Move SETF to src/setf.lisp

diff --git a/jscl.lisp b/jscl.lisp
index e3a9581..e21ab3d 100644 (file)
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -41,6 +41,7 @@
 (defvar *source*
   '(("boot"          :target)
     ("compat"        :host)
+    ("setf"          :target)
     ("utils"         :both)
     ("numbers"       :target)
     ("char"          :target)

diff --git a/src/boot.lisp b/src/boot.lisp
index a45bb73..ce61f98 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -353,117 +353,6 @@
   `(multiple-value-call #'list ,value-from))
 
 
-;;; 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)))))))
-
-(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))))))
-
-
-
 ;; Incorrect typecase, but used in NCONC.
 (defmacro typecase (x &rest clausules)
   (let ((value (gensym)))

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))))))