X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=fa5dcc5f983122a9a68b7afbd887842481027578;hb=5a05b2053cf76ea53701c11072073994dbd31de8;hp=7a4682be3f5e106aac0ad2455c2f5972f4fab009;hpb=1fe6778f419fcbdc218f71bbb332e23de5fef941;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 7a4682b..fa5dcc5 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -47,7 +47,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)
@@ -63,10 +63,10 @@
   (defvar *package* (new))
 
   (defvar nil (make-symbol "NIL"))
-  (set *package* "NIL" nil)
+  (oset *package* "NIL" nil)
 
   (defvar t (make-symbol "T"))
-  (set *package* "T" t)
+  (oset *package* "T" t)
 
   (defun null (x)
     (eq x nil))
@@ -82,11 +82,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 +223,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 +270,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 +318,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 +489,40 @@
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 
-;;; Like CONCAT, but prefix each line with four spaces.
+
+;;; 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>"))))
@@ -755,9 +778,10 @@
 (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)
@@ -768,11 +792,12 @@
   (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 ()
-                (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)))
 
@@ -782,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)
@@ -797,8 +822,9 @@
                            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)))
 
@@ -942,9 +968,11 @@
           (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)))))
+
 
 ;;; Literals
 (defun escape-string (string)
@@ -1291,6 +1319,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 ")")))
 
@@ -1365,12 +1402,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)
@@ -1412,7 +1449,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
+	  (lookup-variable-translation sexp env))
+	 (special-variable
+	  (ls-compile `(symbol-value ',sexp) env)))))
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
     ((listp sexp)