04b9450c75d1205db8804978a4b2cf2d1687eb97
[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 (defpackage :jscl
20   (:use :cl)
21   (:export #:bootstrap #:run-tests-in-host))
22
23 (in-package :jscl)
24
25 (defvar *source*
26   '(("boot"             :target)
27     ("compat"           :host)
28     ("utils"            :both)
29     ("numbers"          :target)
30     ("char"             :target)
31     ("list"             :target)
32     ("array"            :target)
33     ("string"           :target)
34     ("sequence"         :target)
35     ("stream"           :target)
36     ("print"            :target)
37     ("package"          :target)
38     ("misc"             :target)
39     ("ffi"              :both)
40     ("read"             :both)
41     ("defstruct"        :both)
42     ("lambda-list"      :both)
43     ("backquote"        :both)
44     ("compiler-codegen" :both)
45     ("compiler"         :both)
46     ("toplevel"         :target)))
47
48 (defmacro do-source (name type &body body)
49   (unless (member type '(:host :target))
50     (error "TYPE should be one of :HOST or :TARGET"))
51   (let ((file (gensym)))
52     `(dolist (,file *source*)
53        (when (member (cadr ,file) (list :both ,type))
54          (let ((,name (source-pathname (car ,file) :type "lisp")))
55            ,@body)))))
56
57 (defun source-pathname
58     (filename &key (directory '(:relative "src")) (type nil) (defaults filename))
59   (if type
60       (make-pathname :type type :directory directory :defaults defaults)
61       (make-pathname            :directory directory :defaults defaults)))
62
63 ;;; Compile jscl into the host
64 (with-compilation-unit ()
65   (do-source input :host
66     (multiple-value-bind (fasl warn fail) (compile-file input)
67       (declare (ignore fasl warn))
68       (when fail
69         (error "Compilation of ~A failed." input)))))
70
71 ;;; Load jscl into the host
72 (do-source input :host
73   (load input))
74
75 (defun read-whole-file (filename)
76   (with-open-file (in filename)
77     (let ((seq (make-array (file-length in) :element-type 'character)))
78       (read-sequence seq in)
79       seq)))
80
81 (defun !compile-file (filename out &key print)
82   (let ((*compiling-file* t)
83         (*compile-print-toplevels* print))
84     (let* ((source (read-whole-file filename))
85            (in (make-string-stream source)))
86       (format t "Compiling ~a...~%" filename)
87       (loop
88          with eof-mark = (gensym)
89          for x = (ls-read in nil eof-mark)
90          until (eq x eof-mark)
91          do (let ((compilation (compile-toplevel x)))
92               (when (plusp (length compilation))
93                 (write-string compilation out)))))))
94
95 (defun dump-global-environment (stream)
96   (flet ((late-compile (form)
97            (let ((*standard-output* stream))
98              (write-string (compile-toplevel form)))))
99     ;; We assume that environments have a friendly list representation
100     ;; for the compiler and it can be dumped.
101     (dolist (b (lexenv-function *environment*))
102       (when (eq (binding-type b) 'macro)
103         (setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))
104     (late-compile `(setq *environment* ',*environment*))
105     ;; Set some counter variable properly, so user compiled code will
106     ;; not collide with the compiler itself.
107     (late-compile
108      `(progn
109         (progn ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(string (cdr s)))))
110                          (remove-if-not #'symbolp *literal-table* :key #'car)))
111         (setq *literal-table* ',*literal-table*)
112         (setq *variable-counter* ,*variable-counter*)
113         (setq *gensym-counter* ,*gensym-counter*)))
114     (late-compile `(setq *literal-counter* ,*literal-counter*))))
115
116
117 (defun bootstrap ()
118   (let ((*features* (cons :jscl *features*))
119         (*package* (find-package "JSCL")))
120     (setq *environment* (make-lexenv))
121     (setq *literal-table* nil)
122     (setq *variable-counter* 0
123           *gensym-counter* 0
124           *literal-counter* 0)
125     (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
126       (write-string (read-whole-file (source-pathname "prelude.js")) out)
127       (do-source input :target
128         (!compile-file input out))
129       (dump-global-environment out))
130     ;; Tests
131     (with-open-file (out "tests.js" :direction :output :if-exists :supersede)
132       (dolist (input (append (directory "tests.lisp")
133                              (directory "tests/*.lisp")
134                              (directory "tests-report.lisp")))
135         (!compile-file input out)))))
136
137
138 ;;; Run the tests in the host Lisp implementation. It is a quick way
139 ;;; to improve the level of trust of the tests.
140 (defun run-tests-in-host ()
141   (let ((*package* (find-package "JSCL")))
142     (load "tests.lisp")
143     (let ((*use-html-output-p* nil))
144       (declare (special *use-html-output-p*))
145       (dolist (input (directory "tests/*.lisp"))
146         (load input)))
147     (load "tests-report.lisp")))