Add *version* variable
[jscl.git] / src / setf.lisp
1 ;;; setf.lisp ---
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16
17 ;;; Generalized references (SETF)
18
19 (eval-when(:compile-toplevel :load-toplevel :execute)
20   (defvar *setf-expanders* nil)
21   (defun !get-setf-expansion (place)
22     (if (symbolp place)
23         (let ((value (gensym)))
24           (values nil
25                   nil
26                   `(,value)
27                   `(setq ,place ,value)
28                   place))
29         (let ((place (!macroexpand-1 place)))
30           (let* ((access-fn (car place))
31                  (expander (cdr (assoc access-fn *setf-expanders*))))
32             (when (null expander)
33               (error "Unknown generalized reference."))
34             (apply expander (cdr place)))))))
35 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
36
37 (defmacro define-setf-expander (access-fn lambda-list &body body)
38   (unless (symbolp access-fn)
39     (error "ACCESS-FN `~S' must be a symbol." access-fn))
40   `(eval-when (:compile-toplevel :load-toplevel :execute)
41      (push (cons ',access-fn (lambda ,lambda-list ,@body))
42            *setf-expanders*)
43      ',access-fn))
44
45 (defmacro setf (&rest pairs)
46   (cond
47     ((null pairs)
48      nil)
49     ((null (cdr pairs))
50      (error "Odd number of arguments to setf."))
51     ((null (cddr pairs))
52      (let ((place (!macroexpand-1 (first pairs)))
53            (value (second pairs)))
54        (multiple-value-bind (vars vals store-vars writer-form reader-form)
55            (!get-setf-expansion place)
56          (declare (ignorable reader-form))
57          ;; TODO: Optimize the expansion a little bit to avoid let*
58          ;; or multiple-value-bind when unnecesary.
59          `(let* ,(mapcar #'list vars vals)
60             (multiple-value-bind ,store-vars
61                 ,value
62               ,writer-form)))))
63     (t
64      `(progn
65         ,@(do ((pairs pairs (cddr pairs))
66                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
67               ((null pairs)
68                (reverse result)))))))
69
70
71
72
73 ;;; SETF-Based macros
74
75 (defmacro incf (place &optional (delta 1))
76   (multiple-value-bind (dummies vals newval setter getter)
77       (!get-setf-expansion place)
78     (let ((d (gensym)))
79       `(let* (,@(mapcar #'list dummies vals)
80               (,d ,delta)
81                 (,(car newval) (+ ,getter ,d))
82                 ,@(cdr newval))
83          ,setter))))
84
85 (defmacro decf (place &optional (delta 1))
86   (multiple-value-bind (dummies vals newval setter getter)
87       (!get-setf-expansion place)
88     (let ((d (gensym)))
89       `(let* (,@(mapcar #'list dummies vals)
90               (,d ,delta)
91               (,(car newval) (- ,getter ,d))
92               ,@(cdr newval))
93          ,setter))))
94
95 (defmacro push (x place)
96   (multiple-value-bind (dummies vals newval setter getter)
97       (!get-setf-expansion place)
98     (let ((g (gensym)))
99       `(let* ((,g ,x)
100               ,@(mapcar #'list dummies vals)
101               (,(car newval) (cons ,g ,getter))
102               ,@(cdr newval))
103          ,setter))))
104
105 (defmacro pop (place)
106   (multiple-value-bind (dummies vals newval setter getter)
107     (!get-setf-expansion place)
108     (let ((head (gensym)))
109       `(let* (,@(mapcar #'list dummies vals)
110               (,head ,getter)
111               (,(car newval) (cdr ,head))
112               ,@(cdr newval))
113          ,setter
114          (car ,head)))))
115
116 (defmacro pushnew (x place &rest keys &key key test test-not)
117   (declare (ignore key test test-not))
118   (multiple-value-bind (dummies vals newval setter getter)
119       (!get-setf-expansion place)
120     (let ((g (gensym))
121           (v (gensym)))
122       `(let* ((,g ,x)
123               ,@(mapcar #'list dummies vals)
124               ,@(cdr newval)
125               (,v ,getter))
126          (if (member ,g ,v ,@keys)
127              ,v
128              (let ((,(car newval) (cons ,g ,getter)))
129                ,setter))))))