Changeset 8500

Timestamp:

02/07/05 16:24:03 (17 years ago)

Author:

piso

Message:

INCF/DECF: section 5.1.3.

File:

• trunk/j/src/org/armedbear/lisp/define-modify-macro.lisp (modified) (6 diffs)

trunk/j/src/org/armedbear/lisp/define-modify-macro.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003-2005 Peter Graves
-;;; $Id: define-modify-macro.lisp,v 1.2 2005-02-03 02:27:44 piso Exp $
+;;; $Id: define-modify-macro.lisp,v 1.3 2005-02-07 16:24:03 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -18 +18 @@
 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 
-;;; Adapted from CMUCL.
+;;; Adapted from SBCL.
 
-(in-package "SYSTEM")
+(in-package #:system)
 
+;; FIXME See section 5.1.3.
 (defmacro define-modify-macro (name lambda-list function &optional doc-string)
   "Creates a new read-modify-write macro like PUSH or INCF."
@@ -28 +29 @@
   (env (gensym))
   (reference (gensym)))
-    ;; Parse out the variable names and rest arg from the lambda list.
+    ;; Parse out the variable names and &REST arg from the lambda list.
     (do ((ll lambda-list (cdr ll))
    (arg nil))
@@ -37 +38 @@
        (if (symbolp (cadr ll))
      (setq rest-arg (cadr ll))
-     (error "non-symbol &REST arg in definition of ~S" name))
+     (error "Non-symbol &REST arg in definition of ~S." name))
        (if (null (cddr ll))
      (return nil)
-     (error "illegal stuff after &rest arg in DEFINE-MODIFY-MACRO")))
+     (error "Illegal stuff after &REST argument in DEFINE-MODIFY-MACRO.")))
       ((memq arg '(&key &allow-other-keys &aux))
-       (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list" arg))
+       (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
       ((symbolp arg)
        (push arg other-args))
       ((and (listp arg) (symbolp (car arg)))
        (push (car arg) other-args))
-      (t (error "illegal stuff in lambda list of DEFINE-MODIFY-MACRO"))))
+      (t (error "Illegal stuff in DEFINE-MODIFY-MACRO lambda list."))))
     (setq other-args (nreverse other-args))
     `(defmacro ,name (,reference ,@lambda-list &environment ,env)
        ,doc-string
        (multiple-value-bind (dummies vals newval setter getter)
-   (get-setf-expansion ,reference ,env)
+           (get-setf-expansion ,reference ,env)
    (do ((d dummies (cdr d))
         (v vals (cdr v))
         (let-list nil (cons (list (car d) (car v)) let-list)))
        ((null d)
-        (push
-         (list (car newval)
-         ,(if rest-arg
-        `(list* ',function getter ,@other-args ,rest-arg)
-        `(list ',function getter ,@other-args)))
-         let-list)
+        (push (list (car newval)
+                          ,(if rest-arg
+                               `(list* ',function getter ,@other-args ,rest-arg)
+                               `(list ',function getter ,@other-args)))
+                    let-list)
         `(let* ,(nreverse let-list)
      ,setter)))))))
@@ -76 +76 @@
 (defmacro incf (place &optional (delta 1))
   (cond ((symbolp place)
-         `(setq ,place (+ ,place ,delta)))
+         (cond ((constantp delta)
+                `(setq ,place (+ ,place ,delta)))
+               (t
+                ;; See section 5.1.3.
+                (let ((temp (gensym)))
+                  `(let ((,temp ,delta))
+                     (setq ,place (+ ,place ,temp)))))))
         ((and (consp place) (eq (car place) 'THE))
          (let ((res (gensym)))
@@ -86 +92 @@
 (defmacro decf (place &optional (delta 1))
   (cond ((symbolp place)
-         `(setq ,place (- ,place ,delta)))
+         (cond ((constantp delta)
+                `(setq ,place (- ,place ,delta)))
+               (t
+                ;; See section 5.1.3.
+                (let ((temp (gensym)))
+                  `(let ((,temp ,delta))
+                     (setq ,place (- ,place ,temp)))))))
         ((and (consp place) (eq (car place) 'THE))
          (let ((res (gensym)))