X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=4a274133e68418e58f875825f528b228a9d8e9e2;hb=25702fbbf0ddd2e5386bbf257eee8150adfc7b47;hp=6eaa85db5d74fa49f3e45350d5247c0ce4a6984a;hpb=f6103bee62f1597449b51f6e4480ada375b279d3;p=jscl.git

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 6eaa85d..4a27413 100644
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -68,7 +68,7 @@
         (incf index))
       output)))
 
-#+common-lisp
+#-jscl
 (defun indent (&rest string)
   (with-output-to-string (*standard-output*)
     (with-input-from-string (input (apply #'code string))
@@ -498,6 +498,25 @@
       (incf index))
     output))
 
+;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
+;;; the bootstrap. Once everything is compiled, we want to dump the
+;;; whole global environment to the output file to reproduce it in the
+;;; run-time. However, the environment must contain expander functions
+;;; rather than lists. We do not know how to dump function objects
+;;; itself, so we mark the list definitions with this object and the
+;;; compiler will be called when this object has to be dumped.
+;;; Backquote/unquote does a similar magic, but this use is exclusive.
+;;;
+;;; Indeed, perhaps to compile the object other macros need to be
+;;; evaluated. For this reason we define a valid macro-function for
+;;; this symbol.
+(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
+#-jscl
+(setf (macro-function *magic-unquote-marker*)
+      (lambda (form &optional environment)
+        (declare (ignore environment))
+        (second form)))
+
 (defvar *literal-table* nil)
 (defvar *literal-counter* 0)
 
@@ -505,11 +524,10 @@
   (code "l" (incf *literal-counter*)))
 
 (defun dump-symbol (symbol)
-  #+common-lisp
+  #-jscl
   (let ((package (symbol-package symbol)))
     (if (eq package (find-package "KEYWORD"))
-        (code "(new Symbol(" (dump-string (symbol-name symbol)) ", "
-              (dump-string (package-name package)) "))")
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) ", " (dump-string (package-name package)) "))")
         (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))
   #+jscl
   (let ((package (symbol-package symbol)))
@@ -558,6 +576,8 @@
                (let ((jsvar (genlit)))
                  (push (cons sexp jsvar) *literal-table*)
                  (toplevel-compilation (code "var " jsvar " = " dumped))
+                 (when (keywordp sexp)
+                   (toplevel-compilation (code jsvar ".value = " jsvar)))
                  jsvar)))))))
 
 
@@ -1517,6 +1537,14 @@
     (indent "r.push(" (ls-compile nil) ");" *newline*)
     "return r;" *newline*))
 
+;;; FIXME: should take optional min-extension.
+;;; FIXME: should use fill-pointer instead of the absolute end of array
+(define-builtin vector-push-extend (new vector)
+  (js!selfcall
+    "var v = " vector ";" *newline*
+    "v.push(" new ");" *newline*
+    "return v;"))
+
 (define-builtin arrayp (x)
   (js!bool
    (js!selfcall
@@ -1536,6 +1564,18 @@
     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
     "return x[i] = " value ";" *newline*))
 
+(define-builtin afind (value array)
+  (js!selfcall
+    "var v = " value ";" *newline*
+    "var x = " array ";" *newline*
+    "return x.indexOf(v);" *newline*))
+
+(define-builtin aresize (array new-size)
+  (js!selfcall
+    "var x = " array ";" *newline*
+    "var n = " new-size ";" *newline*
+    "return x.length = n;" *newline*))
+
 (define-builtin get-internal-real-time ()
   "(new Date()).getTime()")
 
@@ -1569,7 +1609,7 @@
             `(%js-vref ,var))))
 
 
-#+common-lisp
+#-jscl
 (defvar *macroexpander-cache*
   (make-hash-table :test #'eq))
 
@@ -1580,7 +1620,7 @@
     (if (and b (eq (binding-type b) 'macro))
         (let ((expander (binding-value b)))
           (cond
-            #+common-lisp
+            #-jscl
             ((gethash b *macroexpander-cache*)
              (setq expander (gethash b *macroexpander-cache*)))
             ((listp expander)
@@ -1593,7 +1633,7 @@
                ;; function with the compiled one.
                ;;
                #+jscl (setf (binding-value b) compiled)
-               #+common-lisp (setf (gethash b *macroexpander-cache*) compiled)
+               #-jscl (setf (gethash b *macroexpander-cache*) compiled)
                (setq expander compiled))))
           expander)
         nil)))
@@ -1627,7 +1667,7 @@
        (concat (translate-function function) arglist))
       ((and (symbolp function)
             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
-            #+common-lisp t)
+            #-jscl t)
        (code (ls-compile `',function) ".fvalue" arglist))
       (t
        (code (ls-compile `#',function) arglist)))))