From: David Vázquez Date: Thu, 25 Apr 2013 12:34:15 +0000 (+0100) Subject: Move eval and cl-user package code to toplevel.lisp X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e1d0d10f178f343fb9fed572794336159a81a1a6;p=jscl.git Move eval and cl-user package code to toplevel.lisp --- diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 95c8918..b412d21 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -16,7 +16,6 @@ ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . -#+common-lisp (eval-when (:load-toplevel :compile-toplevel :execute) (load "compat") (load "utils") @@ -24,140 +23,38 @@ (load "read") (load "compiler")) -;;; Once we have the compiler, we define the runtime environment and -;;; interactive development (eval), which works calling the compiler -;;; and evaluating the Javascript result globally. - -#+ecmalisp -(progn - (defun eval (x) - (js-eval (ls-compile-toplevel x t))) - - (defvar * nil) - (defvar ** nil) - (defvar *** nil) - (defvar / nil) - (defvar // nil) - (defvar /// nil) - (defvar + nil) - (defvar ++ nil) - (defvar +++ nil) - (defvar - nil) - - (defun eval-interactive (x) - (setf - x) - (let ((results (multiple-value-list (eval x)))) - (setf /// // - // / - / results - *** ** - ** * - * (car results))) - (setf +++ ++ - ++ + - + -) - (values-list /)) - - (export '(&body &key &optional &rest * *gensym-counter* *package* + - / 1+ 1- < - <= = = > >= and append apply aref arrayp assoc atom block - boundp boundp butlast caar cadddr caddr cadr car car case - catch cdar cdddr cddr cdr cdr char char-code char= - code-char cond cons consp constantly copy-list decf - declaim defconstant define-setf-expander - define-symbol-macro defmacro defparameter defun defvar - digit-char digit-char-p disassemble do do* documentation - dolist dotimes ecase eq eql equal error eval every export - fdefinition find-package find-symbol first flet fourth - fset funcall function functionp gensym get-setf-expansion - get-universal-time go identity if in-package incf integerp - integerp intern keywordp labels lambda last length let - let* list list* list-all-packages listp loop make-array - make-package make-symbol mapcar member minusp mod - multiple-value-bind multiple-value-call - multiple-value-list multiple-value-prog1 nconc nil not - nreconc nth nthcdr null numberp or package-name - package-use-list packagep parse-integer plusp - prin1-to-string print proclaim prog1 prog2 progn psetq - push quote remove remove-if remove-if-not return - return-from revappend reverse rplaca rplacd second set - setf setq some string string-upcase string= stringp subseq - symbol-function symbol-name symbol-package symbol-plist - symbol-value symbolp t tagbody third throw truncate unless - unwind-protect values values-list variable warn when - write-line write-string zerop ** *** // /// ++ +++)) - - (setq *package* *user-package*) - - (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" (lambda (s) (ls-compile-toplevel s t))) - (%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)))) - *literal-symbols*) - (setq *literal-symbols* ',*literal-symbols*) - (setq *variable-counter* ,*variable-counter*) - (setq *gensym-counter* ,*gensym-counter*) - (setq *block-counter* ,*block-counter*))))) - - (eval-when-compile - (toplevel-compilation - (ls-compile - `(setq *literal-counter* ,*literal-counter*))))) - - -;;; Finally, we provide a couple of functions to easily bootstrap -;;; this. It just calls the compiler with this file as input. - -#+common-lisp -(progn - (defun read-whole-file (filename) - (with-open-file (in filename) - (let ((seq (make-array (file-length in) :element-type 'character))) - (read-sequence seq in) - seq))) - - (defun ls-compile-file (filename out &key print) - (let ((*compiling-file* t) - (*compile-print-toplevels* print)) - (let* ((source (read-whole-file filename)) - (in (make-string-stream source))) - (format t "Compiling ~a...~%" filename) - (loop - for x = (ls-read in) - until (eq x *eof*) - for compilation = (ls-compile-toplevel x) - when (plusp (length compilation)) - do (write-string compilation out))))) - - (defun bootstrap () - (setq *environment* (make-lexenv)) - (setq *literal-symbols* nil) - (setq *variable-counter* 0 - *gensym-counter* 0 - *literal-counter* 0 - *block-counter* 0) - (with-open-file (out "ecmalisp.js" :direction :output :if-exists :supersede) - (write-string (read-whole-file "prelude.js") out) - (dolist (file '("boot.lisp" - "utils.lisp" - "print.lisp" - "read.lisp" - "compiler.lisp" - "ecmalisp.lisp")) - (ls-compile-file file out))))) +(defun read-whole-file (filename) + (with-open-file (in filename) + (let ((seq (make-array (file-length in) :element-type 'character))) + (read-sequence seq in) + seq))) + +(defun ls-compile-file (filename out &key print) + (let ((*compiling-file* t) + (*compile-print-toplevels* print)) + (let* ((source (read-whole-file filename)) + (in (make-string-stream source))) + (format t "Compiling ~a...~%" filename) + (loop + for x = (ls-read in) + until (eq x *eof*) + for compilation = (ls-compile-toplevel x) + when (plusp (length compilation)) + do (write-string compilation out))))) + +(defun bootstrap () + (setq *environment* (make-lexenv)) + (setq *literal-symbols* nil) + (setq *variable-counter* 0 + *gensym-counter* 0 + *literal-counter* 0 + *block-counter* 0) + (with-open-file (out "ecmalisp.js" :direction :output :if-exists :supersede) + (write-string (read-whole-file "prelude.js") out) + (dolist (file '("boot.lisp" + "utils.lisp" + "print.lisp" + "read.lisp" + "compiler.lisp" + "toplevel.lisp")) + (ls-compile-file file out)))) diff --git a/toplevel.lisp b/toplevel.lisp new file mode 100644 index 0000000..6f1332e --- /dev/null +++ b/toplevel.lisp @@ -0,0 +1,89 @@ +(defun eval (x) + (js-eval (ls-compile-toplevel x t))) + +(defvar * nil) +(defvar ** nil) +(defvar *** nil) +(defvar / nil) +(defvar // nil) +(defvar /// nil) +(defvar + nil) +(defvar ++ nil) +(defvar +++ nil) +(defvar - nil) + +(defun eval-interactive (x) + (setf - x) + (let ((results (multiple-value-list (eval x)))) + (setf /// // + // / + / results + *** ** + ** * + * (car results))) + (setf +++ ++ + ++ + + + -) + (values-list /)) + +(export '(&body &key &optional &rest * *gensym-counter* *package* + - / 1+ 1- < + <= = = > >= and append apply aref arrayp assoc atom block + boundp boundp butlast caar cadddr caddr cadr car car case + catch cdar cdddr cddr cdr cdr char char-code char= + code-char cond cons consp constantly copy-list decf + declaim defconstant define-setf-expander + define-symbol-macro defmacro defparameter defun defvar + digit-char digit-char-p disassemble do do* documentation + dolist dotimes ecase eq eql equal error eval every export + fdefinition find-package find-symbol first flet fourth + fset funcall function functionp gensym get-setf-expansion + get-universal-time go identity if in-package incf integerp + integerp intern keywordp labels lambda last length let + let* list list* list-all-packages listp loop make-array + make-package make-symbol mapcar member minusp mod + multiple-value-bind multiple-value-call + multiple-value-list multiple-value-prog1 nconc nil not + nreconc nth nthcdr null numberp or package-name + package-use-list packagep parse-integer plusp + prin1-to-string print proclaim prog1 prog2 progn psetq + push quote remove remove-if remove-if-not return + return-from revappend reverse rplaca rplacd second set + setf setq some string string-upcase string= stringp subseq + symbol-function symbol-name symbol-package symbol-plist + symbol-value symbolp t tagbody third throw truncate unless + unwind-protect values values-list variable warn when + write-line write-string zerop ** *** // /// ++ +++)) + +(setq *package* *user-package*) + +(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" (lambda (s) (ls-compile-toplevel s t))) +(%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)))) + *literal-symbols*) + (setq *literal-symbols* ',*literal-symbols*) + (setq *variable-counter* ,*variable-counter*) + (setq *gensym-counter* ,*gensym-counter*) + (setq *block-counter* ,*block-counter*))))) + +(eval-when-compile + (toplevel-compilation + (ls-compile + `(setq *literal-counter* ,*literal-counter*))))