Different quote compilation in CL and ecmalisp

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 82b207d..30649d2 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -21,6 +21,7 @@
 ;;; as well as funcalls and macroexpansion, but no functions. So, we
 ;;; define the Lisp world from scratch. This code has to define enough
 ;;; language to the compiler to be able to run.
 ;;; as well as funcalls and macroexpansion, but no functions. So, we
 ;;; define the Lisp world from scratch. This code has to define enough
 ;;; language to the compiler to be able to run.

+

 #+ecmalisp
 (progn
   (eval-when-compile
 #+ecmalisp
 (progn
   (eval-when-compile

@@ -28,7 +29,7 @@
                        '(lambda (name args &rest body)
                          `(eval-when-compile
                             (%compile-defmacro ',name
                        '(lambda (name args &rest body)
                          `(eval-when-compile
                             (%compile-defmacro ',name

-                                               '(lambda ,(mapcar (lambda (x)
+                                              '(lambda ,(mapcar (lambda (x)

                                                                    (if (eq x '&body)
                                                                        '&rest
                                                                        x))
                                                                    (if (eq x '&body)
                                                                        '&rest
                                                                        x))

@@ -47,7 +48,7 @@
   (defmacro named-lambda (name args &rest body)
     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))
   (defmacro named-lambda (name args &rest body)
     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))

-         (set ,x "fname" ,name)
+         (oset ,x "fname" ,name)

          ,x)))
 
   (defmacro %defun (name args &rest body)
          ,x)))
 
   (defmacro %defun (name args &rest body)

@@ -62,11 +63,8 @@
 
   (defvar *package* (new))
 
 
   (defvar *package* (new))
 

-  (defvar nil (make-symbol "NIL"))
-  (set *package* "NIL" nil)
-
-  (defvar t (make-symbol "T"))
-  (set *package* "T" t)
+  (defvar nil 'nil)
+  (defvar t 't)

 
   (defun null (x)
     (eq x nil))
 
   (defun null (x)
     (eq x nil))

@@ -82,11 +80,11 @@
 
   (defun intern (name)
     (if (internp name)
 
   (defun intern (name)
     (if (internp name)

-        (get *package* name)
-        (set *package* name (make-symbol name))))
+        (oget *package* name)
+        (oset *package* name (make-symbol name))))

 
   (defun find-symbol (name)
 
   (defun find-symbol (name)

-    (get *package* name))
+    (oget *package* name))

 
   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
 
   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))

@@ -153,7 +151,7 @@
                (,var nil))
            (%while ,g!list
                    (setq ,var (car ,g!list))
                (,var nil))
            (%while ,g!list
                    (setq ,var (car ,g!list))

-                   ,@body
+                   (tagbody ,@body)

                    (setq ,g!list (cdr ,g!list)))
            ,(third iter)))))
 
                    (setq ,g!list (cdr ,g!list)))
            ,(third iter)))))
 

@@ -166,7 +164,7 @@
          (let ((,var 0)
                (,g!to ,to))
            (%while (< ,var ,g!to)
          (let ((,var 0)
                (,g!to ,to))
            (%while (< ,var ,g!to)

-                   ,@body
+                   (tagbody ,@body)

                    (incf ,var))
            ,result))))
 
                    (incf ,var))
            ,result))))
 

