X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=30649d2cc736d724a6a0c1260e7009e8fa2ebcce;hb=3eb2ddbf68c4e76bf771b3397c3c720128d0e2a2;hp=1f03e046361725e0ee888dd573eb16c79cdf1d58;hpb=3192a89026cef55a8ece5b45887da9be51ea976d;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 1f03e04..30649d2 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -21,6 +21,7 @@ ;;; as well as funcalls and macroexpansion, but no functions. So, we ;;; define the Lisp world from scratch. This code has to define enough ;;; language to the compiler to be able to run. + #+ecmalisp (progn (eval-when-compile @@ -28,7 +29,7 @@ '(lambda (name args &rest body) `(eval-when-compile (%compile-defmacro ',name - '(lambda ,(mapcar (lambda (x) + '(lambda ,(mapcar (lambda (x) (if (eq x '&body) '&rest x)) @@ -62,11 +63,8 @@ (defvar *package* (new)) - (defvar nil (make-symbol "NIL")) - (oset *package* "NIL" nil) - - (defvar t (make-symbol "T")) - (oset *package* "T" t) + (defvar nil 'nil) + (defvar t 't) (defun null (x) (eq x nil)) @@ -489,6 +487,8 @@ "" (concat (car list) separator (join-trailing (cdr list) separator)))) +(defun mapconcat (func list) + (join (mapcar func list))) ;;; Like CONCAT, but prefix each line with four spaces. Two versions ;;; of this function are available, because the Ecmalisp version is @@ -792,7 +792,7 @@ (or (lookup-in-lexenv symbol env 'variable) (lookup-in-lexenv symbol *environment* 'variable) (let ((name (symbol-name symbol)) - (binding (make-binding symbol 'variable (gvarname symbol) nil))) + (binding (make-binding symbol 'special-variable (gvarname symbol) nil))) (push-to-lexenv binding *environment* 'variable) (push (lambda () (let ((b (lookup-in-lexenv symbol *environment* 'variable))) @@ -807,7 +807,7 @@ (defun extend-local-env (args env) (let ((new (copy-lexenv env))) (dolist (symbol args new) - (let ((b (make-binding symbol 'variable (gvarname symbol) t))) + (let ((b (make-binding symbol 'lexical-variable (gvarname symbol) t))) (push-to-lexenv b new 'variable))))) (defvar *function-counter* 0) @@ -968,9 +968,16 @@ (ls-compile val env))) (define-compilation setq (var val) - (concat (lookup-variable-translation var env) - " = " - (ls-compile val env))) + (let ((b (lookup-variable var env))) + (ecase (binding-type b) + (lexical-variable (concat (binding-translation b) " = " (ls-compile val env))) + (special-variable (ls-compile `(set ',var ,val) env))))) + +;;; FFI Variable accessors +(define-compilation js-vref (var) + var) +(define-compilation js-vset (var val) + (concat "(" var " = " (ls-compile val env) ")")) ;;; Literals @@ -989,25 +996,43 @@ (incf index)) output)) -(defun literal->js (sexp) + +(defvar *literal-symbols* nil) +(defvar *literal-counter* 0) + +(defun genlit () + (concat "l" (integer-to-string (incf *literal-counter*)))) + +(defun literal (sexp &optional recursive) (cond ((integerp sexp) (integer-to-string sexp)) ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) - ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *environment*)) - ((consp sexp) (concat "{car: " - (literal->js (car sexp)) - ", cdr: " - (literal->js (cdr sexp)) "}")))) - -(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)) + ((symbolp sexp) + #+common-lisp + (or (cdr (assoc sexp *literal-symbols*)) + (let ((v (genlit)) + (s (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}"))) + (push (cons sexp v) *literal-symbols*) + (push (concat "var " v " = " s) *toplevel-compilations*) + v)) + #+ecmalisp + (let ((v (genlit))) + (push (concat "var " v " = " (ls-compile `(intern ,(symbol-name sexp)))) + *toplevel-compilations*) + v)) + ((consp sexp) + (let ((c (concat "{car: " (literal (car sexp) t) ", " + "cdr: " (literal (cdr sexp) t) "}"))) + (if recursive + c + (let ((v (genlit))) + (push (concat "var " v " = " c) *toplevel-compilations*) + v)))))) (define-compilation quote (sexp) (literal sexp)) + (define-compilation %while (pred &rest body) (js!selfcall "while(" (ls-compile pred env) " !== " (ls-compile nil) "){" *newline* @@ -1448,7 +1473,13 @@ (defun ls-compile (sexp &optional (env (make-lexenv))) (cond - ((symbolp sexp) (lookup-variable-translation sexp env)) + ((symbolp sexp) + (let ((b (lookup-variable sexp env))) + (ecase (binding-type b) + (lexical-variable + (binding-translation b)) + (special-variable + (ls-compile `(symbol-value ',sexp) env))))) ((integerp sexp) (integer-to-string sexp)) ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) ((listp sexp) @@ -1460,13 +1491,21 @@ (compile-funcall (car sexp) (cdr sexp) env)))))) (defun ls-compile-toplevel (sexp) - (setq *toplevel-compilations* nil) - (let ((code (ls-compile sexp))) - (prog1 - (concat (join (mapcar (lambda (x) (concat x ";" *newline*)) - *toplevel-compilations*)) - code) - (setq *toplevel-compilations* nil)))) + (cond + ((and (consp sexp) (eq (car sexp) 'progn)) + (let ((subs (mapcar 'ls-compile-toplevel (cdr sexp)))) + (join-trailing + (remove-if (lambda (s) (or (null s) (equal s ""))) + subs) + (concat ";" *newline*)))) + (t + (setq *toplevel-compilations* nil) + (let ((code (ls-compile sexp))) + (prog1 + (concat (join-trailing *toplevel-compilations* + (concat ";" *newline*)) + code) + (setq *toplevel-compilations* nil)))))) ;;; Once we have the compiler, we define the runtime environment and @@ -1500,22 +1539,22 @@ (setq *function-counter* ',*function-counter*) (setq *literal-counter* ',*literal-counter*) (setq *gensym-counter* ',*gensym-counter*) - (setq *block-counter* ',*block-counter*))))) + (setq *block-counter* ',*block-counter*) + ,@(mapcar (lambda (s) + `(oset *package* ,(symbol-name (car s)) + (js-vref ,(cdr s)))) + *literal-symbols*))))) (setq *toplevel-compilations* (append *toplevel-compilations* (list tmp))))) - (js-eval - (concat "var lisp = {};" - "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline* - "lisp.print = " (lookup-function-translation 'prin1-to-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*))) + (js-eval "var lisp") + (js-vset "lisp" (new)) + (js-vset "lisp.read" #'ls-read-from-string) + (js-vset "lisp.print" #'prin1-to-string) + (js-vset "lisp.eval" #'eval) + (js-vset "lisp.compile" #'ls-compile-toplevel) + (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str)))) + (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str))))) ;;; Finally, we provide a couple of functions to easily bootstrap @@ -1546,6 +1585,7 @@ (defun bootstrap () (setq *environment* (make-lexenv)) + (setq *literal-symbols* nil) (setq *variable-counter* 0 *gensym-counter* 0 *function-counter* 0