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