@@ -223,7 +221,14 @@
     (let ((value (gensym)))
       `(let ((,value ,form))
          ,@body
     (let ((value (gensym)))
       `(let ((,value ,form))
          ,@body

-         ,value))))
+         ,value)))
+
+  (defmacro prog2 (form1 result &body body)
+    `(prog1 (progn ,form1 ,result) ,@body))
+
+
+
+)

 
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
 
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.

@@ -263,13 +268,14 @@
   (defun append (&rest lists)
     (!reduce #'append-two lists '()))
 
   (defun append (&rest lists)
     (!reduce #'append-two lists '()))
 

-  (defun reverse-aux (list acc)
-    (if (null list)
-        acc
-        (reverse-aux (cdr list) (cons (car list) acc))))
+  (defun revappend (list1 list2)
+    (while list1
+      (push (car list1) list2)
+      (setq list1 (cdr list1)))
+    list2)

 
   (defun reverse (list)
 
   (defun reverse (list)

-    (reverse-aux list '()))
+    (revappend list '()))

 
   (defun list-length (list)
     (let ((l 0))
 
   (defun list-length (list)
     (let ((l 0))

@@ -310,29 +316,29 @@
   (defun listp (x)
     (or (consp x) (null x)))
 
   (defun listp (x)
     (or (consp x) (null x)))
 

+  (defun nthcdr (n list)
+    (while (and (plusp n) list)
+      (setq n (1- n))
+      (setq list (cdr list)))
+    list)
+

   (defun nth (n list)
   (defun nth (n list)

-    (cond
-      ((null list) list)
-      ((zerop n) (car list))
-      (t (nth (1- n) (cdr list)))))
+    (car (nthcdr n list)))

 
   (defun last (x)
 
   (defun last (x)

-    (if (consp (cdr x))
-        (last (cdr x))
-        x))
+    (while (consp (cdr x))
+      (setq x (cdr x)))
+    x)

 
   (defun butlast (x)
     (and (consp (cdr x))
          (cons (car x) (butlast (cdr x)))))
 
   (defun member (x list)
 
   (defun butlast (x)
     (and (consp (cdr x))
          (cons (car x) (butlast (cdr x)))))
 
   (defun member (x list)

-    (cond
-      ((null list)
-       nil)
-      ((eql x (car list))
-       list)
-      (t
-       (member x (cdr list)))))
+    (while list
+      (when (eql x (car list))
+        (return list))
+      (setq list (cdr list))))

 
   (defun remove (x list)
     (cond
 
   (defun remove (x list)
     (cond

@@ -481,25 +487,42 @@
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 

-;;; Like CONCAT, but prefix each line with four spaces.
+(defun mapconcat (func list)
+  (join (mapcar func list)))
+
+;;; Like CONCAT, but prefix each line with four spaces. Two versions
+;;; of this function are available, because the Ecmalisp version is
+;;; very slow and bootstraping was annoying.
+
+#+ecmalisp

 (defun indent (&rest string)
   (let ((input (join string)))
     (let ((output "")
           (index 0)
           (size (length input)))
 (defun indent (&rest string)
   (let ((input (join string)))
     (let ((output "")
           (index 0)
           (size (length input)))

-      (when (plusp size)
-        (setq output "    "))
+      (when (plusp (length input)) (concatf output "    "))

       (while (< index size)
       (while (< index size)

-        (setq output
-              (concat output
-                      (if (and (char= (char input index) #\newline)
-                               (< index (1- size))
-                               (not (char= (char input (1+ index)) #\newline)))
-                          (concat (string #\newline) "    ")
-                          (subseq input index (1+ index)))))
+        (let ((str
+               (if (and (char= (char input index) #\newline)
+                        (< index (1- size))
+                        (not (char= (char input (1+ index)) #\newline)))
+                   (concat (string #\newline) "    ")
+                   (string (char input index)))))
+          (concatf output str))

         (incf index))
       output)))
 
         (incf index))
       output)))
 

+#+common-lisp
+(defun indent (&rest string)
+  (with-output-to-string (*standard-output*)
+    (with-input-from-string (input (join string))
+      (loop
+         for line = (read-line input nil)
+         while line
+         do (write-string "    ")
+         do (write-line line)))))
+
+

 (defun integer-to-string (x)
   (cond
     ((zerop x)
 (defun integer-to-string (x)
   (cond
     ((zerop x)

@@ -539,7 +562,7 @@
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)

-       (let ((name (get form "fname")))
+       (let ((name (oget form "fname")))

          (if name
              (concat "#<FUNCTION " name ">")
              (concat "#<FUNCTION>"))))
          (if name
              (concat "#<FUNCTION " name ">")
              (concat "#<FUNCTION>"))))

@@ -755,9 +778,10 @@
 (defvar *environment* (make-lexenv))
 
 (defun clear-undeclared-global-bindings ()
 (defvar *environment* (make-lexenv))
 
 (defun clear-undeclared-global-bindings ()

-  (let ((variables (first *environment*))
-        (functions (second *environment*)))
-    (setq *environment* (list variables functions (third *environment*)))))
+  (setq *environment*
+       (mapcar (lambda (namespace)
+                 (remove-if-not #'binding-declared namespace))
+               *environment*)))

 
 
 (defvar *variable-counter* 0)
 
 
 (defvar *variable-counter* 0)

@@ -768,11 +792,12 @@
   (or (lookup-in-lexenv symbol env 'variable)
       (lookup-in-lexenv symbol *environment* 'variable)
       (let ((name (symbol-name symbol))
   (or (lookup-in-lexenv symbol env 'variable)
       (lookup-in-lexenv symbol *environment* 'variable)
       (let ((name (symbol-name symbol))

-            (binding (make-binding symbol 'variable (gvarname symbol) nil)))
+            (binding (make-binding symbol 'special-variable (gvarname symbol) nil)))

         (push-to-lexenv binding *environment* 'variable)
         (push (lambda ()
         (push-to-lexenv binding *environment* 'variable)
         (push (lambda ()

-                (unless (lookup-in-lexenv symbol *environment* 'variable)
-                  (error (concat "Undefined variable `" name "'"))))
+               (let ((b (lookup-in-lexenv symbol *environment* 'variable)))
+                 (unless (binding-declared b)
+                     (error (concat "Undefined variable `" name "'")))))

               *compilation-unit-checks*)
         binding)))
 
               *compilation-unit-checks*)
         binding)))
 

