X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=30649d2cc736d724a6a0c1260e7009e8fa2ebcce;hb=3eb2ddbf68c4e76bf771b3397c3c720128d0e2a2;hp=7d92ef4b028daea7801714680780b64e98f6261f;hpb=48ea10e44c0a53a266fb672d7627b1fa52314f61;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 7d92ef4..30649d2 100644
--- 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.
+
 #+ecmalisp
 (progn
   (eval-when-compile
@@ -28,7 +29,7 @@
                        '(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))
@@ -47,7 +48,7 @@
   (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)
@@ -62,11 +63,8 @@
 
   (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))
@@ -82,11 +80,11 @@
 
   (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)
-    (get *package* name))
+    (oget *package* name))
 
   (defvar *gensym-counter* 0)
   (defun gensym (&optional (prefix "G"))
@@ -223,7 +221,14 @@
     (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.
@@ -263,13 +268,14 @@
   (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)
-    (reverse-aux list '()))
+    (revappend list '()))
 
   (defun list-length (list)
     (let ((l 0))
@@ -310,29 +316,29 @@
   (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)
-    (cond
-      ((null list) list)
-      ((zerop n) (car list))
-      (t (nth (1- n) (cdr list)))))
+    (car (nthcdr n list)))
 
   (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)
-    (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
@@ -481,25 +487,42 @@
       ""
       (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)))
-      (when (plusp size)
-        (setq output "    "))
+      (when (plusp (length input)) (concatf output "    "))
       (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)))
 
+#+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)
@@ -539,7 +562,7 @@
       ((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>"))))
@@ -769,7 +792,7 @@
   (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)))
@@ -784,7 +807,7 @@
 (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)
@@ -945,9 +968,17 @@
           (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)
@@ -965,25 +996,43 @@
       (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) "\""))
-    ((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 %while (pred &rest body)
   (js!selfcall
     "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline*
@@ -1294,6 +1343,15 @@
 (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 ")")))
 
@@ -1368,12 +1426,12 @@
 
 (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*))
 
-(define-builtin set (object key value)
+(define-builtin oset (object key value)
   (concat "((" object ")[" key "] = " value ")"))
 
 (define-builtin in (key object)
@@ -1415,7 +1473,13 @@
 
 (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)
@@ -1427,13 +1491,21 @@
              (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
@@ -1467,22 +1539,22 @@
                    (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)))))
 
-  (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
@@ -1513,6 +1585,7 @@
 
   (defun bootstrap ()
     (setq *environment* (make-lexenv))
+    (setq *literal-symbols* nil)
     (setq *variable-counter* 0
           *gensym-counter* 0
           *function-counter* 0