Move SETF to src/setf.lisp

[jscl.git] / src / setf.lisp

diff --git a/src/setf.lisp b/src/setf.lisp
new file mode 100644 (file)
index 0000000..fc08882
--- /dev/null
+++ b/src/setf.lisp
@@ -0,0 +1,129 @@
+;;; setf.lisp ---
+
+;; JSCL is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; JSCL is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Generalized references (SETF)
+
+(eval-when(:compile-toplevel :load-toplevel :execute)
+  (defvar *setf-expanders* nil)
+  (defun !get-setf-expansion (place)
+    (if (symbolp place)
+        (let ((value (gensym)))
+          (values nil
+                  nil
+                  `(,value)
+                  `(setq ,place ,value)
+                  place))
+        (let ((place (!macroexpand-1 place)))
+          (let* ((access-fn (car place))
+                 (expander (cdr (assoc access-fn *setf-expanders*))))
+            (when (null expander)
+              (error "Unknown generalized reference."))
+            (apply expander (cdr place)))))))
+(fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
+
+(defmacro define-setf-expander (access-fn lambda-list &body body)
+  (unless (symbolp access-fn)
+    (error "ACCESS-FN `~S' must be a symbol." access-fn))
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (push (cons ',access-fn (lambda ,lambda-list ,@body))
+           *setf-expanders*)
+     ',access-fn))
+
+(defmacro setf (&rest pairs)
+  (cond
+    ((null pairs)
+     nil)
+    ((null (cdr pairs))
+     (error "Odd number of arguments to setf."))
+    ((null (cddr pairs))
+     (let ((place (!macroexpand-1 (first pairs)))
+           (value (second pairs)))
+       (multiple-value-bind (vars vals store-vars writer-form reader-form)
+           (!get-setf-expansion place)
+         (declare (ignorable reader-form))
+         ;; TODO: Optimize the expansion a little bit to avoid let*
+         ;; or multiple-value-bind when unnecesary.
+         `(let* ,(mapcar #'list vars vals)
+            (multiple-value-bind ,store-vars
+                ,value
+              ,writer-form)))))
+    (t
+     `(progn
+        ,@(do ((pairs pairs (cddr pairs))
+               (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
+              ((null pairs)
+               (reverse result)))))))
+
+
+
+
+;;; SETF-Based macros
+
+(defmacro incf (place &optional (delta 1))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+                (,(car newval) (+ ,getter ,d))
+                ,@(cdr newval))
+         ,setter))))
+
+(defmacro decf (place &optional (delta 1))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (- ,getter ,d))
+              ,@(cdr newval))
+         ,setter))))
+
+(defmacro push (x place)
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((g (gensym)))
+      `(let* ((,g ,x)
+              ,@(mapcar #'list dummies vals)
+              (,(car newval) (cons ,g ,getter))
+              ,@(cdr newval))
+         ,setter))))
+
+(defmacro pop (place)
+  (multiple-value-bind (dummies vals newval setter getter)
+    (!get-setf-expansion place)
+    (let ((head (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,head ,getter)
+              (,(car newval) (cdr ,head))
+              ,@(cdr newval))
+         ,setter
+         (car ,head)))))
+
+(defmacro pushnew (x place &rest keys &key key test test-not)
+  (declare (ignore key test test-not))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((g (gensym))
+          (v (gensym)))
+      `(let* ((,g ,x)
+              ,@(mapcar #'list dummies vals)
+              ,@(cdr newval)
+              (,v ,getter))
+         (if (member ,g ,v ,@keys)
+             ,v
+             (let ((,(car newval) (cons ,g ,getter)))
+               ,setter))))))