(eval-when-compile
(%compile-defmacro 'defmacro
- (lambda (name args &rest body)
+ '(lambda (name args &rest body)
`(eval-when-compile
- (%compile-defmacro ',name (lambda ,args ,@body))))))
+ (%compile-defmacro ',name '(lambda ,args ,@body))))))
(defmacro defvar (name value)
`(progn
(defvar *package* (new))
+(defvar nil (make-symbol "NIL"))
+(set *package* "NIL" nil)
+
+(defvar t (make-symbol "T"))
+(set *package* "T" t)
+
+(defun internp (name)
+ (in name *package*))
+
(defun intern (name)
- (let ((s (get *package* name)))
- (if s s (set *package* name (make-symbol name)))))
+ (if (internp name)
+ (get *package* name)
+ (set *package* name (make-symbol name))))
(defun find-symbol (name)
(get *package* name))
-(defvar t 't)
-(defvar nil 'nil)
-
(defmacro when (condition &rest body)
`(if ,condition (progn ,@body) nil))
(defun truncate (x y) (floor (/ x y)))
(defun cons (x y ) (cons x y))
+(defun consp (x) (consp x))
+
(defun car (x) (car x))
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
-(defun caddr (x) (car (cdr x)))
-(defun cadddr (x) (car (cdr x)))
+(defun caddr (x) (car (cdr (cdr x))))
+(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun cdr (x) (cdr x))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
((null (cdr forms))
(car forms))
(t
- `(if ,(car forms)
- t
- (or ,@(cdr forms))))))
+ (let ((g (make-symbol "VAR")))
+ `(let ((,g ,(car forms)))
+ (if ,g ,g (or ,@(cdr forms))))))))
(defmacro prog1 (form &rest body)
(t
(cons (car list) (remove x (cdr list))))))
+(defun remove-if (func list)
+ (cond
+ ((null list)
+ nil)
+ ((funcall func (car list))
+ (remove-if func (cdr list)))
+ (t
+ (cons (car list) (remove-if func (cdr list))))))
+
+(defun remove-if-not (func list)
+ (cond
+ ((null list)
+ nil)
+ ((funcall func (car list))
+ (cons (car list) (remove-if-not func (cdr list))))
+ (t
+ (remove-if-not func (cdr list)))))
+
(defun digit-char-p (x)
(if (and (<= #\0 x) (<= x #\9))
(- x #\0)
(defun string= (s1 s2)
(equal s1 s2))
+;; ----------------------------------------------------------
+
+;;; Utils
+
+#+common-lisp
+(progn
+ (defmacro while (condition &body body)
+ `(do ()
+ ((not ,condition))
+ ,@body))
+
+ (defun concat-two (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)))
+
+(defun concat (&rest strs)
+ (!reduce (lambda (s1 s2) (concat-two s1 s2))
+ strs
+ ""))
+
+;;; Concatenate a list of strings, with a separator
+(defun join (list separator)
+ (cond
+ ((null list)
+ "")
+ ((null (cdr list))
+ (car list))
+ (t
+ (concat (car list)
+ separator
+ (join (cdr list) separator)))))
+
+(defun join-trailing (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)
+ "0"
+ (let ((digits nil))
+ (while (not (= x 0))
+ (push (mod x 10) digits)
+ (setq x (truncate x 10)))
+ (join (mapcar (lambda (d) (string (char "0123456789" d)))
+ digits)
+ ""))))
+
;;;; Reader
;;; It is a basic Lisp reader. It does not use advanced stuff
(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))))))
(#\+
(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 *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)
(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)
" : "
*newline*
(if rest-argument
(let ((js!rest (lookup-variable-translation rest-argument new-env)))
- (concat "var " js!rest "= false;" *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*
(defun literal->js (sexp)
(cond
- ((null sexp) "false")
((integerp sexp) (integer-to-string sexp))
((stringp sexp) (concat "\"" (escape-string sexp) "\""))
((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
", cdr: "
(literal->js (cdr sexp)) "}"))))
-(let ((counter 0))
- (defun literal (form)
- (cond
- ((null form)
- (literal->js form))
- (t
- (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)
"}})()"))
(lookup-function-translation x fenv))))
#+common-lisp
-(defmacro eval-when-compile (&body body)
+c(defmacro eval-when-compile (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@body))
;;; 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)
- (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")"))
+ (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
(define-compilation mod (x y)
(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) "}"))
(define-compilation consp (x)
- (concat "(function(){ var tmp = "
- (ls-compile x env fenv)
- "; return (typeof tmp == 'object' && 'car' in tmp);})()"))
+ (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) ")"))
(concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
(define-compilation symbolp (x)
- (concat "(function(){ var tmp = "
- (ls-compile x env fenv)
- "; return (typeof tmp == 'object' && 'name' in tmp); })()"))
+ (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)
- (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 string (x)
(concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
(define-compilation stringp (x)
- (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")"))
+ (compile-bool
+ (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
(define-compilation string-upcase (x)
(concat "(" (ls-compile x env fenv) ").toUpperCase()"))
(concat "(" (ls-compile func env fenv) ")()")
(let ((args (butlast args))
(last (car (last args))))
- (concat "function(){" *newline*
+ (concat "(function(){" *newline*
"var f = " (ls-compile func env fenv) ";" *newline*
"var args = [" (join (mapcar (lambda (x)
(ls-compile x env fenv))
", ")
"];" *newline*
"var tail = (" (ls-compile last env fenv) ");" *newline*
- "while (tail != false){" *newline*
- " args.push(tail[0]);" *newline*
- " args = args.slice(1);" *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*))))
+ "})()" *newline*))))
(define-compilation js-eval (string)
(concat "eval(" (ls-compile string env fenv) ")"))
"{}")
(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)))
(setq *toplevel-compilations* nil)
(let ((code (ls-compile sexp nil nil)))
(prog1
- (join (mapcar (lambda (x) (concat x ";" *newline*))
- *toplevel-compilations*)
- "")
- code
+ (concat #+common-lisp (concat "/* " (princ-to-string sexp) " */")
+ (join (mapcar (lambda (x) (concat x ";" *newline*))
+ *toplevel-compilations*)
+ "")
+ code)
(setq *toplevel-compilations* nil))))
-
-(defmacro with-compilation-unit (&rest body)
- `(progn
- (setq *env* nil)
- (setq *fenv* nil)
- (setq *compilation-unit-checks* nil)
- ,@body
- (dolist (check *compilation-unit-checks*)
- (funcall check))
- (setq *env* nil)
- (setq *fenv* nil)
- (setq *compilation-unit-checks* nil)))
-
-
#+common-lisp
(progn
(defun read-whole-file (filename)
(defun bootstrap ()
(ls-compile-file "lispstrack.lisp" "lispstrack.js")))
+;;; ----------------------------------------------------------
+(defmacro with-compilation-unit (&rest body)
+ `(prog1
+ (progn
+ (setq *compilation-unit-checks* nil)
+ (setq *env* (remove-if-not #'binding-declared *env*))
+ (setq *fenv* (remove-if-not #'binding-declared *fenv*))
+ ,@body)
+ (dolist (check *compilation-unit-checks*)
+ (funcall check))))
(defun eval (x)
- (js-eval (ls-compile x nil nil)))
+ (let ((code
+ (with-compilation-unit
+ (ls-compile-toplevel x nil nil))))
+ (js-eval code)))
+
+
+;; Set the initial global environment to be equal to the host global
+;; environment at this point of the compilation.
+(eval-when-compile
+ (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
+ (c2 (ls-compile `(setq *env* ',*env*) nil nil))
+ (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
+ (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
+ (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
+ (setq *toplevel-compilations*
+ (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
+
+(js-eval
+ (concat "var lisp = {};"
+ "lisp.read = " (lookup-function-translation 'ls-read-from-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*))
projects / jscl.git / blobdiff