ViewVC logotype

Diff of /src/pcl/macros.lisp

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

revision by pw, Sat Mar 23 18:51:19 2002 UTC revision 1.31 by rtoy, Mon Apr 19 02:31:14 2010 UTC
# Line 25  Line 25 
25  ;;; *************************************************************************  ;;; *************************************************************************
26  ;;;  ;;;
28  (ext:file-comment  (file-comment
29    "$Header$")    "$Header$")
30  ;;;  ;;;
31  ;;; Macros global variable definitions, and other random support stuff used  ;;; Macros global variable definitions, and other random support stuff used
# Line 36  Line 36 
36  ;;;  ;;;
38  (in-package :pcl)  (in-package :pcl)
39    (intl:textdomain "cmucl")
41  (declaim (declaration  (declaim (declaration class variable-rebinding method-name
42            values ;;I use this so that Zwei can remind                        method-lambda-list))
                  ;;me what values a function returns.  
           arglist ;;Tells me what the pretty arglist  
                   ;;of something (which probably takes  
                   ;;&rest args) is.  
           indentation     ;;Tells ZWEI how to indent things  
                           ;;like defclass.  
 ;;; 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)  
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))))
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)))))  
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)  
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)))
                  (let ((,gensym-var (gensym)))  
                    (push ,gensym-var ,run-time-vars)  
                    (push ,var ,run-time-vals)  
     `(let* (,run-time-vars  
               (let ,(mapcar #'list vars (reverse expand-time-val-forms))  
        `(let ,(mapcar #'list (reverse ,run-time-vars)  
                              (reverse ,run-time-vals))  
 (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  
         (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))  
                              (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))))  
 (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))))))  
 (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  
          (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 ()))  
         ((make-pop (var form pop-into)  
              (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))))  
                     `(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)))  
               (unless (memq var '(nil ignore))  
                          (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 ()))  
                     ((memq var '(nil ignore)) (incf pending-pops))  
                     ((memq (cadr pat) '(nil ignore))  
                      (push (make-pop var form ()) setqs)  
                      (incf pending-pops 1))  
                      (push (make-pop var form form) setqs))))  
               (push `(let ((,gensym ()))  
                        ,(make-pop gensym  
                                   (if (symbolp (cdr pat)) (cdr pat) form))  
                            (destructure-internal (car pat) gensym)))  
               (when (symbolp (cdr pat))  
                 (push (cdr pat) *destructure-vars*)  
 (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))))  
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)))))
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.)  
                  (setq ,var (pop .dolist-carefully.))  
 ;;;;;; 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)  
   `(print-unreadable-object (,thing ,stream :identity t) ,@body))  
 (defun printing-random-thing-internal (thing stream)  
   (declare (ignore thing stream))  
 (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))))))  
106  ;;;  ;;;
108  ;;;  ;;;
# Line 375  Line 120 
120  (defmacro find-class-cell-predicate (cell)  (defmacro find-class-cell-predicate (cell)
121    `(cadr ,cell))    `(cadr ,cell))
 (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 386  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)))))
134  (defvar *create-classes-from-internal-structure-definitions-p* t)  (defvar *create-classes-from-internal-structure-definitions-p* t)
# Line 394  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)))))
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 408  Line 150 
150    (find-class-cell-predicate cell))    (find-class-cell-predicate cell))
152  (defun legal-class-name-p (x)  (defun legal-class-name-p (x)
153    (and (symbolp x)    (symbolp x))
        (not (keywordp x))))  
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    "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     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."     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 t) errorp))  
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 426  Line 166 
167  (defvar *boot-state* nil) ; duplicate defvar to defs.lisp  (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
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  ; 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")))
# Line 448  Line 193 
193                            (find-class-from-cell ',symbol ,class-cell nil))))))                            (find-class-from-cell ',symbol ,class-cell nil))))))
194        form))        form))
196  (defun (setf find-class) (new-value symbol)  (defun (setf find-class) (new-value name &optional errorp environment)
197    (if (legal-class-name-p symbol)    (declare (ignore errorp environment))
198        (let ((cell (find-class-cell symbol)))    (if (legal-class-name-p name)
199          (let ((cell (find-class-cell name)))
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            (when (memq *boot-state* '(complete braid))
204            (when (and new-value (class-wrapper new-value))            (when (and new-value (class-wrapper new-value))
205              (setf (find-class-cell-predicate cell)              (setf (find-class-cell-predicate cell)
206                    (symbol-function (class-predicate-name new-value))))                    (fdefinition (class-predicate-name new-value))))
207            (when (and new-value (not (forward-referenced-class-p new-value)))            (update-ctors 'setf-find-class :class new-value :name name))
             (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))  
                (initialize-info new-value (car keys+aok) nil (cdr keys+aok))  
208          new-value)          new-value)
209        (error "~S is not a legal class name." symbol)))        (error _"~S is not a legal class name." name)))
211  (defun (setf find-class-predicate) (new-value symbol)  (defun (setf find-class-predicate) (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)))
 (defmacro gathering1 (gatherer &body body)  
   `(gathering ((.gathering1. ,gatherer))  
      (macrolet ((gather1 (x) `(gather ,x .gathering1.)))  
 ;;; 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)  
                  (setq tail (funcall ,by tail))))))  
216  (defmacro function-funcall (form &rest args)  (defmacro function-funcall (form &rest args)
217    `(funcall (the function ,form) ,@args))    `(funcall (the function ,form) ,@args))
# Line 507  Line 222 
223  (defsetf slot-value set-slot-value)  (defsetf slot-value set-slot-value)
225  (defvar *redefined-functions* nil)  (defvar *cold-boot-state* nil)
 (defmacro original-definition (name)  
   `(get ,name ':definition-before-pcl))  
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)))
236    #+bootable-pcl
237    (defmacro /show (msg)
238      `(system:%primitive print ,msg))
240    #-bootable-pcl
241    (defmacro /show (&rest args)
242      (declare (ignore args)))

Removed from v.  
changed lines
  Added in v.1.31

  ViewVC Help
Powered by ViewVC 1.1.5