;;; compiler.lisp ---
;; copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with JSCL. If not, see .
;;;; Compiler
(/debug "loading compiler.lisp!")
;;; Translate the Lisp code to Javascript. It will compile the special
;;; forms. Some primitive functions are compiled as special forms
;;; too. The respective real functions are defined in the target (see
;;; the beginning of this file) as well as some primitive functions.
(defun interleave (list element &optional after-last-p)
(unless (null list)
(with-collect
(collect (car list))
(dolist (x (cdr list))
(collect element)
(collect x))
(when after-last-p
(collect element)))))
(defun code (&rest args)
(mapconcat (lambda (arg)
(cond
((null arg) "")
((integerp arg) (integer-to-string arg))
((floatp arg) (float-to-string arg))
((stringp arg) arg)
(t
(with-output-to-string (*standard-output*)
(js-expr arg)))))
args))
;;; Wrap X with a Javascript code to convert the result from
;;; Javascript generalized booleans to T or NIL.
(defun js!bool (x)
`(if ,x ,(ls-compile t) ,(ls-compile nil)))
;;; Concatenate the arguments and wrap them with a self-calling
;;; Javascript anonymous function. It is used to make some Javascript
;;; statements valid expressions and provide a private scope as well.
;;; It could be defined as function, but we could do some
;;; preprocessing in the future.
(defmacro js!selfcall (&body body)
``(call (function nil (code ,,@body))))
(defmacro js!selfcall* (&body body)
``(call (function nil ,,@body)))
;;; Like CODE, but prefix each line with four spaces. Two versions
;;; of this function are available, because the Ecmalisp version is
;;; very slow and bootstraping was annoying.
;;; A Form can return a multiple values object calling VALUES, like
;;; values(arg1, arg2, ...). It will work in any context, as well as
;;; returning an individual object. However, if the special variable
;;; `*multiple-value-p*' is NIL, is granted that only the primary
;;; value will be used, so we can optimize to avoid the VALUES
;;; function call.
(defvar *multiple-value-p* nil)
;;; Environment
(def!struct binding
name
type
value
declarations)
(def!struct lexenv
variable
function
block
gotag)
(defun lookup-in-lexenv (name lexenv namespace)
(find name (ecase namespace
(variable (lexenv-variable lexenv))
(function (lexenv-function lexenv))
(block (lexenv-block lexenv))
(gotag (lexenv-gotag lexenv)))
:key #'binding-name))
(defun push-to-lexenv (binding lexenv namespace)
(ecase namespace
(variable (push binding (lexenv-variable lexenv)))
(function (push binding (lexenv-function lexenv)))
(block (push binding (lexenv-block lexenv)))
(gotag (push binding (lexenv-gotag lexenv)))))
(defun extend-lexenv (bindings lexenv namespace)
(let ((env (copy-lexenv lexenv)))
(dolist (binding (reverse bindings) env)
(push-to-lexenv binding env namespace))))
(defvar *environment* (make-lexenv))
(defvar *variable-counter* 0)
(defun gvarname (symbol)
(declare (ignore symbol))
(code "v" (incf *variable-counter*)))
(defun translate-variable (symbol)
(awhen (lookup-in-lexenv symbol *environment* 'variable)
(binding-value it)))
(defun extend-local-env (args)
(let ((new (copy-lexenv *environment*)))
(dolist (symbol args new)
(let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
(push-to-lexenv b new 'variable)))))
;;; Toplevel compilations
(defvar *toplevel-compilations* nil)
(defun toplevel-compilation (string)
(push string *toplevel-compilations*))
(defun get-toplevel-compilations ()
(reverse *toplevel-compilations*))
(defun %compile-defmacro (name lambda)
(toplevel-compilation (ls-compile `',name))
(let ((binding (make-binding :name name :type 'macro :value lambda)))
(push-to-lexenv binding *environment* 'function))
name)
(defun global-binding (name type namespace)
(or (lookup-in-lexenv name *environment* namespace)
(let ((b (make-binding :name name :type type :value nil)))
(push-to-lexenv b *environment* namespace)
b)))
(defun claimp (symbol namespace claim)
(let ((b (lookup-in-lexenv symbol *environment* namespace)))
(and b (member claim (binding-declarations b)))))
(defun !proclaim (decl)
(case (car decl)
(special
(dolist (name (cdr decl))
(let ((b (global-binding name 'variable 'variable)))
(push 'special (binding-declarations b)))))
(notinline
(dolist (name (cdr decl))
(let ((b (global-binding name 'function 'function)))
(push 'notinline (binding-declarations b)))))
(constant
(dolist (name (cdr decl))
(let ((b (global-binding name 'variable 'variable)))
(push 'constant (binding-declarations b)))))))
#+jscl
(fset 'proclaim #'!proclaim)
(defun %define-symbol-macro (name expansion)
(let ((b (make-binding :name name :type 'macro :value expansion)))
(push-to-lexenv b *environment* 'variable)
name))
#+jscl
(defmacro define-symbol-macro (name expansion)
`(%define-symbol-macro ',name ',expansion))
;;; Special forms
(defvar *compilations* nil)
(defmacro define-compilation (name args &body body)
;; Creates a new primitive `name' with parameters args and
;; @body. The body can access to the local environment through the
;; variable *ENVIRONMENT*.
`(push (list ',name (lambda ,args (block ,name ,@body)))
*compilations*))
(define-compilation if (condition true &optional false)
`(if (!== ,(ls-compile condition) ,(ls-compile nil))
,(ls-compile true *multiple-value-p*)
,(ls-compile false *multiple-value-p*)))
(defvar *ll-keywords* '(&optional &rest &key))
(defun list-until-keyword (list)
(if (or (null list) (member (car list) *ll-keywords*))
nil
(cons (car list) (list-until-keyword (cdr list)))))
(defun ll-section (keyword ll)
(list-until-keyword (cdr (member keyword ll))))
(defun ll-required-arguments (ll)
(list-until-keyword ll))
(defun ll-optional-arguments-canonical (ll)
(mapcar #'ensure-list (ll-section '&optional ll)))
(defun ll-optional-arguments (ll)
(mapcar #'car (ll-optional-arguments-canonical ll)))
(defun ll-rest-argument (ll)
(let ((rest (ll-section '&rest ll)))
(when (cdr rest)
(error "Bad lambda-list `~S'." ll))
(car rest)))
(defun ll-keyword-arguments-canonical (ll)
(flet ((canonicalize (keyarg)
;; Build a canonical keyword argument descriptor, filling
;; the optional fields. The result is a list of the form
;; ((keyword-name var) init-form).
(let ((arg (ensure-list keyarg)))
(cons (if (listp (car arg))
(car arg)
(list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
(cdr arg)))))
(mapcar #'canonicalize (ll-section '&key ll))))
(defun ll-keyword-arguments (ll)
(mapcar (lambda (keyarg) (second (first keyarg)))
(ll-keyword-arguments-canonical ll)))
(defun ll-svars (lambda-list)
(let ((args
(append
(ll-keyword-arguments-canonical lambda-list)
(ll-optional-arguments-canonical lambda-list))))
(remove nil (mapcar #'third args))))
(defun lambda-name/docstring-wrapper (name docstring code)
(if (or name docstring)
(js!selfcall*
`(var (func ,code))
(when name `(= (get func |fname|) ,name))
(when docstring `(= (get func |docstring|) ,docstring))
`(return func))
`(code ,code)))
(defun lambda-check-argument-count
(n-required-arguments n-optional-arguments rest-p)
;; Note: Remember that we assume that the number of arguments of a
;; call is at least 1 (the values argument).
(let ((min n-required-arguments)
(max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments))))
(block nil
;; Special case: a positive exact number of arguments.
(when (and (< 0 min) (eql min max))
(return `(code "checkArgs(nargs, " ,min ");")))
;; General case:
`(code
,(when (< 0 min)
`(code "checkArgsAtLeast(nargs, " ,min ");"))
,(when (numberp max)
`(code "checkArgsAtMost(nargs, " ,max ");"))))))
(defun compile-lambda-optional (ll)
(let* ((optional-arguments (ll-optional-arguments-canonical ll))
(n-required-arguments (length (ll-required-arguments ll)))
(n-optional-arguments (length optional-arguments)))
(when optional-arguments
`(code "switch(nargs){"
,(let ((cases nil)
(idx 0))
(progn
(while (< idx n-optional-arguments)
(let ((arg (nth idx optional-arguments)))
(push `(code "case " ,(+ idx n-required-arguments) ":"
(code ,(translate-variable (car arg))
"="
,(ls-compile (cadr arg)) ";")
,(when (third arg)
`(code ,(translate-variable (third arg))
"="
,(ls-compile nil)
";")))
cases)
(incf idx)))
(push `(code "default: break;") cases)
`(code ,@(reverse cases))))
"}"))))
(defun compile-lambda-rest (ll)
(let ((n-required-arguments (length (ll-required-arguments ll)))
(n-optional-arguments (length (ll-optional-arguments ll)))
(rest-argument (ll-rest-argument ll)))
(when rest-argument
(let ((js!rest (translate-variable rest-argument)))
`(code "var " ,js!rest "= " ,(ls-compile nil) ";"
"for (var i = nargs-1; i>=" ,(+ n-required-arguments n-optional-arguments)
"; i--)"
(code ,js!rest " = {car: arguments[i+2], cdr: " ,js!rest "};"))))))
(defun compile-lambda-parse-keywords (ll)
(let ((n-required-arguments
(length (ll-required-arguments ll)))
(n-optional-arguments
(length (ll-optional-arguments ll)))
(keyword-arguments
(ll-keyword-arguments-canonical ll)))
`(code
;; Declare variables
,@(mapcar (lambda (arg)
(let ((var (second (car arg))))
`(code "var " ,(translate-variable var) "; "
,(when (third arg)
`(code "var " ,(translate-variable (third arg))
" = " ,(ls-compile nil)
";" )))))
keyword-arguments)
;; Parse keywords
,(flet ((parse-keyword (keyarg)
;; ((keyword-name var) init-form)
`(code "for (i=" ,(+ n-required-arguments n-optional-arguments)
"; i >)
(define-builtin-comparison < <)
(define-builtin-comparison >= >=)
(define-builtin-comparison <= <=)
(define-builtin-comparison = ==)
(define-builtin-comparison /= !=)
(define-builtin numberp (x)
(js!bool `(== (typeof ,x) "number")))
(define-builtin floor (x)
(type-check (("x" "number" x))
"Math.floor(x)"))
(define-builtin expt (x y)
(type-check (("x" "number" x)
("y" "number" y))
"Math.pow(x, y)"))
(define-builtin float-to-string (x)
(type-check (("x" "number" x))
"make_lisp_string(x.toString())"))
(define-builtin cons (x y)
`(object "car" ,x "cdr" ,y))
(define-builtin consp (x)
(js!bool
(js!selfcall
"var tmp = " x ";"
"return (typeof tmp == 'object' && 'car' in tmp);" )))
(define-builtin car (x)
(js!selfcall*
`(var (tmp ,x))
`(return (if (=== tmp ,(ls-compile nil))
,(ls-compile nil)
(get tmp "car")))))
(define-builtin cdr (x)
(js!selfcall*
`(var (tmp ,x))
`(return (if (=== tmp ,(ls-compile nil))
,(ls-compile nil)
(get tmp "cdr")))))
(define-builtin rplaca (x new)
(type-check (("x" "object" x))
`(code "(x.car = " ,new ", x)")))
(define-builtin rplacd (x new)
(type-check (("x" "object" x))
`(code "(x.cdr = " ,new ", x)")))
(define-builtin symbolp (x)
(js!bool `(instanceof ,x |Symbol|)))
(define-builtin make-symbol (name)
`(new (call |Symbol| ,name)))
(define-builtin symbol-name (x)
`(get ,x "name"))
(define-builtin set (symbol value)
`(= (get ,symbol "value") ,value))
(define-builtin fset (symbol value)
`(= (get ,symbol "fvalue") ,value))
(define-builtin boundp (x)
(js!bool `(!== (get ,x "value") undefined)))
(define-builtin fboundp (x)
(js!bool `(!== (get ,x "fvalue") undefined)))
(define-builtin symbol-value (x)
(js!selfcall*
`(var (symbol ,x)
(value (get symbol "value")))
`(if (=== value undefined)
(throw (+ "Variable `" (call |xstring| (get symbol "name")) "' is unbound.")))
`(return value)))
(define-builtin symbol-function (x)
(js!selfcall*
`(var (symbol ,x)
(func (get symbol "fvalue")))
`(if (=== func undefined)
(throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
`(return func)))
(define-builtin symbol-plist (x)
`(or (get ,x "plist") ,(ls-compile nil)))
(define-builtin lambda-code (x)
`(call |make_lisp_string| (call (get ,x "toString"))))
(define-builtin eq (x y)
(js!bool `(=== ,x ,y)))
(define-builtin char-code (x)
(type-check (("x" "string" x))
"char_to_codepoint(x)"))
(define-builtin code-char (x)
(type-check (("x" "number" x))
"char_from_codepoint(x)"))
(define-builtin characterp (x)
(js!bool
(js!selfcall
"var x = " x ";"
"return (typeof(" x ") == \"string\") && (x.length == 1 || x.length == 2);")))
(define-builtin char-upcase (x)
`(call |safe_char_upcase| ,x))
(define-builtin char-downcase (x)
`(call |safe_char_downcase| ,x))
(define-builtin stringp (x)
(js!bool
(js!selfcall*
`(var (x ,x))
`(return (and (and (===(typeof x) "object")
(in "length" x))
(== (get x "stringp") 1))))))
(define-raw-builtin funcall (func &rest args)
(js!selfcall
"var f = " (ls-compile func) ";"
"return (typeof f === 'function'? f: f.fvalue)("
`(code
,@(interleave (list* (if *multiple-value-p* "values" "pv")
(integer-to-string (length args))
(mapcar #'ls-compile args))
", "))
")"))
(define-raw-builtin apply (func &rest args)
(if (null args)
`(code "(" ,(ls-compile func) ")()")
(let ((args (butlast args))
(last (car (last args))))
(js!selfcall
"var f = " (ls-compile func) ";"
"var args = [" `(code
,@(interleave (list* (if *multiple-value-p* "values" "pv")
(integer-to-string (length args))
(mapcar #'ls-compile args))
", "))
"];"
"var tail = (" (ls-compile last) ");"
"while (tail != " (ls-compile nil) "){"
" args.push(tail.car);"
" args[1] += 1;"
" tail = tail.cdr;"
"}"
"return (typeof f === 'function'? f : f.fvalue).apply(this, args);" ))))
(define-builtin js-eval (string)
(if *multiple-value-p*
(js!selfcall*
`(var (v (call |globalEval| (call |xstring| ,string))))
`(return (call (get |values| "apply") this (call |forcemv| v))))
`(call |globalEval| (call |xstring| ,string))))
(define-builtin %throw (string)
(js!selfcall* `(throw ,string)))
(define-builtin functionp (x)
(js!bool `(=== (typeof ,x) "function")))
(define-builtin %write-string (x)
`(call (get |lisp| "write") ,x))
(define-builtin /debug (x)
`(call (get |console| "log") (call |xstring| ,x)))
;;; Storage vectors. They are used to implement arrays and (in the
;;; future) structures.
(define-builtin storage-vector-p (x)
(js!bool
(js!selfcall*
`(var (x ,x))
`(return (and (=== (typeof x) "object") (in "length" x))))))
(define-builtin make-storage-vector (n)
(js!selfcall*
`(var (r #()))
`(= (get r "length") ,n)
`(return r)))
(define-builtin storage-vector-size (x)
`(get ,x "length"))
(define-builtin resize-storage-vector (vector new-size)
`(= (get ,vector "length") ,new-size))
(define-builtin storage-vector-ref (vector n)
(js!selfcall*
`(var (x (get ,vector ,n)))
`(if (=== x undefined) (throw "Out of range."))
`(return x)))
(define-builtin storage-vector-set (vector n value)
(js!selfcall*
`(var (x ,vector))
`(var (i ,n))
`(if (or (< i 0) (>= i (get x "length")))
(throw "Out of range."))
`(return (= (property x i) ,value))))
(define-builtin concatenate-storage-vector (sv1 sv2)
(js!selfcall*
`(var (sv1 ,sv1))
`(var (r (call (get sv1 "concat") ,sv2)))
`(= (get r "type") (get sv1 "type"))
`(= (get r "stringp") (get sv1 "stringp"))
`(return r)))
(define-builtin get-internal-real-time ()
`(call (get (new (call Date)) "getTime")))
(define-builtin values-array (array)
(if *multiple-value-p*
`(code "values.apply(this, " ,array ")")
`(code "pv.apply(this, " ,array ")")))
(define-raw-builtin values (&rest args)
(if *multiple-value-p*
`(code "values(" ,@(interleave (mapcar #'ls-compile args) ",") ")")
`(code "pv(" ,@(interleave (mapcar #'ls-compile args) ", ") ")")))
;;; Javascript FFI
(define-builtin new ()
'(object))
(define-raw-builtin oget* (object key &rest keys)
(js!selfcall*
`(progn
(var (tmp (get ,(ls-compile object) (call |xstring| ,(ls-compile key)))))
,@(mapcar (lambda (key)
`(progn
(if (=== tmp undefined) (return ,(ls-compile nil)))
(= tmp (get tmp (call |xstring| ,(ls-compile key))))))
keys))
`(return (if (=== tmp undefined) ,(ls-compile nil) tmp))))
(define-raw-builtin oset* (value object key &rest keys)
(let ((keys (cons key keys)))
(js!selfcall*
`(progn
(var (obj ,(ls-compile object)))
,@(mapcar (lambda (key)
`(progn
(= obj (get obj (call |xstring| ,(ls-compile key))))
(if (=== object undefined)
(throw "Impossible to set object property."))))
(butlast keys))
(var (tmp
(= (get obj (call |xstring| ,(ls-compile (car (last keys)))))
,(ls-compile value))))
(return (if (=== tmp undefined)
,(ls-compile nil)
tmp))))))
(define-raw-builtin oget (object key &rest keys)
`(call |js_to_lisp| ,(ls-compile `(oget* ,object ,key ,@keys))))
(define-raw-builtin oset (value object key &rest keys)
(ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys)))
(define-builtin objectp (x)
(js!bool `(=== (typeof ,x) "object")))
(define-builtin lisp-to-js (x) `(call |lisp_to_js| ,x))
(define-builtin js-to-lisp (x) `(call |js_to_lisp| ,x))
(define-builtin in (key object)
(js!bool `(in (call |xstring| ,key) ,object)))
(define-builtin map-for-in (function object)
(js!selfcall
"var f = " function ";"
"var g = (typeof f === 'function' ? f : f.fvalue);"
"var o = " object ";"
"for (var key in o){"
`(code "g(" ,(if *multiple-value-p* "values" "pv") ", 1, o[key]);" )
"}"
" return " (ls-compile nil) ";" ))
(define-compilation %js-vref (var)
`(code "js_to_lisp(" ,var ")"))
(define-compilation %js-vset (var val)
`(code "(" ,var " = lisp_to_js(" ,(ls-compile val) "))"))
(define-setf-expander %js-vref (var)
(let ((new-value (gensym)))
(unless (stringp var)
(error "`~S' is not a string." var))
(values nil
(list var)
(list new-value)
`(%js-vset ,var ,new-value)
`(%js-vref ,var))))
#-jscl
(defvar *macroexpander-cache*
(make-hash-table :test #'eq))
(defun !macro-function (symbol)
(unless (symbolp symbol)
(error "`~S' is not a symbol." symbol))
(let ((b (lookup-in-lexenv symbol *environment* 'function)))
(if (and b (eq (binding-type b) 'macro))
(let ((expander (binding-value b)))
(cond
#-jscl
((gethash b *macroexpander-cache*)
(setq expander (gethash b *macroexpander-cache*)))
((listp expander)
(let ((compiled (eval expander)))
;; The list representation are useful while
;; bootstrapping, as we can dump the definition of the
;; macros easily, but they are slow because we have to
;; evaluate them and compile them now and again. So, let
;; us replace the list representation version of the
;; function with the compiled one.
;;
#+jscl (setf (binding-value b) compiled)
#-jscl (setf (gethash b *macroexpander-cache*) compiled)
(setq expander compiled))))
expander)
nil)))
(defun !macroexpand-1 (form)
(cond
((symbolp form)
(let ((b (lookup-in-lexenv form *environment* 'variable)))
(if (and b (eq (binding-type b) 'macro))
(values (binding-value b) t)
(values form nil))))
((and (consp form) (symbolp (car form)))
(let ((macrofun (!macro-function (car form))))
(if macrofun
(values (funcall macrofun (cdr form)) t)
(values form nil))))
(t
(values form nil))))
(defun compile-funcall (function args)
(let* ((values-funcs (if *multiple-value-p* "values" "pv"))
(arglist `(code "(" ,@(interleave (list* values-funcs
(integer-to-string (length args))
(mapcar #'ls-compile args))
", ")
")")))
(unless (or (symbolp function)
(and (consp function)
(member (car function) '(lambda oget))))
(error "Bad function designator `~S'" function))
(cond
((translate-function function)
`(code ,(translate-function function) ,arglist))
((and (symbolp function)
#+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
#-jscl t)
`(code ,(ls-compile `',function) ".fvalue" ,arglist))
#+jscl((symbolp function)
`(code ,(ls-compile `#',function) ,arglist))
((and (consp function) (eq (car function) 'lambda))
`(code ,(ls-compile `#',function) ,arglist))
((and (consp function) (eq (car function) 'oget))
`(code ,(ls-compile function) ,arglist))
(t
(error "Bad function descriptor")))))
(defun ls-compile-block (sexps &optional return-last-p decls-allowed-p)
(multiple-value-bind (sexps decls)
(parse-body sexps :declarations decls-allowed-p)
(declare (ignore decls))
(if return-last-p
`(code ,(ls-compile-block (butlast sexps) nil decls-allowed-p)
"return " ,(ls-compile (car (last sexps)) *multiple-value-p*) ";")
`(code
,@(interleave (mapcar #'ls-compile sexps) ";
" *newline*)
";" ,*newline*))))
(defun ls-compile* (sexp &optional multiple-value-p)
(multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
(when expandedp
(return-from ls-compile* (ls-compile sexp multiple-value-p)))
;; The expression has been macroexpanded. Now compile it!
(let ((*multiple-value-p* multiple-value-p))
(cond
((symbolp sexp)
(let ((b (lookup-in-lexenv sexp *environment* 'variable)))
(cond
((and b (not (member 'special (binding-declarations b))))
(binding-value b))
((or (keywordp sexp)
(and b (member 'constant (binding-declarations b))))
`(code ,(ls-compile `',sexp) ".value"))
(t
(ls-compile `(symbol-value ',sexp))))))
((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
(literal sexp))
((listp sexp)
(let ((name (car sexp))
(args (cdr sexp)))
(cond
;; Special forms
((assoc name *compilations*)
(let ((comp (second (assoc name *compilations*))))
(apply comp args)))
;; Built-in functions
((and (assoc name *builtins*)
(not (claimp name 'function 'notinline)))
(let ((comp (second (assoc name *builtins*))))
(apply comp args)))
(t
(compile-funcall name args)))))
(t
(error "How should I compile `~S'?" sexp))))))
(defun ls-compile (sexp &optional multiple-value-p)
`(code "(" ,(ls-compile* sexp multiple-value-p) ")"))
(defvar *compile-print-toplevels* nil)
(defun truncate-string (string &optional (width 60))
(let ((n (or (position #\newline string)
(min width (length string)))))
(subseq string 0 n)))
(defun convert-toplevel (sexp &optional multiple-value-p)
(let ((*toplevel-compilations* nil))
(cond
;; Non-empty toplevel progn
((and (consp sexp)
(eq (car sexp) 'progn)
(cdr sexp))
`(progn
,@(mapcar (lambda (s) (convert-toplevel s t))
(cdr sexp))))
(t
(when *compile-print-toplevels*
(let ((form-string (prin1-to-string sexp)))
(format t "Compiling ~a..." (truncate-string form-string))))
(let ((code (ls-compile sexp multiple-value-p)))
`(code
,@(interleave (get-toplevel-compilations) ";
" t)
,(when code
`(code ,code ";"))))))))
(defun ls-compile-toplevel (sexp &optional multiple-value-p)
(with-output-to-string (*standard-output*)
(js (convert-toplevel sexp multiple-value-p))))