Changeset 8500


Ignore:
Timestamp:
02/07/05 16:24:03 (17 years ago)
Author:
piso
Message:

INCF/DECF: section 5.1.3.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/define-modify-macro.lisp

    r8452 r8500  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: define-modify-macro.lisp,v 1.2 2005-02-03 02:27:44 piso Exp $
     4;;; $Id: define-modify-macro.lisp,v 1.3 2005-02-07 16:24:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1818;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
    1919
    20 ;;; Adapted from CMUCL.
     20;;; Adapted from SBCL.
    2121
    22 (in-package "SYSTEM")
     22(in-package #:system)
    2323
     24;; FIXME See section 5.1.3.
    2425(defmacro define-modify-macro (name lambda-list function &optional doc-string)
    2526  "Creates a new read-modify-write macro like PUSH or INCF."
     
    2829  (env (gensym))
    2930  (reference (gensym)))
    30     ;; Parse out the variable names and rest arg from the lambda list.
     31    ;; Parse out the variable names and &REST arg from the lambda list.
    3132    (do ((ll lambda-list (cdr ll))
    3233   (arg nil))
     
    3738       (if (symbolp (cadr ll))
    3839     (setq rest-arg (cadr ll))
    39      (error "non-symbol &REST arg in definition of ~S" name))
     40     (error "Non-symbol &REST arg in definition of ~S." name))
    4041       (if (null (cddr ll))
    4142     (return nil)
    42      (error "illegal stuff after &rest arg in DEFINE-MODIFY-MACRO")))
     43     (error "Illegal stuff after &REST argument in DEFINE-MODIFY-MACRO.")))
    4344      ((memq arg '(&key &allow-other-keys &aux))
    44        (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list" arg))
     45       (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
    4546      ((symbolp arg)
    4647       (push arg other-args))
    4748      ((and (listp arg) (symbolp (car arg)))
    4849       (push (car arg) other-args))
    49       (t (error "illegal stuff in lambda list of DEFINE-MODIFY-MACRO"))))
     50      (t (error "Illegal stuff in DEFINE-MODIFY-MACRO lambda list."))))
    5051    (setq other-args (nreverse other-args))
    5152    `(defmacro ,name (,reference ,@lambda-list &environment ,env)
    5253       ,doc-string
    5354       (multiple-value-bind (dummies vals newval setter getter)
    54   (get-setf-expansion ,reference ,env)
     55          (get-setf-expansion ,reference ,env)
    5556   (do ((d dummies (cdr d))
    5657        (v vals (cdr v))
    5758        (let-list nil (cons (list (car d) (car v)) let-list)))
    5859       ((null d)
    59         (push
    60          (list (car newval)
    61          ,(if rest-arg
    62         `(list* ',function getter ,@other-args ,rest-arg)
    63         `(list ',function getter ,@other-args)))
    64          let-list)
     60        (push (list (car newval)
     61                          ,(if rest-arg
     62                               `(list* ',function getter ,@other-args ,rest-arg)
     63                               `(list ',function getter ,@other-args)))
     64                    let-list)
    6565        `(let* ,(nreverse let-list)
    6666     ,setter)))))))
     
    7676(defmacro incf (place &optional (delta 1))
    7777  (cond ((symbolp place)
    78          `(setq ,place (+ ,place ,delta)))
     78         (cond ((constantp delta)
     79                `(setq ,place (+ ,place ,delta)))
     80               (t
     81                ;; See section 5.1.3.
     82                (let ((temp (gensym)))
     83                  `(let ((,temp ,delta))
     84                     (setq ,place (+ ,place ,temp)))))))
    7985        ((and (consp place) (eq (car place) 'THE))
    8086         (let ((res (gensym)))
     
    8692(defmacro decf (place &optional (delta 1))
    8793  (cond ((symbolp place)
    88          `(setq ,place (- ,place ,delta)))
     94         (cond ((constantp delta)
     95                `(setq ,place (- ,place ,delta)))
     96               (t
     97                ;; See section 5.1.3.
     98                (let ((temp (gensym)))
     99                  `(let ((,temp ,delta))
     100                     (setq ,place (- ,place ,temp)))))))
    89101        ((and (consp place) (eq (car place) 'THE))
    90102         (let ((res (gensym)))
Note: See TracChangeset for help on using the changeset viewer.