Move SETF to src/setf.lisp

[jscl.git] / src / boot.lisp

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