(skip-whitespaces-and-comments stream)
(let ((ch (%peek-char stream)))
(cond
+ ((null ch)
+ (error "Unspected EOF"))
((char= ch #\))
(%read-char stream)
nil)
((char= ch #\.)
(%read-char stream)
- (skip-whitespaces-and-comments stream)
(prog1 (ls-read stream)
+ (skip-whitespaces-and-comments stream)
(unless (char= (%read-char stream) #\))
(error "')' was expected."))))
(t
(cons (ls-read stream) (%read-list stream))))))
+(defun read-string (stream)
+ (let ((string "")
+ (ch nil))
+ (setq ch (%read-char stream))
+ (while (not (eql ch #\"))
+ (when (null ch)
+ (error "Unexpected EOF"))
+ (when (eql ch #\\)
+ (setq ch (%read-char stream)))
+ (setq string (concat string (string ch)))
+ (setq ch (%read-char stream)))
+ string))
+
(defvar *eof* (make-symbol "EOF"))
(defun ls-read (stream)
(skip-whitespaces-and-comments stream)
(list 'backquote (ls-read stream)))
((char= ch #\")
(%read-char stream)
- (prog1 (read-until stream (lambda (ch) (char= ch #\")))
- (%read-char stream)))
+ (read-string stream))
((char= ch #\,)
(%read-char stream)
(if (eql (%peek-char stream) #\@)
(read-until stream #'terminalp))))
(cond
((string= cname "space") (char-code #\space))
+ ((string= cname "tab") (char-code #\tab))
((string= cname "newline") (char-code #\newline))
(t (char-code (char cname 0))))))
(#\+
(defvar *compilation-unit-checks* '())
-(defparameter *env* '())
-(defparameter *fenv* '())
+(defvar *env* '())
+(defvar *fenv* '())
(defun make-binding (name type js declared)
(list name type js declared))
(defun mark-binding-as-declared (b)
(setcar (cdddr b) t))
-(let ((counter 0))
- (defun gvarname (symbol)
- (concat "v" (integer-to-string (incf counter))))
-
- (defun lookup-variable (symbol env)
- (or (assoc symbol env)
- (assoc symbol *env*)
- (let ((name (symbol-name symbol))
- (binding (make-binding symbol 'variable (gvarname symbol) nil)))
- (push binding *env*)
- (push (lambda ()
- (unless (binding-declared (assoc symbol *env*))
- (error (concat "Undefined variable `" name "'"))))
- *compilation-unit-checks*)
- binding)))
-
- (defun lookup-variable-translation (symbol env)
- (binding-translation (lookup-variable symbol env)))
-
- (defun extend-local-env (args env)
- (append (mapcar (lambda (symbol)
- (make-binding symbol 'variable (gvarname symbol) t))
- args)
- env)))
-
-(let ((counter 0))
- (defun lookup-function (symbol env)
- (or (assoc symbol env)
- (assoc symbol *fenv*)
- (let ((name (symbol-name symbol))
- (binding
- (make-binding symbol
- 'function
- (concat "f" (integer-to-string (incf counter)))
- nil)))
- (push binding *fenv*)
- (push (lambda ()
- (unless (binding-declared (assoc symbol *fenv*))
- (error (concat "Undefined function `" name "'"))))
- *compilation-unit-checks*)
- binding)))
-
- (defun lookup-function-translation (symbol env)
- (binding-translation (lookup-function symbol env))))
-
-
-(defvar *toplevel-compilations*)
+(defvar *variable-counter* 0)
+(defun gvarname (symbol)
+ (concat "v" (integer-to-string (incf *variable-counter*))))
+
+(defun lookup-variable (symbol env)
+ (or (assoc symbol env)
+ (assoc symbol *env*)
+ (let ((name (symbol-name symbol))
+ (binding (make-binding symbol 'variable (gvarname symbol) nil)))
+ (push binding *env*)
+ (push (lambda ()
+ (unless (binding-declared (assoc symbol *env*))
+ (error (concat "Undefined variable `" name "'"))))
+ *compilation-unit-checks*)
+ binding)))
+
+(defun lookup-variable-translation (symbol env)
+ (binding-translation (lookup-variable symbol env)))
+
+(defun extend-local-env (args env)
+ (append (mapcar (lambda (symbol)
+ (make-binding symbol 'variable (gvarname symbol) t))
+ args)
+ env))
+
+(defvar *function-counter* 0)
+(defun lookup-function (symbol env)
+ (or (assoc symbol env)
+ (assoc symbol *fenv*)
+ (let ((name (symbol-name symbol))
+ (binding
+ (make-binding symbol
+ 'function
+ (concat "f" (integer-to-string (incf *function-counter*)))
+ nil)))
+ (push binding *fenv*)
+ (push (lambda ()
+ (unless (binding-declared (assoc symbol *fenv*))
+ (error (concat "Undefined function `" name "'"))))
+ *compilation-unit-checks*)
+ binding)))
+
+(defun lookup-function-translation (symbol env)
+ (binding-translation (lookup-function symbol env)))
+
+
+(defvar *toplevel-compilations* nil)
(defun %compile-defvar (name)
(let ((b (lookup-variable name *env*)))
sexps))
";
"))
-(defmacro define-compilation (name args &body body)
+(defmacro define-compilation (name args &rest body)
;; Creates a new primitive `name' with parameters args and
;; @body. The body can access to the local environment through the
;; variable ENV.
(define-compilation if (condition true false)
(concat "("
- (ls-compile condition env fenv)
+ (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
" ? "
(ls-compile true env fenv)
" : "
(let ((required-arguments (lambda-list-required-argument lambda-list))
(rest-argument (lambda-list-rest-argument lambda-list)))
(let ((new-env (extend-local-env
- (append (if rest-argument (list rest-argument))
+ (append (and rest-argument (list rest-argument))
required-arguments)
env)))
(concat "(function ("
*newline*
(if rest-argument
(let ((js!rest (lookup-variable-translation rest-argument new-env)))
- (concat "var " js!rest ";" *newline*
+ (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
"for (var i = arguments.length-1; i>="
(integer-to-string (length required-arguments))
"; i--)" *newline*
;;; Literals
+(defun escape-string (string)
+ (let ((output "")
+ (index 0)
+ (size (length string)))
+ (while (< index size)
+ (let ((ch (char string index)))
+ (when (or (char= ch #\") (char= ch #\\))
+ (setq output (concat output "\\")))
+ (when (or (char= ch #\newline))
+ (setq output (concat output "\\"))
+ (setq ch #\n))
+ (setq output (concat output (string ch))))
+ (incf index))
+ output))
+
(defun literal->js (sexp)
(cond
- ((null sexp) "false")
((integerp sexp) (integer-to-string sexp))
- ((stringp sexp) (concat "\"" sexp "\""))
- ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
+ ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
+ ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
((consp sexp) (concat "{car: "
(literal->js (car sexp))
", cdr: "
(literal->js (cdr sexp)) "}"))))
-(let ((counter 0))
- (defun literal (form)
- (if (null form)
- (literal->js form)
- (let ((var (concat "l" (integer-to-string (incf counter)))))
- (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
- var))))
+(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))
(define-compilation quote (sexp)
(literal sexp))
(define-compilation while (pred &rest body)
(concat "(function(){ while("
- (ls-compile pred env fenv)
+ (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
"){"
(ls-compile-block body env fenv)
"}})()"))
(define-transformation let (bindings &rest body)
(let ((bindings (mapcar #'ensure-list bindings)))
- `((lambda ,(mapcar 'car bindings) ,@body)
- ,@(mapcar 'cadr bindings))))
+ `((lambda ,(mapcar #'car bindings) ,@body)
+ ,@(mapcar #'cadr bindings))))
;;; A little backquote implementation without optimizations of any
;;; kind for lispstrack.
;;; Primitives
+(defun compile-bool (x)
+ (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
+
(define-compilation + (x y)
(concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
(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) "))"))
+ (compile-bool (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) "))"))
+ (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
+
+(define-compilation numberp (x)
+ (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
+
(define-compilation mod (x y)
(concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
(concat "(Math.floor(" (ls-compile x env fenv) "))"))
(define-compilation null (x)
- (concat "(" (ls-compile x env fenv) "== false)"))
+ (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
(define-compilation cons (x y)
- (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
+ (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
+
+(define-compilation consp (x)
+ (compile-bool
+ (concat "(function(){ var tmp = "
+ (ls-compile x env fenv)
+ "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
(define-compilation car (x)
- (concat "(" (ls-compile x env fenv) ").car"))
+ (concat "(function () { var tmp = " (ls-compile x env fenv)
+ "; return tmp === " (ls-compile nil nil nil) "? "
+ (ls-compile nil nil nil)
+ ": tmp.car; })()"))
(define-compilation cdr (x)
- (concat "(" (ls-compile x env fenv) ").cdr"))
+ (concat "(function () { var tmp = " (ls-compile x env fenv)
+ "; return tmp === " (ls-compile nil nil nil) "? "
+ (ls-compile nil nil nil)
+ ": tmp.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 symbolp (x)
+ (compile-bool
+ (concat "(function(){ var tmp = "
+ (ls-compile x env fenv)
+ "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
+
(define-compilation make-symbol (name)
(concat "{name: " (ls-compile name env fenv) "}"))
(concat "(" (ls-compile x env fenv) ").name"))
(define-compilation eq (x y)
- (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
+ (compile-bool
+ (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
+
+(define-compilation equal (x y)
+ (compile-bool
+ (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
(define-compilation string (x)
(concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
+(define-compilation stringp (x)
+ (compile-bool
+ (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
+
+(define-compilation string-upcase (x)
+ (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
+
+(define-compilation string-length (x)
+ (concat "(" (ls-compile x env fenv) ").length"))
+
(define-compilation char (string index)
(concat "("
(ls-compile string env fenv)
", ")
")"))
+(define-compilation apply (func &rest args)
+ (if (null args)
+ (concat "(" (ls-compile func env fenv) ")()")
+ (let ((args (butlast args))
+ (last (car (last args))))
+ (concat "(function(){" *newline*
+ "var f = " (ls-compile func env fenv) ";" *newline*
+ "var args = [" (join (mapcar (lambda (x)
+ (ls-compile x env fenv))
+ args)
+ ", ")
+ "];" *newline*
+ "var tail = (" (ls-compile last env fenv) ");" *newline*
+ "while (tail != " (ls-compile nil env fenv) "){" *newline*
+ " args.push(tail.car);" *newline*
+ " tail = tail.cdr;" *newline*
+ "}" *newline*
+ "return f.apply(this, args);" *newline*
+ "})()" *newline*))))
+
+(define-compilation js-eval (string)
+ (concat "eval.apply(window, [" (ls-compile string env fenv) "])"))
+
(define-compilation error (string)
- (concat "console.error(" (ls-compile string env fenv) ")"))
+ (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
(define-compilation new ()
"{}")
(define-compilation get (object key)
- (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
+ (concat "(function(){ var tmp = "
+ "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
+ ";"
+ "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
+ "})()"))
(define-compilation set (object key value)
(concat "(("
(ls-compile key env fenv) "]"
" = " (ls-compile value env fenv) ")"))
+(define-compilation in (key object)
+ (compile-bool
+ (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
+
+
(defun macrop (x)
(and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
-(defun ls-macroexpand-1 (form &optional env fenv)
- (when (macrop (car form))
- (let ((binding (lookup-function (car form) *env*)))
- (if (eq (binding-type binding) 'macro)
- (apply (eval (binding-translation binding)) (cdr form))
- form))))
+(defun ls-macroexpand-1 (form env fenv)
+ (if (macrop (car form))
+ (let ((binding (lookup-function (car form) *env*)))
+ (if (eq (binding-type binding) 'macro)
+ (apply (eval (binding-translation binding)) (cdr form))
+ form))
+ form))
(defun compile-funcall (function args env fenv)
(cond
", ")
")"))
(t
- (error "Invalid function designator ~a." function))))
+ (error (concat "Invalid function designator " (symbol-name function))))))
-(defun ls-compile (sexp &optional env fenv)
+(defun ls-compile (sexp env fenv)
(cond
((symbolp sexp) (lookup-variable-translation sexp env))
((integerp sexp) (integer-to-string sexp))
- ((stringp sexp) (concat "\"" sexp "\""))
+ ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
((listp sexp)
(if (assoc (car sexp) *compilations*)
(let ((comp (second (assoc (car sexp) *compilations*))))
(defun ls-compile-toplevel (sexp)
(setq *toplevel-compilations* nil)
- (let ((code (ls-compile sexp)))
+ (let ((code (ls-compile sexp nil nil)))
(prog1
- (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
+ (concat #+common-lisp (concat "/* " (princ-to-string sexp) " */")
+ (join (mapcar (lambda (x) (concat x ";" *newline*))
*toplevel-compilations*)
- "")
+ "")
code)
(setq *toplevel-compilations* nil))))
(defun ls-compile-file (filename output)
(setq *env* nil *fenv* nil)
+ (setq *compilation-unit-checks* nil)
(with-open-file (out output :direction :output :if-exists :supersede)
(let* ((source (read-whole-file filename))
(in (make-string-stream source)))
when (plusp (length compilation))
do (write-line (concat compilation "; ") out))
(dolist (check *compilation-unit-checks*)
- (funcall check)))))
+ (funcall check))
+ (setq *compilation-unit-checks* nil))))
(defun bootstrap ()
(ls-compile-file "lispstrack.lisp" "lispstrack.js")))