Merge branch 'master' of https://github.com/davazp/jscl
[jscl.git] / jscl.lisp
1 ;;; jscl.lisp ---
2
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
6 ;; This program 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.
10 ;;
11 ;; This program 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.
15 ;;
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
18
19 (defvar *source*
20   '(("boot"      :target)
21     ("compat"    :host)
22     ("utils"     :both)
23     ("print"     :target)
24     ("read"      :both)
25     ("compiler"  :both)
26     ("list"      :target)
27     ("toplevel"  :target)))
28
29 (defun source-pathname
30     (filename &key (directory '(:relative "src")) (type nil) (defaults filename))
31   (if type
32       (make-pathname :type type :directory directory :defaults defaults)
33       (make-pathname            :directory directory :defaults defaults)))
34
35 ;;; Compile jscl into the host
36 (with-compilation-unit ()
37   (dolist (input *source*)
38     (when (member (cadr input) '(:host :both))
39       (let ((fname (source-pathname (car input))))
40         (multiple-value-bind (fasl warn fail) (compile-file fname)
41           (declare (ignore fasl warn))
42           (when fail
43             (error "Compilation of ~A failed." fname)))))))
44
45 ;;; Load jscl into the host
46 (dolist (input *source*)
47   (when (member (cadr input) '(:host :both))
48     (load (source-pathname (car input)))))
49
50 (defun read-whole-file (filename)
51   (with-open-file (in filename :external-format :latin-1)
52     (let ((seq (make-array (file-length in) :element-type 'character)))
53       (read-sequence seq in)
54       seq)))
55
56 (defun ls-compile-file (filename out &key print)
57   (let ((*compiling-file* t)
58         (*compile-print-toplevels* print))
59     (let* ((source (read-whole-file filename))
60            (in (make-string-stream source)))
61       (format t "Compiling ~a...~%" filename)
62       (loop
63          with eof-mark = (gensym)
64          for x = (ls-read in nil eof-mark)
65          until (eq x eof-mark)
66          for compilation = (ls-compile-toplevel x)
67          when (plusp (length compilation))
68          do (write-string compilation out)))))
69
70 (defun bootstrap ()
71   (setq *environment* (make-lexenv))
72   (setq *literal-table* nil)
73   (setq *variable-counter* 0
74         *gensym-counter* 0
75         *literal-counter* 0
76         *block-counter* 0)
77   (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
78     (write-string (read-whole-file (source-pathname "prelude.js")) out)
79     (dolist (input *source*)
80       (when (member (cadr input) '(:target :both))
81         (ls-compile-file (source-pathname (car input) :type "lisp") out))))
82   ;; Tests
83   (with-open-file (out "tests.js" :direction :output :if-exists :supersede)
84     (dolist (input (append (directory "tests.lisp")
85                            (directory "tests/*.lisp")
86                            (directory "tests-report.lisp"))) 
87       (ls-compile-file input out))))
88
89
90 ;;; Run the tests in the host Lisp implementation. It is a quick way
91 ;;; to improve the level of trust of the tests.
92 (defun run-tests-in-host ()
93   (dolist (input (append (directory "tests.lisp")
94                          (directory "tests/*.lisp")
95                          (directory "tests-report.lisp")))
96     (load input)))