X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=04b1cb6092214c4f6e6a6c031d5af66f81b3ee1a;hb=14b62f94d79e1b3e5f1287296917c4a7cbbe1441;hp=5efc3e1113e6e6aa212ce3497947c4dc527a1806;hpb=9faab964accf5bbe9d7d8e843bc5e5dc390c7074;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 5efc3e1..04b1cb6 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -36,38 +36,31 @@ 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)) - (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)) @@ -229,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) @@ -252,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 @@ -473,9 +455,6 @@ (defmacro concatf (variable &body form) `(setq ,variable (concat ,variable (progn ,@form)))) -(defun mapconcat (func list) - (join (mapcar func list))) - ;;; Concatenate a list of strings, with a separator (defun join (list &optional (separator "")) (cond @@ -493,6 +472,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 @@ -854,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*))) @@ -1012,12 +990,18 @@ ((integerp sexp) (integer-to-string sexp)) ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) ((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))) + 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) "}"))) @@ -1027,17 +1011,9 @@ (push (concat "var " v " = " c) *toplevel-compilations*) v)))))) -#+common-lisp (define-compilation quote (sexp) (literal sexp)) -#+ecmalisp -(define-compilation quote (sexp) - (let ((v (genlit))) - (push (ls-compile `(js-vset ,v ,sexp) env) - *toplevel-compilations*) - v)) - (define-compilation %while (pred &rest body) (js!selfcall @@ -1055,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 @@ -1307,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 @@ -1485,7 +1463,7 @@ (lexical-variable (binding-translation b)) (special-variable - (ls-compile `(symbol-value ',sexp) env))))) + (ls-compile `(symbol-value ',sexp) env))))) ((integerp sexp) (integer-to-string sexp)) ((stringp sexp) (concat "\"" (escape-string sexp) "\"")) ((listp sexp) @@ -1496,18 +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)) - (mapconcat 'ls-compile-toplevel (cdr sexp))) + (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 (mapcar (lambda (x) (concat x ";" *newline*)) - *toplevel-compilations*)) - 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 @@ -1531,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 @@ -1580,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))))