Changeset 8500
- Timestamp:
- 02/07/05 16:24:03 (18 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/define-modify-macro.lisp
r8452 r8500 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: define-modify-macro.lisp,v 1. 2 2005-02-03 02:27:44piso Exp $4 ;;; $Id: define-modify-macro.lisp,v 1.3 2005-02-07 16:24:03 piso Exp $ 5 5 ;;; 6 6 ;;; 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. 19 19 20 ;;; Adapted from CMUCL.20 ;;; Adapted from SBCL. 21 21 22 (in-package "SYSTEM")22 (in-package #:system) 23 23 24 ;; FIXME See section 5.1.3. 24 25 (defmacro define-modify-macro (name lambda-list function &optional doc-string) 25 26 "Creates a new read-modify-write macro like PUSH or INCF." … … 28 29 (env (gensym)) 29 30 (reference (gensym))) 30 ;; Parse out the variable names and restarg from the lambda list.31 ;; Parse out the variable names and &REST arg from the lambda list. 31 32 (do ((ll lambda-list (cdr ll)) 32 33 (arg nil)) … … 37 38 (if (symbolp (cadr ll)) 38 39 (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)) 40 41 (if (null (cddr ll)) 41 42 (return nil) 42 (error " illegal stuff after &rest arg in DEFINE-MODIFY-MACRO")))43 (error "Illegal stuff after &REST argument in DEFINE-MODIFY-MACRO."))) 43 44 ((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)) 45 46 ((symbolp arg) 46 47 (push arg other-args)) 47 48 ((and (listp arg) (symbolp (car arg))) 48 49 (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.")))) 50 51 (setq other-args (nreverse other-args)) 51 52 `(defmacro ,name (,reference ,@lambda-list &environment ,env) 52 53 ,doc-string 53 54 (multiple-value-bind (dummies vals newval setter getter) 54 55 (get-setf-expansion ,reference ,env) 55 56 (do ((d dummies (cdr d)) 56 57 (v vals (cdr v)) 57 58 (let-list nil (cons (list (car d) (car v)) let-list))) 58 59 ((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) 65 65 `(let* ,(nreverse let-list) 66 66 ,setter))))))) … … 76 76 (defmacro incf (place &optional (delta 1)) 77 77 (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))))))) 79 85 ((and (consp place) (eq (car place) 'THE)) 80 86 (let ((res (gensym))) … … 86 92 (defmacro decf (place &optional (delta 1)) 87 93 (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))))))) 89 101 ((and (consp place) (eq (car place) 'THE)) 90 102 (let ((res (gensym)))
Note: See TracChangeset
for help on using the changeset viewer.