INTERSECTION
[jscl.git] / jscl.lisp
1 ;;; jscl.lisp ---
2
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
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.
10 ;;
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.
15 ;;
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/>.
18
19 (defvar *source*
20   '(("boot"      :target)
21     ("compat"    :host)
22     ("utils"     :both)
23     ("list"      :target)
24     ("string"    :target)
25     ("print"     :target)
26     ("package"   :target)
27     ("ffi"       :target)
28     ("read"      :both)
29     ("compiler"  :both)
30     ("toplevel"  :target)))
31
32 (defun source-pathname
33     (filename &key (directory '(:relative "src")) (type nil) (defaults filename))
34   (if type
35       (make-pathname :type type :directory directory :defaults defaults)
36       (make-pathname            :directory directory :defaults defaults)))
37
38 ;;; Compile jscl into the host
39 (with-compilation-unit ()
40   (dolist (input *source*)
41     (when (member (cadr input) '(:host :both))
42       (let ((fname (source-pathname (car input))))
43         (multiple-value-bind (fasl warn fail) (compile-file fname)
44           (declare (ignore fasl warn))
45           (when fail
46             (error "Compilation of ~A failed." fname)))))))
47
48 ;;; Load jscl into the host
49 (dolist (input *source*)
50   (when (member (cadr input) '(:host :both))
51     (load (source-pathname (car input)))))
52
53 (defun read-whole-file (filename)
54   (with-open-file (in filename :external-format :latin-1)
55     (let ((seq (make-array (file-length in) :element-type 'character)))
56       (read-sequence seq in)
57       seq)))
58
59 (defun ls-compile-file (filename out &key print)
60   (let ((*compiling-file* t)
61         (*compile-print-toplevels* print))
62     (let* ((source (read-whole-file filename))
63            (in (make-string-stream source)))
64       (format t "Compiling ~a...~%" filename)
65       (loop
66          with eof-mark = (gensym)
67          for x = (ls-read in nil eof-mark)
68          until (eq x eof-mark)
69          for compilation = (ls-compile-toplevel x)
70          when (plusp (length compilation))
71          do (write-string compilation out)))))
72
73
74 (defun dump-global-environment (stream)
75   (flet ((late-compile (form)
76            (write-string (ls-compile-toplevel form) stream)))
77     ;; We assume that environments have a friendly list representation
78     ;; for the compiler and it can be dumped.
79     (dolist (b (lexenv-function *environment*))
80       (when (eq (binding-type b) 'macro)
81         (push *magic-unquote-marker* (binding-value b))))
82     (late-compile `(setq *environment* ',*environment*))
83     ;; Set some counter variable properly, so user compiled code will
84     ;; not collide with the compiler itself.
85     (late-compile
86      `(progn
87         ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
88                   (remove-if-not #'symbolp *literal-table* :key #'car))
89         (setq *literal-table* ',*literal-table*)
90         (setq *variable-counter* ,*variable-counter*)
91         (setq *gensym-counter* ,*gensym-counter*)))
92     (late-compile `(setq *literal-counter* ,*literal-counter*))))
93
94
95 (defun bootstrap ()
96   (setq *environment* (make-lexenv))
97   (setq *literal-table* nil)
98   (setq *variable-counter* 0
99         *gensym-counter* 0
100         *literal-counter* 0)
101   (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
102     (write-string (read-whole-file (source-pathname "prelude.js")) out)
103     (dolist (input *source*)
104       (when (member (cadr input) '(:target :both))
105         (ls-compile-file (source-pathname (car input) :type "lisp") out)))
106     (dump-global-environment out))
107   ;; Tests
108   (with-open-file (out "tests.js" :direction :output :if-exists :supersede)
109     (dolist (input (append (directory "tests.lisp")
110                            (directory "tests/*.lisp")
111                            (directory "tests-report.lisp")))
112       (ls-compile-file input out))))
113
114
115 ;;; Run the tests in the host Lisp implementation. It is a quick way
116 ;;; to improve the level of trust of the tests.
117 (defun run-tests-in-host ()
118   (load "tests.lisp")
119   (let ((*use-html-output-p* nil))
120     (declare (special *use-html-output-p*))
121     (dolist (input (directory "tests/*.lisp"))
122       (load input)))
123   (load "tests-report.lisp"))