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

Diff of /src/code/macros.lisp

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

revision 1.76 by toy, Mon Oct 28 19:36:59 2002 UTC revision 1.77 by toy, Tue Oct 29 16:42:22 2002 UTC
# Line 886  Line 886 
886  (defmacro push (obj place &environment env)  (defmacro push (obj place &environment env)
887    "Takes an object and a location holding a list.  Conses the object onto    "Takes an object and a location holding a list.  Conses the object onto
888    the list, returning the modified list.  OBJ is evaluated before PLACE."    the list, returning the modified list.  OBJ is evaluated before PLACE."
889    (multiple-value-bind (dummies vals newval setter getter)    (if (and (symbolp place)
890        (get-setf-method place env)             (eq place (macroexpand place env)))
891      (let ((g (gensym)))        `(setq ,place (cons ,obj ,place))
892        `(let* ((,g ,obj)        (multiple-value-bind (dummies vals newval setter getter)
893                ,@(mapcar #'list dummies vals)            (get-setf-expansion place env)
894                (,(car newval) (cons ,g ,getter)))          (let ((g (gensym)))
895          ,setter))))            `(let* ((,g ,obj)
896                      ,@(mapcar #'list dummies vals)
897                      (,(car newval) (cons ,g ,getter)))
898                ,setter)))))
899    
900  (defmacro pushnew (obj place &rest keys &environment env)  (defmacro pushnew (obj place &rest keys &environment env)
901    "Takes an object and a location holding a list.  If the object is already    "Takes an object and a location holding a list.  If the object is already
902    in the list, does nothing.  Else, conses the object onto the list.  Returns    in the list, does nothing.  Else, conses the object onto the list.  Returns
903    NIL.  If there is a :TEST keyword, this is used for the comparison."    NIL.  If there is a :TEST keyword, this is used for the comparison."
904    (multiple-value-bind (vars vals stores setter getter)    (if (and (symbolp place)
905        (get-setf-method place env)             (eq place (macroexpand place env)))
906      (let ((tem (gensym)))        `(setq ,place (adjoin ,obj ,place ,@keys))
907        `(let* ((,tem ,obj)        (multiple-value-bind (vars vals stores setter getter)
908                ,@(mapcar #'list vars vals)            (get-setf-method place env)
909                (,(car stores) (adjoin ,tem ,getter ,@keys)))          (let ((tem (gensym)))
910          ,setter))))            `(let* ((,tem ,obj)
911                      ,@(mapcar #'list vars vals)
912                      (,(car stores) (adjoin ,tem ,getter ,@keys)))
913                ,setter)))))
914    
915    
916  (defmacro pop (place &environment env)  (defmacro pop (place &environment env)
917    "The argument is a location holding a list.  Pops one item off the front    "The argument is a location holding a list.  Pops one item off the front
918    of the list and returns it."    of the list and returns it."
919    (multiple-value-bind (dummies vals newval setter getter)    (if (and (symbolp place)
920        (get-setf-method place env)             (eq place (macroexpand place env)))
921      (do* ((d dummies (cdr d))        `(prog1 (car ,place)
922            (v vals (cdr v))                (setq ,place (cdr ,place)))
923            (let-list nil))        (multiple-value-bind (dummies vals newval setter getter)
924           ((null d)            (get-setf-method place env)
925            (push (list (car newval) getter) let-list)          (do* ((d dummies (cdr d))
926            `(let* ,(nreverse let-list)                (v vals (cdr v))
927               (prog1 (car ,(car newval))                (let-list nil))
928                 (setq ,(car newval) (cdr ,(car newval)))               ((null d)
929                 ,setter)))                (push (list (car newval) getter) let-list)
930        (push (list (car d) (car v)) let-list))))                `(let* ,(nreverse let-list)
931                    (prog1 (car ,(car newval))
932                      (setq ,(car newval) (cdr ,(car newval)))
933                      ,setter)))
934              (push (list (car d) (car v)) let-list)))))
935    
936    
937  (define-modify-macro incf (&optional (delta 1)) +  (define-modify-macro incf (&optional (delta 1)) +

Legend:
Removed from v.1.76  
changed lines
  Added in v.1.77

  ViewVC Help
Powered by ViewVC 1.1.5