eql to char=

[jscl.git] / lispstrack.lisp

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 9e864b5..ee1aab7 100644 (file)
--- 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)))
 
@@ -72,7 +83,7 @@
 (defun %read-char (stream)
   (and (< (cdr stream) (length (car stream)))
        (prog1 (char (car stream) (cdr stream))
-         (incf (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)))))
 
@@ -153,7 +164,9 @@
          (#\'
           (list 'function (ls-read stream)))
          (#\\
-          (let ((cname (read-until stream #'terminalp)))
+          (let ((cname
+                (concat (string (%read-char stream))
+                        (read-until stream #'terminalp))))
             (cond
               ((string= cname "space") (char-code #\space))
               ((string= cname "newline") (char-code #\newline))
@@ -172,7 +185,7 @@
        (let ((string (read-until stream #'terminalp)))
          (if (every #'digit-char-p string)
              (parse-integer string)
-             (intern (string-upcase string)))))))))
+             (intern (string-upcase string))))))))
 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))
@@ -286,7 +299,7 @@
 
 (defun literal->js (sexp)
   (cond
-    ((null sexp) "undefined")
+    ((null sexp) "false")
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" sexp "\""))
     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
@@ -340,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.
@@ -405,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) "}"))
@@ -416,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) "}"))
 
@@ -507,11 +528,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)