Boolean Lisp<->Javascript conversion

[jscl.git] / src / boot.lisp

diff --git a/src/boot.lisp b/src/boot.lisp
index cb964e4..a45bb73 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -52,6 +52,7 @@
 (defconstant t 't)
 (defconstant nil 'nil)
 (%js-vset "nil" nil)
+(%js-vset "t" t)
 
 (defmacro lambda (args &body body)
   `(function (lambda ,args ,@body)))
@@ -102,6 +103,12 @@
 
 (defun not (x) (if x nil t))
 
+(defun funcall (function &rest args)
+  (apply function args))
+
+(defun apply (function arg &rest args)
+  (apply function (apply #'list* arg args)))
+
 ;; Basic macros
 
 (defmacro dolist ((var list &optional result) &body body)
@@ -348,29 +355,31 @@
 
 ;;; 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 ((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))))))
+(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))
-  `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
-                *setf-expanders*)
-          ',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
@@ -382,14 +391,14 @@
      (let ((place (!macroexpand-1 (first pairs)))
            (value (second pairs)))
        (multiple-value-bind (vars vals store-vars writer-form reader-form)
-           (get-setf-expansion place)
+           (!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
-              ,reader-form)))))
+              ,writer-form)))))
     (t
      `(progn
         ,@(do ((pairs pairs (cddr pairs))
@@ -399,7 +408,7 @@
 
 (defmacro incf (place &optional (delta 1))
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-expansion place)
+      (!get-setf-expansion place)
     (let ((d (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               (,d ,delta)
@@ -409,7 +418,7 @@
 
 (defmacro decf (place &optional (delta 1))
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-expansion place)
+      (!get-setf-expansion place)
     (let ((d (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               (,d ,delta)
@@ -419,7 +428,7 @@
 
 (defmacro push (x place)
   (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-expansion place)
+      (!get-setf-expansion place)
     (let ((g (gensym)))
       `(let* ((,g ,x)
               ,@(mapcar #'list dummies vals)
@@ -429,7 +438,7 @@
 
 (defmacro pop (place)
   (multiple-value-bind (dummies vals newval setter getter)
-    (get-setf-expansion place)
+    (!get-setf-expansion place)
     (let ((head (gensym)))
       `(let* (,@(mapcar #'list dummies vals)
               (,head ,getter)
@@ -441,7 +450,7 @@
 (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)
+      (!get-setf-expansion place)
     (let ((g (gensym))
           (v (gensym)))
       `(let* ((,g ,x)