/[cmucl]/src/pcl/macros.lisp
ViewVC logotype

Diff of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by pw, Thu Feb 6 21:24:14 1997 UTC revision 1.7.2.3 by pw, Sat Mar 23 18:51:19 2002 UTC
# Line 24  Line 24 
24  ;;; Suggestions, comments and requests for improvements are also welcome.  ;;; Suggestions, comments and requests for improvements are also welcome.
25  ;;; *************************************************************************  ;;; *************************************************************************
26  ;;;  ;;;
27    
28    (ext:file-comment
29      "$Header$")
30    ;;;
31  ;;; Macros global variable definitions, and other random support stuff used  ;;; Macros global variable definitions, and other random support stuff used
32  ;;; by the rest of the system.  ;;; by the rest of the system.
33  ;;;  ;;;
# Line 33  Line 37 
37    
38  (in-package :pcl)  (in-package :pcl)
39    
40  (proclaim '(declaration  (declaim (declaration
41               #-Genera values          ;I use this so that Zwei can remind            values ;;I use this so that Zwei can remind
42                                        ;me what values a function returns.                   ;;me what values a function returns.
43    
44               #-Genera arglist         ;Tells me what the pretty arglist            arglist ;;Tells me what the pretty arglist
45                                        ;of something (which probably takes                    ;;of something (which probably takes
46                                        ;&rest args) is.                    ;;&rest args) is.
47    
48               #-Genera indentation     ;Tells ZWEI how to indent things            indentation     ;;Tells ZWEI how to indent things
49                                        ;like defclass.                            ;;like defclass.
50               class            class
51               variable-rebinding            variable-rebinding
52               pcl-fast-call            pcl-fast-call
53               method-name            method-name
54               method-lambda-list            method-lambda-list
55               ))            ))
56    
57  ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist  ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist
58  ;;; in other packages in all CommonLisp implementations, but I will leave it  ;;; in other packages in all CommonLisp implementations, but I will leave it
# Line 160  Line 164 
164          (return-from get-declaration (cdr form))))))          (return-from get-declaration (cdr form))))))
165    
166    
 #+Lucid  
 (eval-when (compile load eval)  
   (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))  
   
