Copy *literal-counter* to target properly

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 1754c19..04b1cb6 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,45 +29,38 @@
                        '(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))
                                                                  args)
                                                  ,@body))))))
 
                                                                    (if (eq x '&body)
                                                                        '&rest
                                                                        x))
                                                                  args)
                                                  ,@body))))))
 

-  (defmacro %defvar (name value)
+  (defmacro defvar (name value)

     `(progn
        (eval-when-compile
          (%compile-defvar ',name))
     `(progn
        (eval-when-compile
          (%compile-defvar ',name))

-       (setq ,name ,value)))
-
-  (defmacro defvar (name &optional value)
-    `(%defvar ,name ,value))
+       (setq ,name ,value)
+       ',name))

 
 

-  (defmacro named-lambda (name args &rest body)
+  (defmacro named-lambda (name args &body body)

     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))
     (let ((x (gensym "FN")))
       `(let ((,x (lambda ,args ,@body)))

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

          ,x)))
 
          ,x)))
 

-  (defmacro %defun (name args &rest body)
+  (defmacro defun (name args &body body)

     `(progn
        (eval-when-compile
          (%compile-defun ',name))
        (fsetq ,name (named-lambda ,(symbol-name name) ,args
     `(progn
        (eval-when-compile
          (%compile-defun ',name))
        (fsetq ,name (named-lambda ,(symbol-name name) ,args

-                      (block ,name ,@body)))))
-
-  (defmacro defun (name args &rest body)
-    `(%defun ,name ,args ,@body))
+                      (block ,name ,@body)))
+       ',name))

 
   (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 +76,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"))

@@ -223,7 +217,13 @@
     (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.

@@ -244,16 +244,6 @@
 ;;; constructions.
 #+ecmalisp
 (progn
 ;;; constructions.
 #+ecmalisp
 (progn

-  (defmacro defun (name args &body body)
-    `(progn
-       (%defun ,name ,args ,@body)
-       ',name))
-
-  (defmacro defvar (name &optional value)
-    `(progn
-       (%defvar ,name ,value)
-       ',name))
-

   (defun append-two (list1 list2)
     (if (null list1)
         list2
   (defun append-two (list1 list2)
     (if (null list1)
         list2

@@ -263,13 +253,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 +301,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,6 +472,8 @@
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 

+(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
 
 ;;; Like CONCAT, but prefix each line with four spaces. Two versions
 ;;; of this function are available, because the Ecmalisp version is

@@ -554,7 +547,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>"))))

@@ -784,7 +777,7 @@
   (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 ()
                (let ((b (lookup-in-lexenv symbol *environment* 'variable)))
         (push-to-lexenv binding *environment* 'variable)
         (push (lambda ()
                (let ((b (lookup-in-lexenv symbol *environment* 'variable)))

@@ -799,7 +792,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)

@@ -842,10 +835,7 @@
 
 (defun ls-compile-block (sexps env)
   (join-trailing
 
 (defun ls-compile-block (sexps env)
   (join-trailing

-   (remove-if (lambda (x)
-                (or (null x)
-                    (and (stringp x)
-                         (zerop (length x)))))
+   (remove-if #'null

               (mapcar (lambda (x) (ls-compile x env))  sexps))
    (concat ";" *newline*)))
 
               (mapcar (lambda (x) (ls-compile x env))  sexps))
    (concat ";" *newline*)))
 

@@ -960,9 +950,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)

@@ -980,25 +978,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*

@@ -1015,7 +1031,7 @@
 
 (define-compilation eval-when-compile (&rest body)
   (eval (cons 'progn body))
 
 (define-compilation eval-when-compile (&rest body)
   (eval (cons 'progn body))

-  "")
+  nil)

 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args
 
 (defmacro define-transformation (name args form)
   `(define-compilation ,name ,args

@@ -1267,7 +1283,9 @@
   (type-check (("x" "number" x))
     "Math.floor(x)"))
 
   (type-check (("x" "number" x))
     "Math.floor(x)"))
 

-(define-builtin cons (x y) (concat "({car: " x ", cdr: " y "})"))
+(define-builtin cons (x y)
+  (concat "({car: " x ", cdr: " y "})"))
+

 (define-builtin consp (x)
   (js!bool
    (js!selfcall
 (define-builtin consp (x)
   (js!bool
    (js!selfcall

@@ -1309,6 +1327,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 ")")))
 

@@ -1383,12 +1410,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)

@@ -1430,7 +1457,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)

@@ -1441,14 +1474,24 @@
              (ls-compile (ls-macroexpand-1 sexp env) env)
              (compile-funcall (car sexp) (cdr sexp) env))))))
 
              (ls-compile (ls-macroexpand-1 sexp env) env)
              (compile-funcall (car sexp) (cdr sexp) env))))))
 

+(defun null-or-empty-p (x)
+  (zerop (length x)))
+

 (defun ls-compile-toplevel (sexp)
   (setq *toplevel-compilations* nil)
 (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 (remove-if #'null-or-empty-p subs))))
+    (t
+     (let ((code (ls-compile sexp)))
+       (prog1
+           (concat (join-trailing (remove-if #'null-or-empty-p *toplevel-compilations*)
+                                  (concat ";" *newline*))
+                   (if code
+                       (concat code ";" *newline*)
+                       ""))
+         (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

@@ -1472,32 +1515,37 @@
                (ls-compile-toplevel x))))
       (js-eval code)))
 
                (ls-compile-toplevel x))))
       (js-eval code)))
 

+  (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))))
+

   ;; Set the initial global environment to be equal to the host global
   ;; environment at this point of the compilation.
   (eval-when-compile
     (let ((tmp (ls-compile
                 `(progn
   ;; Set the initial global environment to be equal to the host global
   ;; environment at this point of the compilation.
   (eval-when-compile
     (let ((tmp (ls-compile
                 `(progn

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

                    (setq *environment* ',*environment*)
                    (setq *environment* ',*environment*)

-                   (setq *variable-counter* ',*variable-counter*)
-                   (setq *function-counter* ',*function-counter*)
-                   (setq *literal-counter* ',*literal-counter*)
-                   (setq *gensym-counter* ',*gensym-counter*)
-                   (setq *block-counter* ',*block-counter*)))))
+                   (setq *variable-counter* ,*variable-counter*)
+                   (setq *function-counter* ,*function-counter*)
+                   (setq *gensym-counter* ,*gensym-counter*)
+                   (setq *block-counter* ,*block-counter*)))))

       (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*)))
+  ;; KLUDGE:
+  (eval-when-compile
+    (let ((tmp (ls-compile
+                `(setq *literal-counter* ,*literal-counter*))))
+      (setq *toplevel-compilations*
+            (append *toplevel-compilations* (list tmp))))))

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

@@ -1521,13 +1569,14 @@
            until (eq x *eof*)
            for compilation = (ls-compile-toplevel x)
            when (plusp (length compilation))
            until (eq x *eof*)
            for compilation = (ls-compile-toplevel x)
            when (plusp (length compilation))

-           do (write-line (concat compilation "; ") out))
+           do (write-string compilation out))

         (dolist (check *compilation-unit-checks*)
           (funcall check))
         (setq *compilation-unit-checks* nil))))
 
   (defun bootstrap ()
     (setq *environment* (make-lexenv))
         (dolist (check *compilation-unit-checks*)
           (funcall check))
         (setq *compilation-unit-checks* nil))))
 
   (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