;;; -*- Mode:LISP; Package:(PCL Lisp 1000); Base:10.; Syntax:Common-lisp; Patch-File: Yes -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This is the 3600 version of the file portable-low.
;;;

(in-package 'pcl)

(defmacro without-interrupts (&body body)
  `(zl:without-interrupts ,.body))

  ;;
;;;;;; Load Time Constants
  ;;
;;;
;;;   WHEN                       EXPANDS-TO
;;;   compile to a file          (#:EVAL-AT-LOAD-TIME-MARKER . <form>)
;;;   compile to core            '<result of evaluating form>
;;;   not in compiler at all     (progn <form>)
;;;
;;; Believe me when I tell you that I don't know why it is I need both a
;;; transformer and an optimizer to get this to work.  Believe me when I
;;; tell you that I don't really care why either.
;;;
(defmacro load-time-eval (form)
  ;; The interpreted definition of load-time-eval.  This definition
  ;; never gets compiled.
  (let ((value (gensym)))
    `(multiple-value-bind (,value)
	 (progn ,form)
       ,value)))

(compiler:deftransformer (load-time-eval optimize-load-time-eval) (form)
  (compiler-is-a-loser-internal form))

(compiler:defoptimizer (load-time-eval transform-load-time-eval) (form)
  (compiler-is-a-loser-internal form))

