Changeset 4440
 Timestamp:
 10/17/03 19:10:19 (18 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/j/src/org/armedbear/lisp/setf.lisp
r4209 r4440 2 2 ;;; 3 3 ;;; Copyright (C) 2003 Peter Graves 4 ;;; $Id: setf.lisp,v 1.3 4 20031006 00:26:24piso Exp $4 ;;; $Id: setf.lisp,v 1.35 20031017 19:10:19 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 22 22 (defun getsetfmethodinverse (form inverse setffunction) 23 23 (let ((newvar (gensym)) 24 25 24 (vars nil) 25 (vals nil)) 26 26 (dolist (x (cdr form)) 27 27 (push (gensym) vars) … … 29 29 (setq vals (nreverse vals)) 30 30 (values vars vals (list newvar) 31 (if setffunction 32 `(,@inverse ,newvar ,@vars) 33 `(,@inverse ,@vars ,newvar)) 34 `(,(car form) ,@vars)))) 31 (if setffunction 32 `(,@inverse ,newvar ,@vars) 33 (if (functionp (car inverse)) 34 `(funcall ,@inverse ,@vars ,newvar) 35 `(,@inverse ,@vars ,newvar))) 36 `(,(car form) ,@vars)))) 35 37 36 38 ;;; If a macro, expand one level and try again. If not, go for the … … 41 43 (macroexpand1 form environment) 42 44 (if expanded 43 44 45 45 (getsetfexpansion expansion environment) 46 (getsetfmethodinverse form `(funcall #'(setf ,(car form))) 47 t)))) 46 48 47 49 (defun getsetfexpansion (form &optional environment) … … 51 53 (values nil nil (list newvar) 52 54 `(setq ,form ,newvar) form))) 53 54 55 ((setq temp (get (car form) 'setfinverse)) 56 (getsetfmethodinverse form `(,temp) nil)) 55 57 ((setq temp (get (car form) 'setfexpander)) 56 58 (funcall temp form environment)) 57 58 59 (t 60 (expandorgetsetfinverse form environment))))) 59 61 60 62 ;;; ROTATEF (from GCL) … … 70 72 (setq accessforms (nreverse accessforms)) 71 73 `(let* ,(nconc pairs 72 73 74 (mapcar #'list stores (cdr accessforms)) 75 (list (list (car (last stores)) (car accessforms)))) 74 76 ,@storeforms 75 77 nil)) … … 97 99 `(funcall ,inverse ,@(cdr place) ,valueform) 98 100 `(,inverse ,@(cdr place) ,valueform)) 99 100 101 101 `(let* (,@(mapcar #'list dummies vals)) 102 (multiplevaluebind ,newval ,valueform 103 ,setter)))))))) 102 104 ((oddp count) 103 105 (error "odd number of args to SETF")) … … 105 107 (do ((a args (cddr a)) (l nil)) 106 108 ((null a) `(progn ,@(nreverse l))) 107 109 (setq l (cons (list 'setf (car a) (cadr a)) l))))))) 108 110 109 111 ;;; Redefined in definemodifymacro.lisp.
Note: See TracChangeset
for help on using the changeset viewer.