167  (defvar *keyword-package* (find-package 'keyword))  (defvar *keyword-package* (find-package 'keyword))
168    
169  (defun make-keyword (symbol)  (defun make-keyword (symbol)
# Line 256  Line 256 
256            ((null pat) ())            ((null pat) ())
257          (if (symbolp (setq var (car pat)))          (if (symbolp (setq var (car pat)))
258              (progn              (progn
259                #-:coral (unless (memq var '(nil ignore))                (unless (memq var '(nil ignore))
260                           (push var *destructure-vars*))                           (push var *destructure-vars*))
               #+:coral (push var *destructure-vars*)  
261                (cond ((null (cdr pat))                (cond ((null (cdr pat))
262                       (push (make-pop var form ()) setqs))                       (push (make-pop var form ()) setqs))
263                      ((symbolp (cdr pat))                      ((symbolp (cdr pat))
264                       (push (make-pop var form (cdr pat)) setqs)                       (push (make-pop var form (cdr pat)) setqs)
265                       (push (cdr pat) *destructure-vars*)                       (push (cdr pat) *destructure-vars*)
266                       (return ()))                       (return ()))
                     #-:coral  
267                      ((memq var '(nil ignore)) (incf pending-pops))                      ((memq var '(nil ignore)) (incf pending-pops))
                     #-:coral  
268                      ((memq (cadr pat) '(nil ignore))                      ((memq (cadr pat) '(nil ignore))
269                       (push (make-pop var form ()) setqs)                       (push (make-pop var form ()) setqs)
270                       (incf pending-pops 1))                       (incf pending-pops 1))
# Line 279  Line 276 
276                                    form                                    form
277                                    (if (symbolp (cdr pat)) (cdr pat) form))                                    (if (symbolp (cdr pat)) (cdr pat) form))
278                         ,@(nreverse                         ,@(nreverse
279                             (destructure-internal                             (destructure-internal (car pat) gensym)))
                              (if (consp pat) (car pat) pat)  
                              gensym)))  
280                      setqs)                      setqs)
281                (when (symbolp (cdr pat))                (when (symbolp (cdr pat))
282                  (push (cdr pat) *destructure-vars*)                  (push (cdr pat) *destructure-vars*)
# Line 333  Line 328 
328  ;;; Similar to printing-random-object in the lisp machine but much simpler  ;;; Similar to printing-random-object in the lisp machine but much simpler
329  ;;; and machine independent.  ;;; and machine independent.
330  (defmacro printing-random-thing ((thing stream) &body body)  (defmacro printing-random-thing ((thing stream) &body body)
331    #+cmu17    `(print-unreadable-object (,thing ,stream :identity t) ,@body))
   `(print-unreadable-object (,thing ,stream :identity t) ,@body)  
   #-cmu17  
   (once-only (thing stream)  
     `(progn  
        (when *print-readably*  
          (error "~S cannot be printed readably." thing))  
        (format ,stream "#<")  
        ,@body  
        (format ,stream " ")  
        (printing-random-thing-internal ,thing ,stream)  
        (format ,stream ">"))))  
332    
333  (defun printing-random-thing-internal (thing stream)  (defun printing-random-thing-internal (thing stream)
334    (declare (ignore thing stream))    (declare (ignore thing stream))
# Line 374  Line 358 
358               (unless dashes-p (setf (elt string i) #\space)))               (unless dashes-p (setf (elt string i) #\space)))
359              (t (setq flag nil))))))              (t (setq flag nil))))))
360    
 #-(or lucid kcl)  
 (eval-when (compile load eval)  
 ;(warn "****** Things will go faster if you fix define-compiler-macro")  
 )  
   
 #-cmu  
 (defmacro define-compiler-macro (name arglist &body body)  
   #+(or lucid kcl)  
   `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro  
             ,name ,arglist  
             ,@body)  
   #-(or kcl lucid)  
   (declare (ignore name arglist body))  
   #-(or kcl lucid)  
   nil)  
   
   
361  ;;;  ;;;
362  ;;; FIND-CLASS  ;;; FIND-CLASS
363  ;;;  ;;;
# Line 398  Line 365 
365  ;;;  ;;;
366  (defvar *find-class* (make-hash-table :test #'eq))  (defvar *find-class* (make-hash-table :test #'eq))
367    
 (defun make-constant-function (value)  
   #'(lambda (object)  
       (declare (ignore object))  
       value))  
   
368  (defun function-returning-nil (x)  (defun function-returning-nil (x)
369    (declare (ignore x))    (declare (ignore x))
370    nil)    nil)
371    
 (defun function-returning-t (x)  
   (declare (ignore x))  
   t)  
   
372  (defmacro find-class-cell-class (cell)  (defmacro find-class-cell-class (cell)
373    `(car ,cell))    `(car ,cell))
374    
# Line 454  Line 412 
412         (not (keywordp x))))         (not (keywordp x))))
413    
414  (defun find-class (symbol &optional (errorp t) environment)  (defun find-class (symbol &optional (errorp t) environment)
415      "Returns the PCL class metaobject named by SYMBOL. An error of type
416       SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
417       is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
418    (declare (ignore environment))    (declare (ignore environment))
419    (find-class-from-cell    (find-class-from-cell
420     symbol (find-class-cell symbol errorp) errorp))     symbol (find-class-cell symbol t) errorp))
421    
422  (defun find-class-predicate (symbol &optional (errorp t) environment)  (defun find-class-predicate (symbol &optional (errorp t) environment)
423    (declare (ignore environment))    (declare (ignore environment))
# Line 467  Line 428 
428    
429  ; Use this definition in any CL implementation supporting  ; Use this definition in any CL implementation supporting
430  ; both define-compiler-macro and load-time-value.  ; both define-compiler-macro and load-time-value.
431  #+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class  ; Note that in CMU, lisp:find-class /= pcl:find-class
432  (define-compiler-macro find-class (&whole form  (define-compiler-macro find-class (&whole form
433                                     symbol &optional (errorp t) environment)                                     symbol &optional (errorp t) environment)
434    (declare (ignore environment))    (declare (ignore environment))
# Line 480  Line 441 
441              (class-cell (make-symbol "CLASS-CELL")))              (class-cell (make-symbol "CLASS-CELL")))
442          `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))          `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
443             (or (find-class-cell-class ,class-cell)             (or (find-class-cell-class ,class-cell)
                #-cmu17  
                (find-class-from-cell ',symbol ,class-cell ,errorp)  
                #+cmu17  
444                 ,(if errorp                 ,(if errorp
445                      `(find-class-from-cell ',symbol ,class-cell t)                      `(find-class-from-cell ',symbol ,class-cell t)
446                      `(and (kernel:class-cell-class                      `(and (kernel:class-cell-class
# Line 490  Line 448 
448                            (find-class-from-cell ',symbol ,class-cell nil))))))                            (find-class-from-cell ',symbol ,class-cell nil))))))
449        form))        form))
450    
451  #-setf  (defun (setf find-class) (new-value symbol)
 (defsetf find-class (symbol &optional (errorp t) environment) (new-value)  
   (declare (ignore errorp environment))  
   `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))  
   
 (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)  
452    (if (legal-class-name-p symbol)    (if (legal-class-name-p symbol)
453        (let ((cell (find-class-cell symbol)))        (let ((cell (find-class-cell symbol)))
454          (setf (find-class-cell-class cell) new-value)          (setf (find-class-cell-class cell) new-value)
455          (when (or (eq *boot-state* 'complete)          (when (or (eq *boot-state* 'complete)
456                    (eq *boot-state* 'braid))                    (eq *boot-state* 'braid))
457            #+cmu17            (when (and new-value (class-wrapper new-value))
458            (let ((lclass (kernel:layout-class (class-wrapper new-value))))              (setf (find-class-cell-predicate cell)
459              (setf (lisp:class-name lclass) (class-name new-value))                    (symbol-function (class-predicate-name new-value))))
             (unless (eq (lisp:find-class symbol nil) lclass)  
               (setf (lisp:find-class symbol) lclass)))  
   
           (setf (find-class-cell-predicate cell)  
                 (symbol-function (class-predicate-name new-value)))  
460            (when (and new-value (not (forward-referenced-class-p new-value)))            (when (and new-value (not (forward-referenced-class-p new-value)))
461    
462              (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))              (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
463                (update-initialize-info-internal                (update-initialize-info-internal
464                 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))                 (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
465                 'make-instance-function)))))                 'make-instance-function))))
466            new-value)
467        (error "~S is not a legal class name." symbol)))        (error "~S is not a legal class name." symbol)))
468    
469  #-setf  (defun (setf find-class-predicate) (new-value symbol)
 (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)  
   (declare (ignore errorp environment))  
   `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))  
   
 (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)  
           (new-value symbol)  
