*newline*
(if rest-argument
(let ((js!rest (lookup-variable-translation rest-argument new-env)))
- (concat "var " js!rest ";" *newline*
+ (concat "var " js!rest "= false;" *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: "
(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))))
+ (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)))))
(define-compilation quote (sexp)
(literal sexp))
(concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
(define-compilation consp (x)
- (concat "('car' in " (ls-compile x env fenv) ")"))
-
+ (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 "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
(define-compilation symbolp (x)
- (concat "('name' in " (ls-compile x env fenv) ")"))
+ (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) "}"))
", ")
")"))
-(define-transformation apply (func &rest args)
+(define-compilation apply (func &rest args)
(if (null args)
(concat "(" (ls-compile func env fenv) ")()")
(let ((args (butlast args))
args)
", ")
"];" *newline*
- "var tail = (" (ls-compile last env fenv) ");"
+ "var tail = (" (ls-compile last env fenv) ");" *newline*
"while (tail != false){" *newline*
" args.push(tail[0]);" *newline*
- " args = args.slice(1);"
+ " args = args.slice(1);" *newline*
"}" *newline*
"return f.apply(this, args);" *newline*
"}" *newline*))))
(defun macrop (x)
(and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
-(defun ls-macroexpand-1 (form &optional env fenv)
+(defun ls-macroexpand-1 (form env fenv)
(when (macrop (car form))
(let ((binding (lookup-function (car form) *env*)))
(if (eq (binding-type binding) 'macro)
(t
(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*))))
(ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
(compile-funcall (car sexp) (cdr sexp) env fenv))))))
+(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)))
+
(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 "/* " (princ-to-string sexp) " */"
+ (join (mapcar (lambda (x) (concat x ";" *newline*))
*toplevel-compilations*)
- "")
+ "")
code)
(setq *toplevel-compilations* nil))))