when (plusp (length compilation))
do (write-string compilation out)))))
+
+(defun dump-global-environment (stream)
+ (flet ((late-compile (form)
+ (write-string (ls-compile-toplevel form) stream)))
+ ;; We assume that environments have a friendly list representation
+ ;; for the compiler and it can be dumped.
+ (dolist (b (lexenv-function *environment*))
+ (when (eq (binding-type b) 'macro)
+ (push *magic-unquote-marker* (binding-value b))))
+ (late-compile `(setq *environment* ',*environment*))
+ ;; Set some counter variable properly, so user compiled code will
+ ;; not collide with the compiler itself.
+ (late-compile
+ `(progn
+ ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s)))) *literal-table*)
+ (setq *literal-table* ',*literal-table*)
+ (setq *variable-counter* ,*variable-counter*)
+ (setq *gensym-counter* ,*gensym-counter*)))
+ (late-compile `(setq *literal-counter* ,*literal-counter*))))
+
+
(defun bootstrap ()
(setq *environment* (make-lexenv))
(setq *literal-table* nil)
(write-string (read-whole-file (source-pathname "prelude.js")) out)
(dolist (input *source*)
(when (member (cadr input) '(:target :both))
- (ls-compile-file (source-pathname (car input) :type "lisp") out))))
+ (ls-compile-file (source-pathname (car input) :type "lisp") out)))
+ (dump-global-environment out))
;; Tests
(with-open-file (out "tests.js" :direction :output :if-exists :supersede)
(dolist (input (append (directory "tests.lisp")
(code "(" result ")")))
-;;; Literals
+;;; Compilation of literals an object dumping
+
(defun escape-string (string)
(let ((output "")
(index 0)
(incf index))
output))
-
(defvar *literal-table* nil)
(defvar *literal-counter* 0)
+;;; BOOTSTRAP MAGIC: During bootstrap, we record the macro definitions
+;;; as lists. Once everything is compiled, we want to dump the whole
+;;; global environment to the output file to reproduce it in the
+;;; run-time. However, the environment must contain expander functions
+;;; rather than lists. We do not know how to dump function objects
+;;; itself, so we mark the definitions with this object and the
+;;; compiler will be called when this object has to be dumped.
+;;; Backquote/unquote does a similar magic, but this use is exclusive.
+(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
+
(defun genlit ()
(code "l" (incf *literal-counter*)))
(or (cdr (assoc sexp *literal-table* :test #'equal))
(let ((dumped (typecase sexp
(symbol (dump-symbol sexp))
- (cons (dump-cons sexp))
(string (dump-string sexp))
+ (cons
+ (if (eq (car sexp) *magic-unquote-marker*)
+ (ls-compile (cdr sexp))
+ (dump-cons sexp)))
(array (dump-array sexp)))))
(if (and recursive (not (symbolp sexp)))
dumped
(toplevel-compilation (code "var " jsvar " = " dumped))
jsvar)))))))
+
(define-compilation quote (sexp)
(literal sexp))
(define-builtin %js-call (fun args)
(code fun ".apply(this, " args ")"))
-(defun macro (x)
- (and (symbolp x)
- (let ((b (lookup-in-lexenv x *environment* 'function)))
- (if (and b (eq (binding-type b) 'macro))
- b
- nil))))
-
#+common-lisp
(defvar *macroexpander-cache*
(make-hash-table :test #'eq))
-(defun ls-macroexpand-1 (form)
+(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
+ #+common-lisp
+ ((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)
+ #+common-lisp (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)))
(values (binding-value b) t)
(values form nil))))
((consp form)
- (let ((macro-binding (macro (car form))))
- (if macro-binding
- (let ((expander (binding-value macro-binding)))
- (cond
- #+common-lisp
- ((gethash macro-binding *macroexpander-cache*)
- (setq expander (gethash macro-binding *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 macro-binding) compiled)
- #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
- (setq expander compiled))))
- (values (apply expander (cdr form)) t))
+ (let ((macrofun (!macro-function (car form))))
+ (if macrofun
+ (values (apply macrofun (cdr form)) t)
(values form nil))))
(t
(values form nil))))
(concat ";" *newline*))))
(defun ls-compile (sexp &optional multiple-value-p)
- (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
+ (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!
(setq *package* *user-package*)
+;;; Set some external entry point to the Lisp implementation to the
+;;; console. It would not be necessary when FFI is finished.
(js-eval "var lisp")
(%js-vset "lisp" (new))
(%js-vset "lisp.read" #'ls-read-from-string)
(%js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
(%js-vset "lisp.evalInput" (lambda (str) (eval-interactive (ls-read-from-string str))))
(%js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))
-
-;; Set the initial global environment to be equal to the host global
-;; environment at this point of the compilation.
-(eval-when-compile
- (toplevel-compilation
- (ls-compile `(setq *environment* ',*environment*))))
-
-(eval-when-compile
- (toplevel-compilation
- (ls-compile
- `(progn
- ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
- (remove-if-not #'symbolp *literal-table* :key #'car))
- (setq *literal-table* ',*literal-table*)
- (setq *variable-counter* ,*variable-counter*)
- (setq *gensym-counter* ,*gensym-counter*)))))
-
-(eval-when-compile
- (toplevel-compilation
- (ls-compile
- `(setq *literal-counter* ,*literal-counter*))))
projects / jscl.git / commitdiff