3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
6 ;; JSCL is free software: you can redistribute it and/or
7 ;; modify it under the terms of the GNU General Public License as
8 ;; published by the Free Software Foundation, either version 3 of the
9 ;; License, or (at your option) any later version.
11 ;; JSCL is distributed in the hope that it will be useful, but
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;; General Public License for more details.
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
21 (:export #:bootstrap #:run-tests-in-host))
25 ;;; List of all the source files that need to be compiled, and whether they
26 ;;; are to be compiled just by the host, by the target JSCL, or by both.
27 ;;; All files have a `.lisp' extension, and
28 ;;; are relative to src/
29 ;;; Subdirectories are indicated by the presence of a list rather than a
30 ;;; keyword in the second element of the list. For example, this list:
35 ;;; Means that src/foo.lisp and src/bar/quux.lisp need to be compiled in the
36 ;;; target, and that src/bar/baz.lisp and src/bar/quux.lisp need to be
37 ;;; compiled in the host
60 ("toplevel" :target)))
62 (defun get-files (file-list type dir)
63 "Traverse FILE-LIST and retrieve a list of the files within which match
64 either TYPE or :BOTH, processing subdirectories."
65 (let ((file (car file-list)))
71 (get-files (cdr file) type (append dir (list (car file))))
72 (get-files (cdr file-list) type dir)))
73 ((member (cadr file) (list type :both))
74 (cons (source-pathname (car file) :directory dir :type "lisp")
75 (get-files (cdr file-list) type dir)))
77 (get-files (cdr file-list) type dir)))))
79 (defmacro do-source (name type &body body)
80 "Iterate over all the source files that need to be compiled in the host or
81 the target, depending on the TYPE argument."
82 (unless (member type '(:host :target))
83 (error "TYPE must be one of :HOST or :TARGET, not ~S" type))
84 `(dolist (,name (get-files *source* ,type '(:relative "src")))
87 (defun source-pathname
88 (filename &key (directory '(:relative "src")) (type nil) (defaults filename))
90 (make-pathname :type type :directory directory :defaults defaults)
91 (make-pathname :directory directory :defaults defaults)))
93 ;;; Compile jscl into the host
94 (with-compilation-unit ()
95 (do-source input :host
96 (multiple-value-bind (fasl warn fail) (compile-file input)
97 (declare (ignore fasl warn))
99 (error "Compilation of ~A failed." input)))))
101 ;;; Load jscl into the host
102 (do-source input :host
105 (defun read-whole-file (filename)
106 (with-open-file (in filename)
107 (let ((seq (make-array (file-length in) :element-type 'character)))
108 (read-sequence seq in)
111 (defun !compile-file (filename out &key print)
112 (let ((*compiling-file* t)
113 (*compile-print-toplevels* print))
114 (let* ((source (read-whole-file filename))
115 (in (make-string-stream source)))
116 (format t "Compiling ~a...~%" filename)
118 with eof-mark = (gensym)
119 for x = (ls-read in nil eof-mark)
120 until (eq x eof-mark)
121 do (let ((compilation (compile-toplevel x)))
122 (when (plusp (length compilation))
123 (write-string compilation out)))))))
125 (defun dump-global-environment (stream)
126 (flet ((late-compile (form)
127 (let ((*standard-output* stream))
128 (write-string (compile-toplevel form)))))
129 ;; We assume that environments have a friendly list representation
130 ;; for the compiler and it can be dumped.
131 (dolist (b (lexenv-function *environment*))
132 (when (eq (binding-type b) 'macro)
133 (setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))
134 (late-compile `(setq *environment* ',*environment*))
135 ;; Set some counter variable properly, so user compiled code will
136 ;; not collide with the compiler itself.
139 (progn ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(string (cdr s)))))
140 (remove-if-not #'symbolp *literal-table* :key #'car)))
141 (setq *literal-table* ',*literal-table*)
142 (setq *variable-counter* ,*variable-counter*)
143 (setq *gensym-counter* ,*gensym-counter*)))
144 (late-compile `(setq *literal-counter* ,*literal-counter*))))
148 (let ((*features* (cons :jscl *features*))
149 (*package* (find-package "JSCL")))
150 (setq *environment* (make-lexenv))
151 (setq *literal-table* nil)
152 (setq *variable-counter* 0
155 (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
156 (write-string (read-whole-file (source-pathname "prelude.js")) out)
157 (do-source input :target
158 (!compile-file input out))
159 (dump-global-environment out))
161 (with-open-file (out "tests.js" :direction :output :if-exists :supersede)
162 (dolist (input (append (directory "tests.lisp")
163 (directory "tests/*.lisp")
164 (directory "tests-report.lisp")))
165 (!compile-file input out)))))
168 ;;; Run the tests in the host Lisp implementation. It is a quick way
169 ;;; to improve the level of trust of the tests.
170 (defun run-tests-in-host ()
171 (let ((*package* (find-package "JSCL")))
173 (let ((*use-html-output-p* nil))
174 (declare (special *use-html-output-p*))
175 (dolist (input (directory "tests/*.lisp"))
177 (load "tests-report.lisp")))