1 | ;;; setf.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2005 Peter Graves |
---|
4 | ;;; $Id: setf.lisp,v 1.50 2005-02-12 02:12:16 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package #:system) |
---|
21 | |
---|
22 | (defun get-setf-method-inverse (form inverse setf-function) |
---|
23 | (let ((new-var (gensym)) |
---|
24 | (vars nil) |
---|
25 | (vals nil)) |
---|
26 | (dolist (x (cdr form)) |
---|
27 | (push (gensym) vars) |
---|
28 | (push x vals)) |
---|
29 | (setq vals (nreverse vals)) |
---|
30 | (values vars vals (list new-var) |
---|
31 | (if setf-function |
---|
32 | `(,@inverse ,new-var ,@vars) |
---|
33 | (if (functionp (car inverse)) |
---|
34 | `(funcall ,@inverse ,@vars ,new-var) |
---|
35 | `(,@inverse ,@vars ,new-var))) |
---|
36 | `(,(car form) ,@vars)))) |
---|
37 | |
---|
38 | ;;; If a macro, expand one level and try again. If not, go for the |
---|
39 | ;;; SETF function. |
---|
40 | (defun expand-or-get-setf-inverse (form environment) |
---|
41 | (multiple-value-bind |
---|
42 | (expansion expanded) |
---|
43 | (macroexpand-1 form environment) |
---|
44 | (if expanded |
---|
45 | (get-setf-expansion expansion environment) |
---|
46 | (get-setf-method-inverse form `(funcall #'(setf ,(car form))) |
---|
47 | t)))) |
---|
48 | |
---|
49 | (defun get-setf-expansion (form &optional environment) |
---|
50 | (let (temp) |
---|
51 | (cond ((symbolp form) |
---|
52 | (let ((new-var (gensym))) |
---|
53 | (values nil nil (list new-var) |
---|
54 | `(setq ,form ,new-var) form))) |
---|
55 | ((setq temp (get (car form) 'setf-inverse)) |
---|
56 | (get-setf-method-inverse form `(,temp) nil)) |
---|
57 | ((setq temp (get (car form) 'setf-expander)) |
---|
58 | (funcall temp form environment)) |
---|
59 | (t |
---|
60 | (expand-or-get-setf-inverse form environment))))) |
---|
61 | |
---|
62 | (defmacro setf (&rest args) |
---|
63 | (let ((count (length args))) |
---|
64 | (cond |
---|
65 | ((= count 2) |
---|
66 | (let ((place (first args)) |
---|
67 | (value-form (second args))) |
---|
68 | (if (atom place) |
---|
69 | `(setq ,place ,value-form) |
---|
70 | (progn |
---|
71 | (when (symbolp (car place)) |
---|
72 | (resolve (car place))) |
---|
73 | (multiple-value-bind (dummies vals store-vars setter getter) |
---|
74 | (get-setf-expansion place) |
---|
75 | (let ((inverse (get (car place) 'setf-inverse))) |
---|
76 | (if (and inverse (eq inverse (car setter))) |
---|
77 | (if (functionp inverse) |
---|
78 | `(funcall ,inverse ,@(cdr place) ,value-form) |
---|
79 | `(,inverse ,@(cdr place) ,value-form)) |
---|
80 | (if (cdr store-vars) |
---|
81 | `(let* (,@(mapcar #'list dummies vals)) |
---|
82 | (multiple-value-bind ,store-vars ,value-form |
---|
83 | ,setter)) |
---|
84 | `(let* (,@(mapcar #'list dummies vals) |
---|
85 | ,(list (car store-vars) value-form)) |
---|
86 | ,setter))))))))) |
---|
87 | ((oddp count) |
---|
88 | (error "odd number of args to SETF")) |
---|
89 | (t |
---|
90 | (do ((a args (cddr a)) (l nil)) |
---|
91 | ((null a) `(progn ,@(nreverse l))) |
---|
92 | (setq l (cons (list 'setf (car a) (cadr a)) l))))))) |
---|
93 | |
---|
94 | ;;; Redefined in define-modify-macro.lisp. |
---|
95 | (defmacro incf (place &optional (delta 1)) |
---|
96 | `(setf ,place (+ ,place ,delta))) |
---|
97 | |
---|
98 | ;;; Redefined in define-modify-macro.lisp. |
---|
99 | (defmacro decf (place &optional (delta 1)) |
---|
100 | `(setf ,place (- ,place ,delta))) |
---|
101 | |
---|
102 | ;; (defsetf subseq (sequence start &optional (end nil)) (v) |
---|
103 | ;; `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) |
---|
104 | ;; ,v)) |
---|
105 | (defun %set-subseq (sequence start &rest rest) |
---|
106 | (let ((end nil) v) |
---|
107 | (ecase (length rest) |
---|
108 | (1 |
---|
109 | (setq v (car rest))) |
---|
110 | (2 |
---|
111 | (setq end (car rest) |
---|
112 | v (cadr rest)))) |
---|
113 | (progn |
---|
114 | (replace sequence v :start1 start :end1 end) |
---|
115 | v))) |
---|
116 | |
---|
117 | (defun %define-setf-macro (name expander inverse doc) |
---|
118 | (when inverse |
---|
119 | (%put name 'setf-inverse inverse)) |
---|
120 | (when expander |
---|
121 | (%put name 'setf-expander expander)) |
---|
122 | name) |
---|
123 | |
---|
124 | (defmacro defsetf (access-function update-function) |
---|
125 | `(eval-when (:load-toplevel :compile-toplevel :execute) |
---|
126 | (%put ',access-function 'setf-inverse ',update-function))) |
---|
127 | |
---|
128 | (defun %set-caar (x v) (%rplaca (car x) v)) |
---|
129 | (defun %set-cadr (x v) (%rplaca (cdr x) v)) |
---|
130 | (defun %set-cdar (x v) (%rplacd (car x) v)) |
---|
131 | (defun %set-cddr (x v) (%rplacd (cdr x) v)) |
---|
132 | (defun %set-caaar (x v) (%rplaca (caar x) v)) |
---|
133 | (defun %set-cadar (x v) (%rplaca (cdar x) v)) |
---|
134 | (defun %set-cdaar (x v) (%rplacd (caar x) v)) |
---|
135 | (defun %set-cddar (x v) (%rplacd (cdar x) v)) |
---|
136 | (defun %set-caadr (x v) (%rplaca (cadr x) v)) |
---|
137 | (defun %set-caddr (x v) (%rplaca (cddr x) v)) |
---|
138 | (defun %set-cdadr (x v) (%rplacd (cadr x) v)) |
---|
139 | (defun %set-cdddr (x v) (%rplacd (cddr x) v)) |
---|
140 | (defun %set-caaaar (x v) (%rplaca (caaar x) v)) |
---|
141 | (defun %set-cadaar (x v) (%rplaca (cdaar x) v)) |
---|
142 | (defun %set-cdaaar (x v) (%rplacd (caaar x) v)) |
---|
143 | (defun %set-cddaar (x v) (%rplacd (cdaar x) v)) |
---|
144 | (defun %set-caadar (x v) (%rplaca (cadar x) v)) |
---|
145 | (defun %set-caddar (x v) (%rplaca (cddar x) v)) |
---|
146 | (defun %set-cdadar (x v) (%rplacd (cadar x) v)) |
---|
147 | (defun %set-cdddar (x v) (%rplacd (cddar x) v)) |
---|
148 | (defun %set-caaadr (x v) (%rplaca (caadr x) v)) |
---|
149 | (defun %set-cadadr (x v) (%rplaca (cdadr x) v)) |
---|
150 | (defun %set-cdaadr (x v) (%rplacd (caadr x) v)) |
---|
151 | (defun %set-cddadr (x v) (%rplacd (cdadr x) v)) |
---|
152 | (defun %set-caaddr (x v) (%rplaca (caddr x) v)) |
---|
153 | (defun %set-cadddr (x v) (%rplaca (cdddr x) v)) |
---|
154 | (defun %set-cdaddr (x v) (%rplacd (caddr x) v)) |
---|
155 | (defun %set-cddddr (x v) (%rplacd (cdddr x) v)) |
---|
156 | |
---|
157 | (defsetf car %rplaca) |
---|
158 | (defsetf cdr %rplacd) |
---|
159 | (defsetf caar %set-caar) |
---|
160 | (defsetf cadr %set-cadr) |
---|
161 | (defsetf cdar %set-cdar) |
---|
162 | (defsetf cddr %set-cddr) |
---|
163 | (defsetf caaar %set-caaar) |
---|
164 | (defsetf cadar %set-cadar) |
---|
165 | (defsetf cdaar %set-cdaar) |
---|
166 | (defsetf cddar %set-cddar) |
---|
167 | (defsetf caadr %set-caadr) |
---|
168 | (defsetf caddr %set-caddr) |
---|
169 | (defsetf cdadr %set-cdadr) |
---|
170 | (defsetf cdddr %set-cdddr) |
---|
171 | (defsetf caaaar %set-caaaar) |
---|
172 | (defsetf cadaar %set-cadaar) |
---|
173 | (defsetf cdaaar %set-cdaaar) |
---|
174 | (defsetf cddaar %set-cddaar) |
---|
175 | (defsetf caadar %set-caadar) |
---|
176 | (defsetf caddar %set-caddar) |
---|
177 | (defsetf cdadar %set-cdadar) |
---|
178 | (defsetf cdddar %set-cdddar) |
---|
179 | (defsetf caaadr %set-caaadr) |
---|
180 | (defsetf cadadr %set-cadadr) |
---|
181 | (defsetf cdaadr %set-cdaadr) |
---|
182 | (defsetf cddadr %set-cddadr) |
---|
183 | (defsetf caaddr %set-caaddr) |
---|
184 | (defsetf cadddr %set-cadddr) |
---|
185 | (defsetf cdaddr %set-cdaddr) |
---|
186 | (defsetf cddddr %set-cddddr) |
---|
187 | |
---|
188 | (defsetf first %rplaca) |
---|
189 | (defsetf second %set-cadr) |
---|
190 | (defsetf third %set-caddr) |
---|
191 | (defsetf fourth %set-cadddr) |
---|
192 | (defun %set-fifth (x v) (%rplaca (cddddr x) v)) |
---|
193 | (defsetf fifth %set-fifth) |
---|
194 | (defun %set-sixth (x v) (%rplaca (cdr (cddddr x)) v)) |
---|
195 | (defsetf sixth %set-sixth) |
---|
196 | (defun %set-seventh (x v) (%rplaca (cddr (cddddr x)) v)) |
---|
197 | (defsetf seventh %set-seventh) |
---|
198 | (defun %set-eighth (x v) (%rplaca (cdddr (cddddr x)) v)) |
---|
199 | (defsetf eighth %set-eighth) |
---|
200 | (defun %set-ninth (x v) (%rplaca (cddddr (cddddr x)) v)) |
---|
201 | (defsetf ninth %set-ninth) |
---|
202 | (defun %set-tenth (x v) (%rplaca (cdr (cddddr (cddddr x))) v)) |
---|
203 | (defsetf tenth %set-tenth) |
---|
204 | |
---|
205 | (defsetf rest %rplacd) |
---|
206 | (defsetf elt %set-elt) |
---|
207 | (defsetf nth %set-nth) |
---|
208 | (defsetf svref %svset) |
---|
209 | (defsetf fill-pointer %set-fill-pointer) |
---|
210 | (defsetf subseq %set-subseq) |
---|
211 | (defsetf symbol-value set) |
---|
212 | (defsetf symbol-function %set-symbol-function) |
---|
213 | (defsetf symbol-plist %set-symbol-plist) |
---|
214 | (defsetf get %put) |
---|
215 | (defsetf gethash puthash) |
---|
216 | (defsetf char %set-char) |
---|
217 | (defsetf schar %set-schar) |
---|
218 | (defsetf charpos %set-charpos) |
---|
219 | (defsetf logical-pathname-translations %set-logical-pathname-translations) |
---|
220 | (defsetf readtable-case %set-readtable-case) |
---|
221 | |
---|
222 | (defun %putf (place property new-value) |
---|
223 | (do ((plist place (cddr plist))) |
---|
224 | ((endp plist) (list* property new-value place)) |
---|
225 | (when (eq (car plist) property) |
---|
226 | (setf (cadr plist) new-value) |
---|
227 | (return place)))) |
---|
228 | |
---|
229 | (defsetf function-info %set-function-info) |
---|
230 | (defsetf single-valued-p %set-single-valued-p) |
---|