Basic SETF implementation

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8db7c46..a9b65c5 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -356,15 +356,38 @@
   (defun concat-two (s1 s2)
     (concat-two s1 s2))
 
-  (defun mapcar (func list)
-    (let* ((head (cons 'sentinel nil))
-          (tail head))
-      (while (not (null list))
-       (let ((new (cons (funcall func (car list)) nil)))
-         (rplacd tail new)
-         (setq tail new
-               list (cdr list))))
-      (cdr head)))
+  (defmacro with-collect (&body body)
+    (let ((head (gensym))
+          (tail (gensym)))
+      `(let* ((,head (cons 'sentinel nil))
+              (,tail ,head))
+         (flet ((collect (x)
+                  (rplacd ,tail (cons x nil))
+                  (setq ,tail (cdr ,tail))
+                  x))
+           ,@body)
+         (cdr ,head))))
+
+  (defun map1 (func list)
+    (with-collect
+      (while list
+        (collect (funcall func (car list)))
+        (setq list (cdr list)))))
+
+  (defmacro loop (&body body)
+    `(while t ,@body))
+
+  (defun mapcar (func list &rest lists)
+    (let ((lists (cons list lists)))
+      (with-collect
+        (block loop
+          (loop
+             (let ((elems (map1 #'car lists)))
+               (do ((tail lists (cdr tail)))
+                   ((null tail))
+                 (when (null (car tail)) (return-from loop))
+                 (rplaca tail (cdar tail)))
+               (collect (apply func elems))))))))
 
   (defun identity (x) x)
 
@@ -538,7 +561,74 @@
   (defmacro multiple-value-list (value-from)
     `(multiple-value-call #'list ,value-from))
 
-  ;; Packages
+
+  ;;; Generalized references (SETF)
+
+  (defvar *setf-expanders* nil)
+
+  (defun get-setf-expansion (place)
+    (if (symbolp place)
+        (let ((value (gensym)))
+          (values nil
+                  nil
+                  `(,value)
+                  `(setq ,place ,value)
+                  place))
+        (let* ((access-fn (car place))
+             (expander (cdr (assoc access-fn *setf-expanders*))))
+          (when (null expander)
+            (error "Unknown generalized reference."))
+          (apply expander (cdr place)))))
+
+  (defmacro define-setf-expander (access-fn lambda-list &body body)
+    (unless (symbolp access-fn)
+      (error "ACCESS-FN must be a symbol."))
+    `(progn (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 (first pairs))
+             (value (second pairs)))
+         (multiple-value-bind (vars vals store-vars writer-form reader-form)
+             (get-setf-expansion place)
+           ;; TODO: Optimize the expansion code here.
+           `(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)))))))
+
+  (define-setf-expander car (x)
+    (let ((cons (gensym))
+          (new-value (gensym)))
+      (values (list cons)
+              (list x)
+              (list new-value)
+              `(progn (rplaca ,cons ,new-value) ,new-value)
+              `(car ,cons))))
+
+  (define-setf-expander cdr (x)
+    (let ((cons (gensym))
+          (new-value (gensym)))
+      (values (list cons)
+              (list x)
+              (list new-value)
+              `(progn (rplacd ,cons ,new-value) ,new-value)
+              `(car ,cons))))
+
+  ;;; Packages
 
   (defvar *package-list* nil)
 
@@ -2350,7 +2440,7 @@
            package-name package-use-list packagep parse-integer plusp
            prin1-to-string print proclaim prog1 prog2 progn psetq
            push quote remove remove-if remove-if-not return
-           return-from revappend reverse rplaca rplacd second set
+           return-from revappend reverse rplaca rplacd second set setf
            setq some string-upcase string string= stringp subseq
            symbol-function symbol-name symbol-package symbol-plist
            symbol-value symbolp t tagbody third throw truncate unless
@@ -2372,12 +2462,15 @@
   ;; environment at this point of the compilation.
   (eval-when-compile
     (toplevel-compilation
+     (ls-compile `(setq *environment* ',*environment*))))
+
+  (eval-when-compile
+    (toplevel-compilation
      (ls-compile
       `(progn
          ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))
                    *literal-symbols*)
          (setq *literal-symbols* ',*literal-symbols*)
-         (setq *environment* ',*environment*)
          (setq *variable-counter* ,*variable-counter*)
          (setq *gensym-counter* ,*gensym-counter*)
          (setq *block-counter* ,*block-counter*)))))