X-Git-Url: http://repo.macrolet.net/gitweb/?p=jscl.git;a=blobdiff_plain;f=jscl.lisp;h=19c5c54b9eb9c6d0321320f60ecefc8e4c971fbf;hp=c1a86586a6bd43dd3460fe877c8fe101f4298349;hb=HEAD;hpb=ad12426068874bb2e2f6ae5e1f567cb5b513713d diff --git a/jscl.lisp b/jscl.lisp index c1a8658..19c5c54 100644 --- a/jscl.lisp +++ b/jscl.lisp @@ -16,82 +16,177 @@ ;; You should have received a copy of the GNU General Public License ;; along with JSCL. If not, see . +(defpackage :jscl + (:use :cl) + (:export #:bootstrap #:run-tests-in-host)) + +(in-package :jscl) + +(defvar *version* "0.0.2") + +(defvar *base-directory* + (or #.*load-pathname* *default-pathname-defaults*)) + +;;; List of all the source files that need to be compiled, and whether they +;;; are to be compiled just by the host, by the target JSCL, or by both. +;;; All files have a `.lisp' extension, and +;;; are relative to src/ +;;; Subdirectories are indicated by the presence of a list rather than a +;;; keyword in the second element of the list. For example, this list: +;;; (("foo" :target) +;;; ("bar" +;;; ("baz" :host) +;;; ("quux" :both))) +;;; Means that src/foo.lisp and src/bar/quux.lisp need to be compiled in the +;;; target, and that src/bar/baz.lisp and src/bar/quux.lisp need to be +;;; compiled in the host (defvar *source* - '(("boot" :target) - ("compat" :host) - ("utils" :both) - ("list" :target) - ("print" :target) - ("package" :target) - ("read" :both) - ("compiler" :both) - ("toplevel" :target))) - -(defun source-pathname - (filename &key (directory '(:relative "src")) (type nil) (defaults filename)) - (if type - (make-pathname :type type :directory directory :defaults defaults) - (make-pathname :directory directory :defaults defaults))) + '(("boot" :target) + ("compat" :host) + ("setf" :target) + ("utils" :both) + ("numbers" :target) + ("char" :target) + ("list" :target) + ("array" :target) + ("string" :target) + ("sequence" :target) + ("stream" :target) + ("hash-table" :target) + ("print" :target) + ("documentation" :target) + ("misc" :target) + ("ffi" :target) + ("symbol" :target) + ("package" :target) + ("read" :both) + ("defstruct" :both) + ("lambda-list" :both) + ("backquote" :both) + ("compiler" + ("codegen" :both) + ("compiler" :both)) + ("toplevel" :target))) + +(defun get-files (file-list type dir) + "Traverse FILE-LIST and retrieve a list of the files within which match + either TYPE or :BOTH, processing subdirectories." + (let ((file (car file-list))) + (cond + ((null file-list) + ()) + ((listp (cadr file)) + (append + (get-files (cdr file) type (append dir (list (car file)))) + (get-files (cdr file-list) type dir))) + ((member (cadr file) (list type :both)) + (cons (source-pathname (car file) :directory dir :type "lisp") + (get-files (cdr file-list) type dir))) + (t + (get-files (cdr file-list) type dir))))) + +(defmacro do-source (name type &body body) + "Iterate over all the source files that need to be compiled in the host or + the target, depending on the TYPE argument." + (unless (member type '(:host :target)) + (error "TYPE must be one of :HOST or :TARGET, not ~S" type)) + `(dolist (,name (get-files *source* ,type '(:relative "src"))) + ,@body)) + +(defun source-pathname (filename &key (directory '(:relative "src")) (type nil) (defaults filename)) + (merge-pathnames + (if type + (make-pathname :type type :directory directory :defaults defaults) + (make-pathname :directory directory :defaults defaults)) + *base-directory*)) ;;; Compile jscl into the host (with-compilation-unit () - (dolist (input *source*) - (when (member (cadr input) '(:host :both)) - (let ((fname (source-pathname (car input)))) - (multiple-value-bind (fasl warn fail) (compile-file fname) - (declare (ignore fasl warn)) - (when fail - (error "Compilation of ~A failed." fname))))))) + (do-source input :host + (multiple-value-bind (fasl warn fail) (compile-file input) + (declare (ignore fasl warn)) + (when fail + (error "Compilation of ~A failed." input))))) ;;; Load jscl into the host -(dolist (input *source*) - (when (member (cadr input) '(:host :both)) - (load (source-pathname (car input))))) +(do-source input :host + (load input)) (defun read-whole-file (filename) - (with-open-file (in filename :external-format :latin-1) + (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) +(defun !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) + (format t "Compiling ~a...~%" (enough-namestring filename)) (loop with eof-mark = (gensym) for x = (ls-read in nil eof-mark) until (eq x eof-mark) - for compilation = (ls-compile-toplevel x) - when (plusp (length compilation)) - do (write-string compilation out))))) + do (let ((compilation (compile-toplevel x))) + (when (plusp (length compilation)) + (write-string compilation out))))))) + +(defun dump-global-environment (stream) + (flet ((late-compile (form) + (let ((*standard-output* stream)) + (write-string (compile-toplevel form))))) + ;; 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) + (setf (binding-value b) `(,*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 + (progn ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(string (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*))) + (late-compile `(setq *literal-counter* ,*literal-counter*)))) + (defun bootstrap () - (setq *environment* (make-lexenv)) - (setq *literal-table* nil) - (setq *variable-counter* 0 - *gensym-counter* 0 - *literal-counter* 0) - (with-open-file (out "jscl.js" :direction :output :if-exists :supersede) - (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)))) - ;; Tests - (with-open-file (out "tests.js" :direction :output :if-exists :supersede) - (dolist (input (append (directory "tests.lisp") - (directory "tests/*.lisp") - (directory "tests-report.lisp"))) - (ls-compile-file input out)))) + (let ((*features* (cons :jscl *features*)) + (*package* (find-package "JSCL"))) + (setq *environment* (make-lexenv)) + (setq *literal-table* nil) + (setq *variable-counter* 0 + *gensym-counter* 0 + *literal-counter* 0) + (with-open-file (out (merge-pathnames "jscl.js" *base-directory*) + :direction :output + :if-exists :supersede) + (write-string (read-whole-file (source-pathname "prelude.js")) out) + (do-source input :target + (!compile-file input out)) + (dump-global-environment out)) + ;; Tests + (with-open-file (out (merge-pathnames "tests.js" *base-directory*) + :direction :output + :if-exists :supersede) + (dolist (input (append (directory "tests.lisp") + (directory "tests/*.lisp") + (directory "tests-report.lisp"))) + (!compile-file input out))) + (report-undefined-functions))) ;;; Run the tests in the host Lisp implementation. It is a quick way ;;; to improve the level of trust of the tests. (defun run-tests-in-host () - (load "tests.lisp") - (let ((*use-html-output-p* nil)) - (dolist (input (directory "tests/*.lisp")) - (load input))) - (load "tests-report.lisp")) + (let ((*package* (find-package "JSCL"))) + (load "tests.lisp") + (let ((*use-html-output-p* nil)) + (declare (special *use-html-output-p*)) + (dolist (input (directory "tests/*.lisp")) + (load input))) + (load "tests-report.lisp")))