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       (compile-file (source-pathname (car input))))))
  40
  41 ;;; Load jscl into the host
  42 (dolist (input *source*)
  43   (when (member (cadr input) '(:host :both))
  44     (load (source-pathname (car input)))))
  45
  46 (defun read-whole-file (filename)
  47   (with-open-file (in filename)
  48     (let ((seq (make-array (file-length in) :element-type 'character)))
  49       (read-sequence seq in)
  50       seq)))
  51
  52 (defun ls-compile-file (filename out &key print)
  53   (let ((*compiling-file* t)
  54         (*compile-print-toplevels* print))
  55     (let* ((source (read-whole-file filename))
  56            (in (make-string-stream source)))
  57       (format t "Compiling ~a...~%" filename)
  58       (loop
  59          with eof-mark = (gensym)
  60          for x = (ls-read in nil eof-mark)
  61          until (eq x eof-mark)
  62          for compilation = (ls-compile-toplevel x)
  63          when (plusp (length compilation))
  64          do (write-string compilation out)))))
  65
  66 (defun bootstrap ()
  67   (setq *environment* (make-lexenv))
  68   (setq *literal-table* nil)
  69   (setq *variable-counter* 0
  70         *gensym-counter* 0
  71         *literal-counter* 0
  72         *block-counter* 0)
  73   (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
  74     (write-string (read-whole-file (source-pathname "prelude.js")) out)
  75     (dolist (input *source*)
  76       (when (member (cadr input) '(:target :both))
  77         (ls-compile-file (source-pathname (car input) :type "lisp") out))))
  78   ;; Tests
  79   (with-open-file (out "tests.js" :direction :output :if-exists :supersede)
  80     (dolist (input (append (directory "tests.lisp")
  81                            (directory "tests/*.lisp")
  82                            (directory "tests-report.lisp")))
  83       (ls-compile-file input out))))
  84
  85
  86 ;;; Run the tests in the host Lisp implementation. It is a quick way
  87 ;;; to improve the level of trust of the tests.
  88 (defun run-tests-in-host ()
  89   (dolist (input (append (directory "tests.lisp")
  90                          (directory "tests/*.lisp")
  91                          (directory "tests-report.lisp")))
  92     (load input)))