ViewVC logotype

Diff of /src/pcl/macros.lisp

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

revision 1.17 by pmai, Sat Aug 24 13:46:52 2002 UTC revision 1.18 by pmai, Mon Aug 26 02:23:14 2002 UTC
# Line 113  Line 113 
113                  (loop (cond ((not (listp form))                  (loop (cond ((not (listp form))
114                               (return-from outer nil))                               (return-from outer nil))
115                              ((eq (car form) 'declare)                              ((eq (car form) 'declare)
116                               (return-from inner 't))                               (return-from inner t))
117                              (t                              (t
118                               (multiple-value-bind (newform macrop)                               (multiple-value-bind (newform macrop)
119                                    (macroexpand-1 form environment)                                    (macroexpand-1 form environment)
# Line 166  Line 166 
166           (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))           (progn (setf ,alist (cons (,make-entry-fn ,key) ,alist))
167                  (car ,alist)))))                  (car ,alist)))))
 (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))))  
169  (defmacro doplist ((key val) plist &body body &environment env)  (defmacro doplist ((key val) plist &body body &environment env)
170    (multiple-value-bind (doc decls bod)    (multiple-value-bind (doc decls bod)
171        (extract-declarations body env)        (extract-declarations body env)
# Line 352  Line 341 
341        (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)        (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
342        (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))))))  
344  (defmacro function-funcall (form &rest args)  (defmacro function-funcall (form &rest args)
345    `(funcall (the function ,form) ,@args))    `(funcall (the function ,form) ,@args))
# Line 391  Line 353 
353  (defvar *redefined-functions* nil)  (defvar *redefined-functions* nil)
355  (defmacro original-definition (name)  (defmacro original-definition (name)
356    `(get ,name ':definition-before-pcl))    `(get ,name :definition-before-pcl))
358  (defun redefine-function (name new)  (defun redefine-function (name new)
359    (pushnew name *redefined-functions*)    (pushnew name *redefined-functions*)

Removed from v.1.17  
changed lines
  Added in v.1.18

  ViewVC Help
Powered by ViewVC 1.1.5