X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=149a7779fbb38d971d882b9e9e08aceacc87abaa;hb=4e103a7d0be6bf1e3cd0ed39934afb36e525a243;hp=5b40d7cbb60fc7fe6b395b96115c6e7acd75d1a4;hpb=718c909c1cca49aa45488505a721766ce94b2377;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 5b40d7c..149a777 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -561,7 +561,75 @@
   (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 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)))))))
+
+  (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)
 
@@ -1344,7 +1412,6 @@
 	(keyword-arguments
 	 (lambda-list-keyword-arguments-canonical lambda-list)))
     (code
-     "var i;" *newline*
      ;; Declare variables
      (mapconcat (lambda (arg)
 		  (let ((var (second (car arg))))
@@ -1371,7 +1438,9 @@
                      (ls-compile (cadr keyarg))
                      ";" *newline*)
                     "}" *newline*)))
-       (mapconcat #'parse-keyword keyword-arguments))
+       (when keyword-arguments
+         (code "var i;" *newline*
+               (mapconcat #'parse-keyword keyword-arguments))))
      ;; Check for unknown keywords
      (when keyword-arguments
        (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
@@ -2373,7 +2442,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