@@ -782,7 +807,7 @@
 (defun extend-local-env (args env)
   (let ((new (copy-lexenv env)))
     (dolist (symbol args new)
 (defun extend-local-env (args env)
   (let ((new (copy-lexenv env)))
     (dolist (symbol args new)

-      (let ((b (make-binding symbol 'variable (gvarname symbol) t)))
+      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t)))

         (push-to-lexenv b new 'variable)))))
 
 (defvar *function-counter* 0)
         (push-to-lexenv b new 'variable)))))
 
 (defvar *function-counter* 0)

@@ -797,8 +822,9 @@
                            nil)))
         (push-to-lexenv binding *environment* 'function)
         (push (lambda ()
                            nil)))
         (push-to-lexenv binding *environment* 'function)
         (push (lambda ()

-                (unless (binding-declared (lookup-in-lexenv symbol *environment* 'function))
-                  (error (concat "Undefined function `" name "'"))))
+               (let ((b (lookup-in-lexenv symbol *environment* 'function)))
+                 (unless (binding-declared b)
+                   (error (concat "Undefined function `" name "'")))))

               *compilation-unit-checks*)
         binding)))
 
               *compilation-unit-checks*)
         binding)))
 

@@ -942,9 +968,17 @@
           (ls-compile val env)))
 
 (define-compilation setq (var val)
           (ls-compile val env)))
 
 (define-compilation setq (var val)

-  (concat (lookup-variable-translation var env)
-          " = "
-           (ls-compile val env)))
+  (let ((b (lookup-variable var env)))
+    (ecase (binding-type b)
+      (lexical-variable (concat (binding-translation b) " = " (ls-compile val env)))
+      (special-variable (ls-compile `(set ',var ,val) env)))))
+
+;;; FFI Variable accessors
+(define-compilation js-vref (var)
+  var)
+(define-compilation js-vset (var val)
+  (concat "(" var " = " (ls-compile val env) ")"))
+

 
 ;;; Literals
 (defun escape-string (string)
 
 ;;; Literals
 (defun escape-string (string)

@@ -962,25 +996,43 @@
       (incf index))
     output))
 
       (incf index))
     output))
 

-(defun literal->js (sexp)
+
+(defvar *literal-symbols* nil)
+(defvar *literal-counter* 0)
+
+(defun genlit ()
+  (concat "l" (integer-to-string (incf *literal-counter*))))
+
+(defun literal (sexp &optional recursive)

   (cond
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
   (cond
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))

-    ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *environment*))
-    ((consp sexp) (concat "{car: "
-                          (literal->js (car sexp))
-                          ", cdr: "
-                          (literal->js (cdr sexp)) "}"))))
-
-(defvar *literal-counter* 0)
-(defun literal (form)
-  (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
-    (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
-    var))
+    ((symbolp sexp)
+     #+common-lisp
+     (or (cdr (assoc sexp *literal-symbols*))
+        (let ((v (genlit))
+              (s (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
+          (push (cons sexp v) *literal-symbols*)
+          (push (concat "var " v " = " s) *toplevel-compilations*)
+          v))
+     #+ecmalisp
+     (let ((v (genlit)))
+       (push (concat "var " v " = " (ls-compile `(intern ,(symbol-name sexp))))
+             *toplevel-compilations*)
+       v))
+    ((consp sexp)
+     (let ((c (concat "{car: " (literal (car sexp) t) ", "
+                     "cdr: " (literal (cdr sexp) t) "}")))
+       (if recursive
+          c
+          (let ((v (genlit)))
+            (push (concat "var " v " = " c) *toplevel-compilations*)
+            v))))))

 
 (define-compilation quote (sexp)
   (literal sexp))
 
 
 (define-compilation quote (sexp)
   (literal sexp))
 

