X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=04b1cb6092214c4f6e6a6c031d5af66f81b3ee1a;hb=14b62f94d79e1b3e5f1287296917c4a7cbbe1441;hp=30649d2cc736d724a6a0c1260e7009e8fa2ebcce;hpb=3eb2ddbf68c4e76bf771b3397c3c720128d0e2a2;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 30649d2..04b1cb6 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -36,30 +36,26 @@ args) ,@body)))))) - (defmacro %defvar (name value) + (defmacro defvar (name value) `(progn (eval-when-compile (%compile-defvar ',name)) - (setq ,name ,value))) - - (defmacro defvar (name &optional value) - `(%defvar ,name ,value)) + (setq ,name ,value) + ',name)) - (defmacro named-lambda (name args &rest body) + (defmacro named-lambda (name args &body body) (let ((x (gensym "FN"))) `(let ((,x (lambda ,args ,@body))) (oset ,x "fname" ,name) ,x))) - (defmacro %defun (name args &rest body) + (defmacro defun (name args &body body) `(progn (eval-when-compile (%compile-defun ',name)) (fsetq ,name (named-lambda ,(symbol-name name) ,args - (block ,name ,@body))))) - - (defmacro defun (name args &rest body) - `(%defun ,name ,args ,@body)) + (block ,name ,@body))) + ',name)) (defvar *package* (new)) @@ -226,10 +222,9 @@ (defmacro prog2 (form1 result &body body) `(prog1 (progn ,form1 ,result) ,@body)) + ) -) - ;;; This couple of helper functions will be defined in both Common ;;; Lisp and in Ecmalisp. (defun ensure-list (x) @@ -249,16 +244,6 @@ ;;; constructions. #+ecmalisp (progn - (defmacro defun (name args &body body) - `(progn - (%defun ,name ,args ,@body) - ',name)) - - (defmacro defvar (name &optional value) - `(progn - (%defvar ,name ,value) - ',name)) - (defun append-two (list1 list2) (if (null list1) list2 @@ -850,10 +835,7 @@ (defun ls-compile-block (sexps env) (join-trailing - (remove-if (lambda (x) - (or (null x) - (and (stringp x) - (zerop (length x))))) + (remove-if #'null (mapcar (lambda (x) (ls-compile x env)) sexps)) (concat ";" *newline*))) @@ -1049,7 +1031,7 @@ (define-compilation eval-when-compile (&rest body) (eval (cons 'progn body)) - "") + nil) (defmacro define-transformation (name args form) `(define-compilation ,name ,args @@ -1301,7 +1283,9 @@ (type-check (("x" "number" x)) "Math.floor(x)")) -(define-builtin cons (x y) (concat "({car: " x ", cdr: " y "})")) +(define-builtin cons (x y) + (concat "({car: " x ", cdr: " y "})")) + (define-builtin consp (x) (js!bool (js!selfcall @@ -1490,22 +1474,24 @@ (ls-compile (ls-macroexpand-1 sexp env) env) (compile-funcall (car sexp) (cdr sexp) env)))))) +(defun null-or-empty-p (x) + (zerop (length x))) + (defun ls-compile-toplevel (sexp) + (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*)))) + (let ((subs (mapcar #'ls-compile-toplevel (cdr sexp)))) + (join (remove-if #'null-or-empty-p subs)))) (t - (setq *toplevel-compilations* nil) (let ((code (ls-compile sexp))) (prog1 - (concat (join-trailing *toplevel-compilations* - (concat ";" *newline*)) - code) - (setq *toplevel-compilations* nil)))))) + (concat (join-trailing (remove-if #'null-or-empty-p *toplevel-compilations*) + (concat ";" *newline*)) + (if code + (concat code ";" *newline*) + "")) + (setq *toplevel-compilations* nil)))))) ;;; Once we have the compiler, we define the runtime environment and @@ -1529,32 +1515,37 @@ (ls-compile-toplevel x)))) (js-eval code))) + (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)))) + ;; Set the initial global environment to be equal to the host global ;; environment at this point of the compilation. (eval-when-compile (let ((tmp (ls-compile `(progn - (setq *environment* ',*environment*) - (setq *variable-counter* ',*variable-counter*) - (setq *function-counter* ',*function-counter*) - (setq *literal-counter* ',*literal-counter*) - (setq *gensym-counter* ',*gensym-counter*) - (setq *block-counter* ',*block-counter*) ,@(mapcar (lambda (s) `(oset *package* ,(symbol-name (car s)) (js-vref ,(cdr s)))) - *literal-symbols*))))) + *literal-symbols*) + (setq *environment* ',*environment*) + (setq *variable-counter* ,*variable-counter*) + (setq *function-counter* ,*function-counter*) + (setq *gensym-counter* ,*gensym-counter*) + (setq *block-counter* ,*block-counter*))))) (setq *toplevel-compilations* (append *toplevel-compilations* (list tmp))))) - - (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))))) + ;; KLUDGE: + (eval-when-compile + (let ((tmp (ls-compile + `(setq *literal-counter* ,*literal-counter*)))) + (setq *toplevel-compilations* + (append *toplevel-compilations* (list tmp)))))) ;;; Finally, we provide a couple of functions to easily bootstrap @@ -1578,7 +1569,7 @@ until (eq x *eof*) for compilation = (ls-compile-toplevel x) when (plusp (length compilation)) - do (write-line (concat compilation "; ") out)) + do (write-string compilation out)) (dolist (check *compilation-unit-checks*) (funcall check)) (setq *compilation-unit-checks* nil))))