/[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.6.1.5 by ram, Tue Oct 4 12:51:03 1994 UTC revision 1.31 by rtoy, Mon Apr 19 02:31:14 2010 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    (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 32  Line 36 
36  ;;;  ;;;
37    
38  (in-package :pcl)  (in-package :pcl)
39    (intl:textdomain "cmucl")
40    
41  (proclaim '(declaration  (declaim (declaration class variable-rebinding method-name
42               #-Genera values          ;I use this so that Zwei can remind                        method-lambda-list))
                                       ;me what values a function returns.  
   
              #-Genera arglist         ;Tells me what the pretty arglist  
                                       ;of something (which probably takes  
                                       ;&rest args) is.  
   
              #-Genera indentation     ;Tells ZWEI how to indent things  
                                       ;like defclass.  
              class  
              variable-rebinding  
              pcl-fast-call  
              method-name  
              method-lambda-list  
              ))  
   
 ;;; Age old functions which CommonLisp cleaned-up away.  They probably exist  
 ;;; in other packages in all CommonLisp implementations, but I will leave it  
 ;;; to the compiler to optimize into calls to them.  
 ;;;  
 ;;; Common Lisp BUG:  
 ;;;    Some Common Lisps define these in the Lisp package which causes  
 ;;;    all sorts of lossage.  Common Lisp should explictly specify which  
 ;;;    symbols appear in the Lisp package.  
 ;;;  
 (eval-when (compile load eval)  
43    
44  (defmacro memq (item list) `(member ,item ,list :test #'eq))  (eval-when (:compile-toplevel :load-toplevel :execute)
45  (defmacro assq (item list) `(assoc ,item ,list :test #'eq))  
46  (defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))    ;; (CLASS-PREDICATE <CLASS-NAME>
47  (defmacro delq (item list) `(delete ,item ,list :test #'eq))    (define-function-name-syntax class-predicate (name)
48  (defmacro posq (item list) `(position ,item ,list :test #'eq))      (when (symbolp (cadr name))
49  (defmacro neq (x y) `(not (eq ,x ,y)))        (values t (cadr name))))
50    
51      ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)
52  (defun make-caxr (n form)    ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.
53    (if (< n 4)    (define-function-name-syntax slot-accessor (name)
54        `(,(nth n '(car cadr caddr cadddr)) ,form)      (values (and (symbolp (cadr name))
55        (make-caxr (- n 4) `(cddddr ,form))))                   (consp (cddr name))
56                     (symbolp (caddr name))
57  (defun make-cdxr (n form)                   (consp (cdddr name))
58    (cond ((zerop n) form)                   (member (cadddr name) '(reader writer boundp)))
59          ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))              (caddr name)))
60          (t (make-cdxr (- n 4) `(cddddr ,form)))))  
61  )    ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))
62      (define-function-name-syntax method (name)
63  (defun true (&rest ignore) (declare (ignore ignore)) t)      (valid-function-name-p (cadr name)))
64  (defun false (&rest ignore) (declare (ignore ignore)) nil)  
65  (defun zero (&rest ignore) (declare (ignore ignore)) 0)    ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))
66      (define-function-name-syntax fast-method (name)
67  (defun make-plist (keys vals)      (valid-function-name-p (cadr name)))
68    (if (null vals)  
69        ()    ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)
70        (list* (car keys)    (define-function-name-syntax effective-method (name)
71               (car vals)      (valid-function-name-p (cadr name))))
72               (make-plist (cdr keys) (cdr vals)))))  
73    (defun pcl-internal-function-name-p (name)
74  (defun remtail (list tail)    (and (consp name)
75    (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))         (memq (car name)
76                 '(class-predicate slot-accessor
77  ;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just                 method fast-method effective-method))))
78  ;;; lifted it from there but I am honest.  Not only that but this one is  
79  ;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more  (import '(lisp::make-keyword))
80  ;;; like rebuilding Rome.  
81  (defmacro once-only (vars &body body)  (defmacro posq (item list)
82    (let ((gensym-var (gensym))    `(position ,item ,list :test #'eq))
83          (run-time-vars (gensym))  
84          (run-time-vals (gensym))  (defmacro neq (x y)
85          (expand-time-val-forms ()))    `(not (eq ,x ,y)))
86      (dolist (var vars)  
87        (push `(if (or (symbolp ,var)  (declaim (inline car-safe))
88                       (numberp ,var)  (defun car-safe (obj)
89                       (and (listp ,var)    (when (consp obj)
90                            (member (car ,var) '(quote function))))      (car obj)))
                  ,var  
                  (let ((,gensym-var (gensym)))  
                    (push ,gensym-var ,run-time-vars)  
                    (push ,var ,run-time-vals)  
                    ,gensym-var))  
             expand-time-val-forms))  
     `(let* (,run-time-vars  
             ,run-time-vals  
             (wrapped-body  
               (let ,(mapcar #'list vars (reverse expand-time-val-forms))  
                 ,@body)))  
        `(let ,(mapcar #'list (reverse ,run-time-vars)  
                              (reverse ,run-time-vals))  
           ,wrapped-body))))  
   
 (eval-when (compile load eval)  
 (defun extract-declarations (body &optional environment)  
   ;;(declare (values documentation declarations body))  
   (let (documentation declarations form)  
     (when (and (stringp (car body))  
                (cdr body))  
       (setq documentation (pop body)))  
     (block outer  
       (loop  
         (when (null body) (return-from outer nil))  
         (setq form (car body))  
         (when (block inner  
                 (loop (cond ((not (listp form))  
                              (return-from outer nil))  
                             ((eq (car form) 'declare)  
                              (return-from inner 't))  
                             (t  
                              (multiple-value-bind (newform macrop)  
                                   (macroexpand-1 form environment)  
                                (if (or (not (eq newform form)) macrop)  
                                    (setq form newform)  
                                  (return-from outer nil)))))))  
           (pop body)  
           (dolist (declaration (cdr form))  
             (push declaration declarations)))))  
     (values documentation  
             (and declarations `((declare ,.(nreverse declarations))))  
             body)))  
 )  
   
 (defun get-declaration (name declarations &optional default)  
   (dolist (d declarations default)  
     (dolist (form (cdr d))  
       (when (and (consp form) (eq (car form) name))  
         (return-from get-declaration (cdr form))))))  
   
   
 #+Lucid  
 (eval-when (compile load eval)  
   (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))  
   
 (defvar *keyword-package* (find-package 'keyword))  
   
 (defun make-keyword (symbol)  
   (intern (symbol-name symbol) *keyword-package*))  
   
 (eval-when (compile load eval)  
   
 (defun string-append (&rest strings)  
   (setq strings (copy-list strings))            ;The explorer can't even  
                                                 ;rplaca an &rest arg?  
   (do ((string-loc strings (cdr string-loc)))  
       ((null string-loc)  
        (apply #'concatenate 'string strings))  
     (rplaca string-loc (string (car string-loc)))))  
 )  
   
 (defun symbol-append (sym1 sym2 &optional (package *package*))  
   (intern (string-append sym1 sym2) package))  
   
 (defmacro check-member (place list &key (test #'eql) (pretty-name place))  
   (once-only (place list)  
     `(or (member ,place ,list :test ,test)  
          (error "The value of ~A, ~S is not one of ~S."  
                 ',pretty-name ,place ,list))))  
   
 (defmacro alist-entry (alist key make-entry-fn)  
   (once-only (alist key)  
     `(or (assq ,key ,alist)  
          (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))  
                 (car ,alist)))))  
   
 ;;; A simple version of destructuring-bind.  
   
 ;;; This does no more error checking than CAR and CDR themselves do.  Some  
 ;;; attempt is made to be smart about preserving intermediate values.  It  
 ;;; could be better, although the only remaining case should be easy for  
 ;;; the compiler to spot since it compiles to PUSH POP.  
 ;;;  
 ;;; Common Lisp BUG:  
 ;;;    Common Lisp should have destructuring-bind.  
 ;;;  
 (defmacro destructuring-bind (pattern form &body body)  
   (multiple-value-bind (ignore declares body)  
       (extract-declarations body)  
     (declare (ignore ignore))  
     (multiple-value-bind (setqs binds)  
         (destructure pattern form)  
       `(let ,binds  
          ,@declares  
          ,@setqs  
          (progn .destructure-form.)  
          . ,body))))  
   
 (eval-when (compile load eval)  
 (defun destructure (pattern form)  
   ;;(declare (values setqs binds))  
   (let ((*destructure-vars* ())  
         (setqs ()))  
     (declare (special *destructure-vars*))  
     (setq *destructure-vars* '(.destructure-form.)  
           setqs (list `(setq .destructure-form. ,form))  
           form '.destructure-form.)  
     (values (nconc setqs (nreverse (destructure-internal pattern form)))  
             (delete nil *destructure-vars*))))  
   
 (defun destructure-internal (pattern form)  
   ;; When we are called, pattern must be a list.  Form should be a symbol  
   ;; which we are free to setq containing the value to be destructured.  
   ;; Optimizations are performed for the last element of pattern cases.  
   ;; we assume that the compiler is smart about gensyms which are bound  
   ;; but only for a short period of time.  
   (declare (special *destructure-vars*))  
   (let ((gensym (gensym))  
         (pending-pops 0)  
         (var nil)  
         (setqs ()))  
     (labels  
         ((make-pop (var form pop-into)  
            (prog1  
              (cond ((zerop pending-pops)  
                     `(progn ,(and var `(setq ,var (car ,form)))  
                             ,(and pop-into `(setq ,pop-into (cdr ,form)))))  
                    ((null pop-into)  
                     (and var `(setq ,var ,(make-caxr pending-pops form))))  
                    (t  
                     `(progn (setq ,pop-into ,(make-cdxr pending-pops form))  
                             ,(and var `(setq ,var (pop ,pop-into))))))  
              (setq pending-pops 0))))  
       (do ((pat pattern (cdr pat)))  
           ((null pat) ())  
         (if (symbolp (setq var (car pat)))  
             (progn  
               #-:coral (unless (memq var '(nil ignore))  
                          (push var *destructure-vars*))  
               #+:coral (push var *destructure-vars*)  
               (cond ((null (cdr pat))  
                      (push (make-pop var form ()) setqs))  
                     ((symbolp (cdr pat))  
                      (push (make-pop var form (cdr pat)) setqs)  
                      (push (cdr pat) *destructure-vars*)  
                      (return ()))  
                     #-:coral  
                     ((memq var '(nil ignore)) (incf pending-pops))  
                     #-:coral  
                     ((memq (cadr pat) '(nil ignore))  
                      (push (make-pop var form ()) setqs)  
                      (incf pending-pops 1))  
                     (t  
                      (push (make-pop var form form) setqs))))  
             (progn  
               (push `(let ((,gensym ()))  
                        ,(make-pop gensym  
                                   form  
                                   (if (symbolp (cdr pat)) (cdr pat) form))  
                        ,@(nreverse  
                            (destructure-internal  
                              (if (consp pat) (car pat) pat)  
                              gensym)))  
                     setqs)  
               (when (symbolp (cdr pat))  
                 (push (cdr pat) *destructure-vars*)  
                 (return)))))  
       setqs)))  
 )  
   
   
 (defmacro collecting-once (&key initial-value)  
    `(let* ((head ,initial-value)  
            (tail ,(and initial-value `(last head))))  
           (values #'(lambda (value)  
                            (if (null head)  
                                (setq head (setq tail (list value)))  
                                (unless (memq value head)  
                                  (setq tail  
                                        (cdr (rplacd tail (list value)))))))  
                   #'(lambda nil head))))  
91    
92  (defmacro doplist ((key val) plist &body body &environment env)  (defmacro doplist ((key val) plist &body body &environment env)
93    (multiple-value-bind (doc decls bod)    (multiple-value-bind (bod decls doc)
94        (extract-declarations body env)        (system:parse-body body env)
95      (declare (ignore doc))      (declare (ignore doc))
96      `(let ((.plist-tail. ,plist) ,key ,val)      `(let ((.plist-tail. ,plist) ,key ,val)
97         ,@decls         ,@decls
98         (loop (when (null .plist-tail.) (return nil))         (loop (when (null .plist-tail.) (return nil))
99               (setq ,key (pop .plist-tail.))               (setq ,key (pop .plist-tail.))
100               (when (null .plist-tail.)               (when (null .plist-tail.)
101                 (error "Malformed plist in doplist, odd number of elements."))                 (error _"Malformed plist in doplist, odd number of elements."))
102               (setq ,val (pop .plist-tail.))               (setq ,val (pop .plist-tail.))
103               (progn ,@bod)))))               (progn ,@bod)))))
104    
105  (defmacro if* (condition true &rest false)  
   `(if ,condition ,true (progn ,@false)))  
   
 (defmacro dolist-carefully ((var list improper-list-handler) &body body)  
   `(let ((,var nil)  
          (.dolist-carefully. ,list))  
      (loop (when (null .dolist-carefully.) (return nil))  
            (if (consp .dolist-carefully.)  
                (progn  
                  (setq ,var (pop .dolist-carefully.))  
                  ,@body)  
                (,improper-list-handler)))))  
   
   ;;  
 ;;;;;; printing-random-thing  
   ;;  
 ;;; Similar to printing-random-object in the lisp machine but much simpler  
 ;;; and machine independent.  
 (defmacro printing-random-thing ((thing stream) &body body)  
   #+cmu17  
   `(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 ">"))))  
   
 (defun printing-random-thing-internal (thing stream)  
   (declare (ignore thing stream))  
   nil)  
   
   ;;  
 ;;;;;;  
   ;;  
   
 (defun capitalize-words (string &optional (dashes-p t))  
   (let ((string (copy-seq (string string))))  
     (declare (string string))  
     (do* ((flag t flag)  
           (length (length string) length)  
           (char nil char)  
           (i 0 (+ i 1)))  
          ((= i length) string)  
       (setq char (elt string i))  
       (cond ((both-case-p char)  
              (if flag  
                  (and (setq flag (lower-case-p char))  
                       (setf (elt string i) (char-upcase char)))  
                  (and (not flag) (setf (elt string i) (char-downcase char))))  
              (setq flag nil))  
             ((char-equal char #\-)  
              (setq flag t)  
              (unless dashes-p (setf (elt string i) #\space)))  
             (t (setq flag nil))))))  
   
 #-(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)  
   
   
106  ;;;  ;;;
107  ;;; FIND-CLASS  ;;; FIND-CLASS
108  ;;;  ;;;
# Line 398  Line 110 
110  ;;;  ;;;
111  (defvar *find-class* (make-hash-table :test #'eq))  (defvar *find-class* (make-hash-table :test #'eq))
112    
 (defun make-constant-function (value)  
   #'(lambda (object)  
       (declare (ignore object))  
       value))  
   
113  (defun function-returning-nil (x)  (defun function-returning-nil (x)
114    (declare (ignore x))    (declare (ignore x))
115    nil)    nil)
116    
 (defun function-returning-t (x)  
   (declare (ignore x))  
   t)  
   
117  (defmacro find-class-cell-class (cell)  (defmacro find-class-cell-class (cell)
118    `(car ,cell))    `(car ,cell))
119    
120  (defmacro find-class-cell-predicate (cell)  (defmacro find-class-cell-predicate (cell)
121    `(cadr ,cell))    `(cadr ,cell))
122    
 (defmacro find-class-cell-make-instance-function-keys (cell)  
   `(cddr ,cell))  
   
123  (defmacro make-find-class-cell (class-name)  (defmacro make-find-class-cell (class-name)
124    (declare (ignore class-name))    (declare (ignore class-name))
125    '(list* nil #'function-returning-nil nil))    '(list* nil #'function-returning-nil nil))
# Line 428  Line 128 
128    (or (gethash symbol *find-class*)    (or (gethash symbol *find-class*)
129        (unless dont-create-p        (unless dont-create-p
130          (unless (legal-class-name-p symbol)          (unless (legal-class-name-p symbol)
131            (error "~S is not a legal class name." symbol))            (error _"~@<~S is not a legal class name.~@:>" symbol))
132          (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))          (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
133    
134  (defvar *create-classes-from-internal-structure-definitions-p* t)  (defvar *create-classes-from-internal-structure-definitions-p* t)
# Line 436  Line 136 
136  (defun find-class-from-cell (symbol cell &optional (errorp t))  (defun find-class-from-cell (symbol cell &optional (errorp t))
137    (or (find-class-cell-class cell)    (or (find-class-cell-class cell)
138        (and *create-classes-from-internal-structure-definitions-p*        (and *create-classes-from-internal-structure-definitions-p*
139             (structure-type-p symbol)             (or (condition-type-p symbol) (structure-type-p symbol))
140             (find-structure-class symbol))             (ensure-non-standard-class symbol))
141        (cond ((null errorp) nil)        (cond ((null errorp) nil)
142              ((legal-class-name-p symbol)              ((legal-class-name-p symbol)
143               (error "No class named: ~S." symbol))               (error _"No class named ~S." symbol))
144              (t              (t
145               (error "~S is not a legal class name." symbol)))))               (error _"~S is not a legal class name." symbol)))))
146    
147  (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))  (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
148    (unless (find-class-cell-class cell)    (unless (find-class-cell-class cell)
# Line 450  Line 150 
150    (find-class-cell-predicate cell))    (find-class-cell-predicate cell))
151    
152  (defun legal-class-name-p (x)  (defun legal-class-name-p (x)
153    (and (symbolp x)    (symbolp x))
        (not (keywordp x))))  
154    
155  (defun find-class (symbol &optional (errorp t) environment)  (defun find-class (symbol &optional (errorp t) environment)
156      "Returns the PCL class metaobject named by SYMBOL. An error of type
157       SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
158       is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
159    (declare (ignore environment))    (declare (ignore environment))
160    (find-class-from-cell    (find-class-from-cell symbol (find-class-cell symbol t) errorp))
    symbol (find-class-cell symbol errorp) errorp))  
161    
162  (defun find-class-predicate (symbol &optional (errorp t) environment)  (defun find-class-predicate (symbol &optional (errorp t) environment)
163    (declare (ignore environment))    (declare (ignore environment))
# Line 465  Line 166 
166    
167  (defvar *boot-state* nil) ; duplicate defvar to defs.lisp  (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
168    
169  ; Use this definition in any CL implementation supporting  ;;;
170  ; both define-compiler-macro and load-time-value.  ;;; When compiling #+BOOTABLE, *BOOT-STATE* is COMPLETE because that's
171  #+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class  ;;; the setting of the host PCL.  We'd could use something like
172  (define-compiler-macro find-class (&whole form  ;;; *COMPILE-STATE* to tell the compiler macro when it should optimize
173                                     symbol &optional (errorp t) environment)  ;;; or not in such a setting.  For simplicity we just don't optimize
174    ;;; in the bootable PCL.
175    ;;;
176    (define-compiler-macro find-class (&whole form symbol
177                                              &optional (errorp t) environment)
178    (declare (ignore environment))    (declare (ignore environment))
179    (if (and (constantp symbol)    (if (and (constantp symbol)
180             (legal-class-name-p (eval symbol))             (legal-class-name-p (eval symbol))
181             (constantp errorp)             (constantp errorp)
182             (member *boot-state* '(braid complete)))             (member *boot-state* '(braid complete))
183               (not (intersection '(:loadable-pcl :bootable-pcl) *features*)))
184        (let ((symbol (eval symbol))        (let ((symbol (eval symbol))
185              (errorp (not (null (eval errorp))))              (errorp (not (null (eval errorp))))
186              (class-cell (make-symbol "CLASS-CELL")))              (class-cell (make-symbol "CLASS-CELL")))
187          `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))          `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
188             (or (find-class-cell-class ,class-cell)             (or (find-class-cell-class ,class-cell)
                #-cmu17  
                (find-class-from-cell ',symbol ,class-cell ,errorp)  
                #+cmu17  
189                 ,(if errorp                 ,(if errorp
190                      `(find-class-from-cell ',symbol ,class-cell t)                      `(find-class-from-cell ',symbol ,class-cell t)
191                      `(and (kernel:class-cell-class                      `(and (kernel:class-cell-class
# Line 490  Line 193 
193                            (find-class-from-cell ',symbol ,class-cell nil))))))                            (find-class-from-cell ',symbol ,class-cell nil))))))
194        form))        form))
195    
196  #-setf  (defun (setf find-class) (new-value name &optional errorp environment)
 (defsetf find-class (symbol &optional (errorp t) environment) (new-value)  
197    (declare (ignore errorp environment))    (declare (ignore errorp environment))
198    `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol))    (if (legal-class-name-p name)
199          (let ((cell (find-class-cell name)))
 (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol)  
   (if (legal-class-name-p symbol)  
       (let ((cell (find-class-cell symbol)))  
200          (setf (find-class-cell-class cell) new-value)          (setf (find-class-cell-class cell) new-value)
201          (when (or (eq *boot-state* 'complete)          (when (and (eq *boot-state* 'complete) (null new-value))
202                    (eq *boot-state* 'braid))            (setf (kernel::find-class name) nil))
203            #+cmu17          (when (memq *boot-state* '(complete braid))
204            (let ((lclass (kernel:layout-class (class-wrapper new-value))))            (when (and new-value (class-wrapper new-value))
205              (setf (lisp:class-name lclass) (class-name new-value))              (setf (find-class-cell-predicate cell)
206              (unless (eq (lisp:find-class symbol nil) lclass)                    (fdefinition (class-predicate-name new-value))))
207                (setf (lisp:find-class symbol) lclass)))            (update-ctors 'setf-find-class :class new-value :name name))
208            new-value)
209            (setf (find-class-cell-predicate cell)        (error _"~S is not a legal class name." name)))
                 (symbol-function (class-predicate-name new-value)))  
           (when (and new-value (not (forward-referenced-class-p new-value)))  
   
             (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))  
               (update-initialize-info-internal  
                (initialize-info new-value (car keys+aok) nil (cdr keys+aok))  
                'make-instance-function)))))  
       (error "~S is not a legal class name." symbol)))  
   
 #-setf  
 (defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)  
   (declare (ignore errorp environment))  
   `(SETF\ PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))  
210    
211  (defun #-setf SETF\ PCL\ FIND-CLASS-PREDICATE #+setf (setf find-class-predicate)  (defun (setf find-class-predicate) (new-value symbol)
           (new-value symbol)  
212    (if (legal-class-name-p symbol)    (if (legal-class-name-p symbol)
213        (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)        (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
214        (error "~S is not a legal class name." symbol)))        (error _"~S is not a legal class name." symbol)))
   
 (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))))  
 ||#  
   
 (defmacro gathering1 (gatherer &body body)  
   `(gathering ((.gathering1. ,gatherer))  
      (macrolet ((gather1 (x) `(gather ,x .gathering1.)))  
        ,@body)))  
   
 ;;;  
 ;;;  
 ;;;  
 (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))))  
   
 ;;;  
 ;;; These are augmented definitions of list-elements and list-tails from  
 ;;; iterate.lisp.  These versions provide the extra :by keyword which can  
 ;;; be used to specify the step function through the list.  
 ;;;  
 (defmacro *list-elements (list &key (by #'cdr))  
   `(let ((tail ,list))  
      #'(lambda (finish)  
          (if (endp tail)  
              (funcall finish)  
              (prog1 (car tail)  
                     (setq tail (funcall ,by tail)))))))  
   
 (defmacro *list-tails (list &key (by #'cdr))  
    `(let ((tail ,list))  
       #'(lambda (finish)  
           (prog1 (if (endp tail)  
                      (funcall finish)  
                      tail)  
                  (setq tail (funcall ,by tail))))))  
215    
216  (defmacro function-funcall (form &rest args)  (defmacro function-funcall (form &rest args)
217    #-cmu `(funcall ,form ,@args)    `(funcall (the function ,form) ,@args))
   #+cmu `(funcall (the function ,form) ,@args))  
218    
219  (defmacro function-apply (form &rest args)  (defmacro function-apply (form &rest args)
220    #-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  
221    
222    
 ;;;  
 ;;; 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  
   )  
   
223  (defsetf slot-value set-slot-value)  (defsetf slot-value set-slot-value)
224    
225  (defvar *redefined-functions* nil)  (defvar *cold-boot-state* nil)
   
 (defmacro original-definition (name)  
   `(get ,name ':definition-before-pcl))  
226    
227  (defun redefine-function (name new)  #+pcl-debug
228    (pushnew name *redefined-functions*)  (defmacro %print (&rest args)
229    (unless (original-definition name)    `(when *cold-boot-state*
230      (setf (original-definition name)       (system:%primitive print ,@args)))
231            (symbol-function name)))  
232    (setf (symbol-function name)  #-pcl-debug
233          (symbol-function new)))  (defmacro %print (&rest args)
234      (declare (ignore args)))
235    
236    #+bootable-pcl
237    (defmacro /show (msg)
238      `(system:%primitive print ,msg))
239    
240    #-bootable-pcl
241    (defmacro /show (&rest args)
242      (declare (ignore args)))
243    

Legend:
Removed from v.1.6.1.5  
changed lines
  Added in v.1.31

  ViewVC Help
Powered by ViewVC 1.1.5