+

 (define-compilation %while (pred &rest body)
   (js!selfcall
     "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline*
 (define-compilation %while (pred &rest body)
   (js!selfcall
     "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline*

@@ -1291,6 +1343,15 @@
 (define-builtin symbol-name (x)
   (concat "(" x ").name"))
 
 (define-builtin symbol-name (x)
   (concat "(" x ").name"))
 

+(define-builtin set (symbol value)
+  (concat "(" symbol ").value =" value))
+
+(define-builtin symbol-value (x)
+  (concat "(" x ").value"))
+
+(define-builtin symbol-function (x)
+  (concat "(" x ").function"))
+

 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 
 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
 

@@ -1365,12 +1426,12 @@
 
 (define-builtin new () "{}")
 
 
 (define-builtin new () "{}")
 

-(define-builtin get (object key)
+(define-builtin oget (object key)

   (js!selfcall
     "var tmp = " "(" object ")[" key "];" *newline*
     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
 
   (js!selfcall
     "var tmp = " "(" object ")[" key "];" *newline*
     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
 

-(define-builtin set (object key value)
+(define-builtin oset (object key value)

   (concat "((" object ")[" key "] = " value ")"))
 
 (define-builtin in (key object)
   (concat "((" object ")[" key "] = " value ")"))
 
 (define-builtin in (key object)

@@ -1412,7 +1473,13 @@
 
 (defun ls-compile (sexp &optional (env (make-lexenv)))
   (cond
 
 (defun ls-compile (sexp &optional (env (make-lexenv)))
   (cond

-    ((symbolp sexp) (lookup-variable-translation sexp env))
+    ((symbolp sexp)
+     (let ((b (lookup-variable sexp env)))
+       (ecase (binding-type b)
+        (lexical-variable
+         (binding-translation b))
+        (special-variable
+          (ls-compile `(symbol-value ',sexp) env)))))

     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((listp sexp)
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((listp sexp)

@@ -1424,13 +1491,21 @@
              (compile-funcall (car sexp) (cdr sexp) env))))))
 
 (defun ls-compile-toplevel (sexp)
              (compile-funcall (car sexp) (cdr sexp) env))))))
 
 (defun ls-compile-toplevel (sexp)

-  (setq *toplevel-compilations* nil)
-  (let ((code (ls-compile sexp)))
-    (prog1
-        (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
-                              *toplevel-compilations*))
-                code)
-      (setq *toplevel-compilations* nil))))
+  (cond
+    ((and (consp sexp) (eq (car sexp) 'progn))
+     (let ((subs (mapcar 'ls-compile-toplevel (cdr sexp))))
+       (join-trailing
+       (remove-if (lambda (s) (or (null s) (equal s "")))
+                  subs)
+       (concat ";" *newline*))))
+    (t
+     (setq *toplevel-compilations* nil)
+     (let ((code (ls-compile sexp)))
+       (prog1
+          (concat (join-trailing *toplevel-compilations*
+                                 (concat ";" *newline*))
+                  code)
+        (setq *toplevel-compilations* nil))))))

 
 
 ;;; Once we have the compiler, we define the runtime environment and
 
 
 ;;; Once we have the compiler, we define the runtime environment and

@@ -1464,22 +1539,22 @@
                    (setq *function-counter* ',*function-counter*)
                    (setq *literal-counter* ',*literal-counter*)
                    (setq *gensym-counter* ',*gensym-counter*)
                    (setq *function-counter* ',*function-counter*)
                    (setq *literal-counter* ',*literal-counter*)
                    (setq *gensym-counter* ',*gensym-counter*)

-                   (setq *block-counter* ',*block-counter*)))))
+                   (setq *block-counter* ',*block-counter*)
+                  ,@(mapcar (lambda (s)
+                              `(oset *package* ,(symbol-name (car s))
+                                     (js-vref ,(cdr s))))
+                            *literal-symbols*)))))

       (setq *toplevel-compilations*
             (append *toplevel-compilations* (list tmp)))))
 
       (setq *toplevel-compilations*
             (append *toplevel-compilations* (list tmp)))))
 

-  (js-eval
-   (concat "var lisp = {};"
-           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
-           "lisp.print = " (lookup-function-translation 'prin1-to-string nil) ";" *newline*
-           "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
-           "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
-           "lisp.evalString = function(str){" *newline*
-           "   return lisp.eval(lisp.read(str));" *newline*
-           "}" *newline*
-           "lisp.compileString = function(str){" *newline*
-           "   return lisp.compile(lisp.read(str));" *newline*
-           "}" *newline*)))
+  (js-eval "var lisp")
+  (js-vset "lisp" (new))
+  (js-vset "lisp.read" #'ls-read-from-string)
+  (js-vset "lisp.print" #'prin1-to-string)
+  (js-vset "lisp.eval" #'eval)
+  (js-vset "lisp.compile" #'ls-compile-toplevel)
+  (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
+  (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str)))))

 
 
 ;;; Finally, we provide a couple of functions to easily bootstrap
 
 
 ;;; Finally, we provide a couple of functions to easily bootstrap

@@ -1510,6 +1585,7 @@
 
   (defun bootstrap ()
     (setq *environment* (make-lexenv))
 
   (defun bootstrap ()
     (setq *environment* (make-lexenv))

+    (setq *literal-symbols* nil)

     (setq *variable-counter* 0
           *gensym-counter* 0
           *function-counter* 0
     (setq *variable-counter* 0
           *gensym-counter* 0
           *function-counter* 0