(defun compiler-is-a-loser-internal (form)  
  ;; When compiling a call to load-time-eval the compiler will call
  ;; this optimizer before the macro expansion.
  (if zl:compiler:(and (boundp '*compile-function*) ;Probably don't need
						    ;this boundp check
						    ;but it can't hurt.
		       (funcall *compile-function* :to-core-p))
      ;; Compiling to core.
      ;; Evaluate the form now, and expand into a constant
      ;; (the result of evaluating the form).
      `',(eval (cadr form))
      ;; Compiling to a file.
      ;; Generate the magic which causes the dumper compiler and loader
      ;; to do magic and evaluate the form at load time.
      `',(cons compiler:eval-at-load-time-marker (cadr form))))

  ;;   
;;;;;; Memory Block primitives.
  ;;   


(defmacro make-memory-block (size &optional area)
  `(make-array ,size :area ,area))

(defmacro memory-block-ref (block offset)	;Don't want to go faster yet.
  `(aref ,block ,offset))

(defvar class-wrapper-area)
(eval-when (load eval)
  (si:make-area :name 'class-wrapper-area
		:room t
		:gc :static))

(scl:defsubst iwmc-class-p (x)
  (and (si:arrayp x)
       (not (zerop (si:array-named-structure-bit x)))
       (eq (aref x 0) 'iwmc-class)))


;;;
;;; Reimplementation OF %INSTANCE
;;;
;;; We take advantage of the fact that Symbolics defstruct doesn't depend on
;;; the fact that Common Lisp defstructs are fixed length.  This allows us to
;;; use defstruct to define a new type, but use internal structure allocation
;;; code to make structure of that type of any length we like.
;;;
;;; In Symbolics Common Lisp, structures are really just arrays with a magic
;;; bit set.  The first element of the array points to the symbol which is
;;; the name of this structure.  The remaining elements are used for the
;;; slots of the structure.
;;;
;;; In our %instance datatype, the array look like
;;;
;;;  element 0:  The symbol %INSTANCE, this tells the system what kind of
;;;              structure this is.
;;;  element 1:  The meta-class of this %INSTANCE
;;;  element 2:  This is used to store the value of %instance-ref slot 0.
;;;  element 3:  This is used to store the value of %instance-ref slot 1.
;;;     .                                .
;;;     .                                .
;;;
(defstruct (%instance (:print-function print-instance)
		      (:constructor nil)
		      (:predicate %instancep))
  meta-class)

(zl:defselect ((:property %instance zl:named-structure-invoke))
  (:print-self (iwmc-class stream print-depth *print-escape*)
	       (print-instance iwmc-class stream print-depth))
  (:describe   (iwmc-class &optional no-complaints)
	       (ignore no-complaints)
	       (describe-instance iwmc-class)))

(defmacro %allocate-instance (meta-class size)
  (let ((instance-var (gensym)))
    `(let ((,instance-var (make-array (+ 2 ,size))))
       (setf (SI:ARRAY-NAMED-STRUCTURE-BIT ,instance-var) 1
	     (aref ,instance-var 0) '%instance
	     (aref ,instance-var 1) ,meta-class)
       ,instance-var)))

(defmacro %instance-ref (instance index)
  `(aref ,instance (+ ,index 2)))

  ;;   
;;;;;; Cache No's
  ;;  

(zl:defsubst symbol-cache-no (symbol mask)
  (logand (si:%pointer symbol) mask))		    

(compiler:defoptimizer (symbol-cache-no fold-symbol-cache-no) (form)
  (if (and (constantp (cadr form))		                    
	   (constantp (caddr form)))
      `(load-time-eval (logand (si:%pointer ,(cadr form)) ,(caddr form)))
      form))

(defmacro object-cache-no (object mask)
  `(logand (si:%pointer ,object) ,mask))

  ;;   
;;;;;; printing-random-thing-internal
  ;;
(defun printing-random-thing-internal (thing stream)
  (format stream "~O" (si:%pointer thing)))

  ;;   
;;;;;; function-arglist
  ;;
;;;
;;; This is hard, I am sweating.
;;; 
(defun function-arglist (function) (zl:arglist function t))

(defun function-pretty-arglist (function) (zl:arglist function))

;;; These should be moved into 3600-high when that file exists.
;;; 
;(defun set-function-pretty-arglist (function new-value)
;  (declare (ignore function new-value)))
;
; But this does...
;(zl:advise zl:arglist
;	   :after
;	   pcl-patch-to-arglist
;	   ()
;  (let ((function (car zl:arglist))
;	(generic-function nil))
;    (when (and (symbolp function)
;	       (fboundp function)
;	       (fboundp 'funcallable-instance-p)
;	       (fboundp 'generic-function-p)
;	       (funcallable-instance-p (symbol-function function))
;	       (generic-function-p (symbol-function function)))
;	(setq values
;	      (list (generic-function-pretty-arglist generic-function))))))

(defun pcl-function-name-advice-1 (arglist values &aux temp)
  (if (and (fboundp 'funcallable-instance-p)
	   (fboundp 'generic-function-name)
	   (funcallable-instance-p (car arglist))
	   (setq temp (generic-function-name (car arglist))))
      (list temp)
      values))


(zl:advise si:function-name :after pcl-function-name-advice ()
  (setq values (pcl-function-name-advice-1 zl:arglist values)))

(zl:advise si:print-lexical-closure :around
				    pcl-print-lexical-closure-advice
				    ()
  (if (and (fboundp 'funcallable-instance-p)
	   (fboundp 'generic-function-p)
	   (funcallable-instance-p (car arglist))
	   (generic-function-p (car arglist)))
      (print-instance (car arglist) (cadr arglist) ())
      :do-it))

(defvar dbg:*closure-names* (make-hash-table :test #'eq :size 500))

(defun set-function-name-1 (fn new-name ignore)
  (cond ((or (funcallable-instance-p fn)
	     (si:lexical-closure-p fn))
	 (let ((env (si:lexical-closure-environment fn)))
	   (setf (gethash env dbg:*closure-names*) new-name)))	   
	((compiled-function-p fn)
	 (let* ((cca (si:compiled-function-cca fn))
		(debug (si:%p-contents-offset cca 2)))
	   (setf (car debug) new-name)))
	((and (listp fn)
	      (eq (car fn) 'si:digested-lambda))
	 (let ((debug (caddr fn)))
	   (setf (caddr fn) (cons new-name (cdr debug))))))
  fn)

(defun record-definition (type spec &rest args)
  (declare (ignore args))
  (case type
;   (method (if (listp (cadr spec))
;        	(si:record-source-file-name spec 'method)
;		(si:record-source-file-name spec 'method)))
    (class (si:record-source-file-name spec 'defclass)
;	   (si:record-source-file-name spec 'deftype)
	   )))

;;;
;;; define a function spec which we use for defmethod and defmethod-setf
;;; method functions.  See code for the expansion of defmethod(-setf).
;;; This also allows us to make compiler-warnings nice, make who-calls work
;;; nicely and all sorts of other wonderful things.  This implementation
;;; could use performance tuning, but note that all that slows down is
;;; loading of defmethods and using the tools like who-calls, parts of the
;;; debugger and stuff like that.
;;; 
(defvar *defmethod-fdefs* (make-hash-table :test #'equal :size 500))
(defvar *defmethod-setf-fdefs* (make-hash-table :test #'equal :size 500))

(si:define-function-spec-handler method (op spec &optional arg1 arg2)
  (if (eq op 'sys:validate-function-spec)
      (and (let ((gspec (cadr spec)))
	     (or (symbolp gspec)
		 (and (listp gspec)
		      (eq (car gspec) 'setf)
		      (symbolp (cadr gspec))
		      (null (cddr gspec)))))
	   (let ((tail (cddr spec)))
	     (loop (cond ((listp (car tail)) (return t))
			 ((symbolp (pop tail)))
			 (t (return nil))))))
      (let ((table (if (listp (cadr spec))
		       *defmethod-setf-fdefs*
		       *defmethod-fdefs*)))
	(case op
	  ((si:fdefinedp si:fdefinition)
	   (gethash (cddr spec) table))
	  (si:fdefine
	    (setf (gethash (cddr spec) table) arg1))
	  (otherwise
	    (si:function-spec-default-handler op spec arg1 arg2))))))


(eval-when (load eval)
  (setf
    (get 'defmethod      'zwei:definition-function-spec-type) 'defun
    (get 'defmethod-setf 'zwei:definition-function-spec-type) 'defun
    (get 'method 'si:definition-type-name) "method"
    (get 'method 'si:definition-type-name) "method"

    (get 'declass 'zwei:definition-function-spec-type) 'defclass
    (get 'defclass 'si:definition-type-name) "Class"
    (get 'defclass 'zwei:definition-function-spec-finder-template) '(0 1))
  )


(defun (:property defmethod zwei::definition-function-spec-parser) (bp)
  (zwei:parse-pcl-defmethod-for-zwei bp nil))

(defun (:property defmethod-setf zwei::definition-function-spec-parser) (bp)
  (zwei:parse-pcl-defmethod-for-zwei bp t))

zwei:
(defun parse-pcl-defmethod-for-zwei (bp-after-defmethod setfp)
  (block parser
    (flet ((barf ()
	     (return-from parser (values nil nil nil t))))
      (let ((bp-after-generic (forward-sexp bp-after-defmethod))
	    (qualifiers ())
	    (specializers ())
	    (spec nil)
	    (ignore1 nil)
	    (ignore2 nil))
	(when bp-after-generic
	  (multiple-value-bind (generic error-p)
	      (read-fspec-item-from-interval bp-after-defmethod
					     bp-after-generic)
	    (if error-p
		(barf)
		(let* ((bp1 bp-after-generic)
		       (bp2 (forward-sexp bp1)))
		  (cl:loop
		    (if (null bp2)
			(barf)
			(multiple-value-bind (item error-p)
			    (read-fspec-item-from-interval bp1 bp2)
			  (cond (error-p (barf))
				((listp item)
				 (setq qualifiers (nreverse qualifiers))
				 (cl:multiple-value-setq (ignore1
							  ignore2
							  specializers)
				   (pcl::parse-specialized-lambda-list item))
				 (setq spec (pcl::make-method-spec 
					      (if setfp
						  `(cl:setf ,generic)
						  generic)
					      qualifiers
					      specializers))
				 (return (values spec
						 'defun
						 (string-interval
						   bp-after-defmethod
						   bp2))))
				(t (push item qualifiers)
				   (setq bp1 bp2
					 bp2 (forward-sexp bp2)))))))))))))))



;;;
;;; Teach zwei that when it gets the name of a generic function as an argument
;;; it should edit all the methods of that generic function.  This works for
;;; ED as well as meta-point.
;;;
(zl:advise (flavor:method :SETUP-FUNCTION-SPECS-TO-EDIT zwei:ZMACS-EDITOR)
	   :around
	   setup-function-specs-to-edit-advice
	   ()
  (let ((old-definitions (cadddr arglist))
	(new-definitions ())
	(new nil))
    (dolist (old old-definitions)
      (setq new (setup-function-specs-to-edit-advice-1 old))
      (push (or new (list old)) new-definitions))
    (setf (cadddr arglist) (apply #'append (reverse new-definitions)))
    :do-it))

(defun setup-function-specs-to-edit-advice-1 (spec)
  (and (or (symbolp spec)
	   (and (listp spec) (eq (car spec) 'setf)))
       (gboundp spec)
       (generic-function-p (gdefinition spec))
       (mapcar #'(lambda (m)
		   (make-method-spec spec
				     (method-options m)
				     (unparse-specializers
				       (method-type-specifiers m))))
	       (generic-function-methods (gdefinition spec)))))