X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=2febb3ab643217836c2a54b0328485b59428ac09;hb=bde4a4bf8433a91cfe6f0996af8b53bc1b778903;hp=3809e9f228f4c011a8eda8a5cdbb5bed918e1d91;hpb=9511928a30436c1ffeefccb79aea296a5b80f768;p=jscl.git

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 3809e9f..2febb3a 100644
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -1,3 +1,9 @@
+(defun ensure-list (x)
+  (if (listp x)
+      x
+      (list x)))
+
+
 (defun !reduce (func list initial)
   (if (null list)
       initial
@@ -15,7 +21,12 @@
        ,@body))
 
   (defun concat-two (s1 s2)
-    (concatenate 'string s1 s2)))
+    (concatenate 'string s1 s2))
+
+  (defun setcar (cons new)
+    (setf (car cons) new))
+  (defun setcdr (cons new)
+    (setf (cdr cons) new)))
 
 (defvar *newline* (string (code-char 10)))
 
@@ -37,9 +48,13 @@
              (join (cdr list) separator)))))
 
 (defun join-trailing (list separator)
-  (if (null list)
-      ""
-      (concat (car list) separator (join-trailing (cdr list) separator))))
+  (cond
+    ((null list)
+     "")
+    ((null (car list))
+     (join-trailing (cdr list) separator))
+    (t
+     (concat (car list) separator (join-trailing (cdr list) separator)))))
 
 (defun integer-to-string (x)
   (if (zerop x)
@@ -62,17 +77,13 @@
   (cons string 0))
 
 (defun %peek-char (stream)
-  (if (streamp stream)
-      (peek-char nil stream nil)
-      (and (< (cdr stream) (length (car stream)))
-           (char (car stream) (cdr stream)))))
+  (and (< (cdr stream) (length (car stream)))
+       (char (car stream) (cdr stream))))
 
 (defun %read-char (stream)
-  (if (streamp stream)
-      (read-char stream nil)
-      (and (< (cdr stream) (length (car stream)))
-           (prog1 (char (car stream) (cdr stream))
-             (incf (cdr stream))))))
+  (and (< (cdr stream) (length (car stream)))
+       (prog1 (char (car stream) (cdr stream))
+         (setcdr stream (1+ (cdr stream))))))
 
 (defun whitespacep (ch)
   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
@@ -101,8 +112,8 @@
   (let (ch)
     (skip-whitespaces stream)
     (setq ch (%peek-char stream))
-    (while (and ch (eql ch #\;))
-      (read-until stream (lambda (x) (eql x #\newline)))
+    (while (and ch (char= ch #\;))
+      (read-until stream (lambda (x) (char= x #\newline)))
       (skip-whitespaces stream)
       (setq ch (%peek-char stream)))))
 
@@ -152,11 +163,19 @@
        (ecase (%read-char stream)
          (#\'
           (list 'function (ls-read stream)))
+         (#\\
+          (let ((cname
+		 (concat (string (%read-char stream))
+			 (read-until stream #'terminalp))))
+            (cond
+              ((string= cname "space") (char-code #\space))
+              ((string= cname "newline") (char-code #\newline))
+              (t (char-code (char cname 0))))))
          (#\+
           (let ((feature (read-until stream #'terminalp)))
             (cond
               ((string= feature "common-lisp")
-               (ls-read stream);ignore
+               (ls-read stream)         ;ignore
                (ls-read stream))
               ((string= feature "lispstrack")
                (ls-read stream))
@@ -280,7 +299,7 @@
 
 (defun literal->js (sexp)
   (cond
-    ((null sexp) "unspecified")
+    ((null sexp) "false")
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" sexp "\""))
     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
@@ -334,8 +353,9 @@
   `((lambda () ,@body)))
 
 (define-transformation let (bindings &rest body)
-  `((lambda ,(mapcar 'car bindings) ,@body)
-    ,@(mapcar 'cadr bindings)))
+  (let ((bindings (mapcar #'ensure-list bindings)))
+    `((lambda ,(mapcar 'car bindings) ,@body)
+      ,@(mapcar 'cadr bindings))))
 
 ;;; A little backquote implementation without optimizations of any
 ;;; kind for lispstrack.
@@ -386,6 +406,9 @@
 (define-compilation / (x y)
   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 
+(define-compilation < (x y)
+  (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
+
 (define-compilation = (x y)
   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 
@@ -396,7 +419,7 @@
   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 
 (define-compilation null (x)
-  (concat "(" (ls-compile x env fenv) "== undefined)"))
+  (concat "(" (ls-compile x env fenv) "== false)"))
 
 (define-compilation cons (x y)
   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
@@ -407,6 +430,13 @@
 (define-compilation cdr (x)
   (concat "(" (ls-compile x env fenv) ").cdr"))
 
+(define-compilation setcar (x new)
+  (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
+
+(define-compilation setcdr (x new)
+  (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
+
+
 (define-compilation make-symbol (name)
   (concat "{name: " (ls-compile name env fenv) "}"))
 
@@ -443,6 +473,10 @@
                 ", ")
           ")"))
 
+(define-compilation error (string)
+  (concat "console.error(" (ls-compile string env fenv) ")"))
+
+
 (define-compilation new ()
   "{}")
 
@@ -498,11 +532,14 @@
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" sexp "\""))
     ((listp sexp)
-     (let ((sexp (ls-macroexpand-1 sexp env fenv)))
-       (let ((compiler-func (second (assoc (car sexp) *compilations*))))
-         (if compiler-func
-             (apply compiler-func env fenv (cdr sexp))
-             (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
+     (if (assoc (car sexp) *compilations*)
+         (let ((comp (second (assoc (car sexp) *compilations*))))
+           (apply comp env fenv (cdr sexp)))
+         (let ((fn (cdr (assoc (car sexp) *fenv*))))
+           (if (and (listp fn) (eq (car fn) 'macro))
+               (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
+               (compile-funcall (car sexp) (cdr sexp) env fenv)))))))
+
 
 (defun ls-compile-toplevel (sexp)
   (setq *toplevel-compilations* nil)
@@ -516,15 +553,24 @@
 
 #+common-lisp
 (progn
+
+  (defun read-whole-file (filename)
+    (with-open-file (in filename)
+      (let ((seq (make-array (file-length in) :element-type 'character)))
+        (read-sequence seq in)
+        seq)))
+
   (defun ls-compile-file (filename output)
     (setq *env* nil *fenv* nil)
-    (with-open-file (in filename)
-      (with-open-file (out output :direction :output :if-exists :supersede)
+    (with-open-file (out output :direction :output :if-exists :supersede)
+      (let* ((source (read-whole-file filename))
+             (in (make-string-stream source)))
         (loop
            for x = (ls-read in)
            until (eq x *eof*)
            for compilation = (ls-compile-toplevel x)
            when (plusp (length compilation))
            do (write-line (concat compilation "; ") out)))))
+
   (defun bootstrap ()
     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))