/[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.16 by pmai, Mon Aug 19 16:52:09 2002 UTC revision 1.17 by pmai, Sat Aug 24 13:46:52 2002 UTC
# Line 98  Line 98 
98  (defun remtail (list tail)  (defun remtail (list tail)
99    (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))    (if (eq list tail) () (cons (car list) (remtail (cdr list) tail))))
100    
 ;;; ONCE-ONLY does the same thing as it does in zetalisp.  I should have just  
 ;;; lifted it from there but I am honest.  Not only that but this one is  
 ;;; written in Common Lisp.  I feel a lot like bootstrapping, or maybe more  
 ;;; like rebuilding Rome.  
 (defmacro once-only (vars &body body)  
   (let ((gensym-var (gensym))  
         (run-time-vars (gensym))  
         (run-time-vals (gensym))  
         (expand-time-val-forms ()))  
     (dolist (var vars)  
       (push `(if (or (symbolp ,var)  
                      (numberp ,var)  
                      (and (listp ,var)  
                           (member (car ,var) '(quote function))))  
                  ,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))))  
   
101  (eval-when (compile load eval)  (eval-when (compile load eval)
102  (defun extract-declarations (body &optional environment)  (defun extract-declarations (body &optional environment)
103    ;;(declare (values documentation declarations body))    ;;(declare (values documentation declarations body))
# Line 184  Line 155 
155    (intern (string-append sym1 sym2) package))    (intern (string-append sym1 sym2) package))
156    
157  (defmacro check-member (place list &key (test #'eql) (pretty-name place))  (defmacro check-member (place list &key (test #'eql) (pretty-name place))
158    (once-only (place list)    (ext:once-only ((place place) (list list))
159      `(or (member ,place ,list :test ,test)      `(or (member ,place ,list :test ,test)
160           (error "The value of ~A, ~S is not one of ~S."           (error "The value of ~A, ~S is not one of ~S."
161                  ',pretty-name ,place ,list))))                  ',pretty-name ,place ,list))))
162    
163  (defmacro alist-entry (alist key make-entry-fn)  (defmacro alist-entry (alist key make-entry-fn)
164    (once-only (alist key)    (ext:once-only ((alist alist) (key key))
165      `(or (assq ,key ,alist)      `(or (assq ,key ,alist)
166           (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))           (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
167                  (car ,alist)))))                  (car ,alist)))))

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

  ViewVC Help
Powered by ViewVC 1.1.5