470    (if (legal-class-name-p symbol)    (if (legal-class-name-p symbol)
471        (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)        (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
472        (error "~S is not a legal class name." symbol)))        (error "~S is not a legal class name." symbol)))
473    
 (defun find-wrapper (symbol)  
   (class-wrapper (find-class symbol)))  
   
 #|| ; Anything that used this should use eval instead.  
 (defun reduce-constant (old)  
   (let ((new (eval old)))  
     (if (eq new old)  
         new  
         (if (constantp new)  
             (reduce-constant new)  
             new))))  
 ||#  
   
474  (defmacro gathering1 (gatherer &body body)  (defmacro gathering1 (gatherer &body body)
475    `(gathering ((.gathering1. ,gatherer))    `(gathering ((.gathering1. ,gatherer))
476       (macrolet ((gather1 (x) `(gather ,x .gathering1.)))       (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
477         ,@body)))         ,@body)))
478    
 ;;;  
 ;;;  
 ;;;  
 (defmacro vectorizing (&key (size 0))  
   `(let* ((limit ,size)  
           (result (make-array limit))  
           (index 0))  
      (values #'(lambda (value)  
                  (if (= index limit)  
                      (error "vectorizing more elements than promised.")  
                      (progn  
                        (setf (svref result index) value)  
                        (incf index)  
                        value)))  
              #'(lambda () result))))  
479    
480  ;;;  ;;;
481  ;;; These are augmented definitions of list-elements and list-tails from  ;;; These are augmented definitions of list-elements and list-tails from
# Line 584  Line 499 
499                   (setq tail (funcall ,by tail))))))                   (setq tail (funcall ,by tail))))))
500    
501  (defmacro function-funcall (form &rest args)  (defmacro function-funcall (form &rest args)
502    #-cmu `(funcall ,form ,@args)    `(funcall (the function ,form) ,@args))
   #+cmu `(funcall (the function ,form) ,@args))  
503    
504  (defmacro function-apply (form &rest args)  (defmacro function-apply (form &rest args)
505    #-cmu `(apply ,form ,@args)    `(apply (the function ,form) ,@args))
   #+cmu `(apply (the function ,form) ,@args))  
   
   
 ;;;  
 ;;; Convert a function name to its standard setf function name.  We have to  
 ;;; do this hack because not all Common Lisps have yet converted to having  
 ;;; setf function specs.  
 ;;;  
 ;;; In a port that does have setf function specs you can use those just by  
 ;;; making the obvious simple changes to these functions.  The rest of PCL  
 ;;; believes that there are function names like (SETF <foo>), this is the  
 ;;; only place that knows about this hack.  
 ;;;  
 (eval-when (compile load eval)  
 ; In 15e (and also 16c), using the built in setf mechanism costs  
 ; a hash table lookup every time a setf function is called.  
 ; Uncomment the next line to use the built in setf mechanism.  
 ;#+cmu (pushnew :setf *features*)  
 )  
   
 (eval-when (compile load eval)  
   
 #-setf  
 (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))  
   
 (defun get-setf-function-name (name)  
   #+setf `(setf ,name)  
   #-setf  
   (or (gethash name *setf-function-names*)  
       (setf (gethash name *setf-function-names*)  
             (let ((pkg (symbol-package name)))  
               (if pkg  
                   (intern (format nil  
                                   "SETF ~A ~A"  
                                   (package-name pkg)  
                                   (symbol-name name))  
                           *the-pcl-package*)  
                   (make-symbol (format nil "SETF ~A" (symbol-name name))))))))  
   
 ;;;  
 ;;; Call this to define a setf macro for a function with the same behavior as  
 ;;; specified by the SETF function cleanup proposal.  Specifically, this will  
 ;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).  
 ;;;  
 ;;; do-standard-defsetf                  A macro interface for use at top level  
 ;;;                                      in files.  Unfortunately, users may  
 ;;;                                      have to use this for a while.  
 ;;;  
 ;;; do-standard-defsetfs-for-defclass    A special version called by defclass.  
 ;;;  
 ;;; do-standard-defsetf-1                A functional interface called by the  
 ;;;                                      above, defmethod and defgeneric.  
 ;;;                                      Since this is all a crock anyways,  
 ;;;                                      users are free to call this as well.  
 ;;;  
 (defmacro do-standard-defsetf (&rest function-names)  
   `(eval-when (compile load eval)  
      (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))  
   
 (defun do-standard-defsetfs-for-defclass (accessors)  
   (dolist (name accessors) (do-standard-defsetf-1 name)))  
   
 (defun do-standard-defsetf-1 (function-name)  
   #+setf  
   (declare (ignore function-name))  
   #+setf nil  
   #-setf  
   (unless (and (setfboundp function-name)  
                (get function-name 'standard-setf))  
     (setf (get function-name 'standard-setf) t)  
     (let* ((setf-function-name (get-setf-function-name function-name)))  
   
       #+Genera  
       (let ((fn #'(lambda (form)  
                     (lt::help-defsetf  
                       '(&rest accessor-args) '(new-value) function-name 'nil  
                       `(`(,',setf-function-name ,new-value .,accessor-args))  
                       form))))  
         (setf (get function-name 'lt::setf-method) fn  
               (get function-name 'lt::setf-method-internal) fn))  
   
       #+Lucid  
       (lucid::set-simple-setf-method  
         function-name  
         #'(lambda (form new-value)  
             (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x))  
                                      (cdr form)))  
                    (vars (mapcar #'car bindings)))  
               ;; This may wrap spurious LET bindings around some form,  
               ;;   but the PQC compiler will unwrap then.  
               `(LET (,.bindings)  
                  (,setf-function-name ,new-value . ,vars)))))  
   
       #+kcl  
       (let ((helper (gensym)))  
         (setf (macro-function helper)  
               #'(lambda (form env)  
                   (declare (ignore env))  
                   (let* ((loc-args (butlast (cdr form)))  
                          (bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) loc-args))  
                          (vars (mapcar #'car bindings)))  
                     `(let ,bindings  
                        (,setf-function-name ,(car (last form)) ,@vars)))))  
         (eval `(defsetf ,function-name ,helper)))  
       #+Xerox  
       (flet ((setf-expander (body env)  
                (declare (ignore env))  
                (let ((temps  
                        (mapcar #'(lambda (x) (declare (ignore x)) (gensym))  
                                (cdr body)))  
                      (forms (cdr body))  
                      (vars (list (gensym))))  
                  (values temps  
                          forms  
                          vars  
                          `(,setf-function-name ,@vars ,@temps)  
                          `(,function-name ,@temps)))))  
         (let ((setf-method-expander (intern (concatenate 'string  
                                                          (symbol-name function-name)  
                                                          "-setf-expander")  
                                      (symbol-package function-name))))  
           (setf (get function-name :setf-method-expander) setf-method-expander  
                 (symbol-function setf-method-expander) #'setf-expander)))  
   
       #-(or Genera Lucid kcl Xerox)  
       (eval `(defsetf ,function-name (&rest accessor-args) (new-value)  
                (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))  
                       (vars (mapcar #'car bindings)))  
                   `(let ,bindings  
                       (,',setf-function-name ,new-value ,@vars)))))  
   
       )))  
   
 (defun setfboundp (symbol)  
   #+Genera (not (null (get-properties (symbol-plist symbol)  
                                       'lt::(derived-setf-function trivial-setf-method  
                                             setf-equivalence setf-method))))  
   #+Lucid  (locally  
              (declare (special lucid::*setf-inverse-table*  
                                lucid::*simple-setf-method-table*  
                                lucid::*setf-method-expander-table*))  
              (or (gethash symbol lucid::*setf-inverse-table*)  
                  (gethash symbol lucid::*simple-setf-method-table*)  
                  (gethash symbol lucid::*setf-method-expander-table*)))  
   #+kcl    (or (get symbol 'si::setf-method)  
                (get symbol 'si::setf-update-fn)  
                (get symbol 'si::setf-lambda))  
   #+Xerox  (or (get symbol :setf-inverse)  
                (get symbol 'il:setf-inverse)  
                (get symbol 'il:setfn)  
                (get symbol :shared-setf-inverse)  
                (get symbol :setf-method-expander)  
                (get symbol 'il:setf-method-expander))  
   #+:coral (or (get symbol 'ccl::setf-inverse)  
                (get symbol 'ccl::setf-method-expander))  
   #+cmu (fboundp `(setf ,symbol))  
   #-(or Genera Lucid KCL Xerox :coral cmu) nil)  
   
 );eval-when  
506    
507    
 ;;;  
 ;;; PCL, like user code, must endure the fact that we don't have a properly  
 ;;; working setf.  Many things work because they get mentioned by a defclass  
 ;;; or defmethod before they are used, but others have to be done by hand.  
 ;;;  
 (do-standard-defsetf  
   class-wrapper                                 ;***  
   generic-function-name  
   method-function-plist  
   method-function-get  
   plist-value  
   object-plist  
   gdefinition  
   slot-value-using-class  
   )  
   
508  (defsetf slot-value set-slot-value)  (defsetf slot-value set-slot-value)
509    
510  (defvar *redefined-functions* nil)  (defvar *redefined-functions* nil)

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.7.2.3

  ViewVC Help
Powered by ViewVC 1.1.5