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     ("list"             :target)
  30     ("string"           :target)
  31     ("print"            :target)
  32     ("package"          :target)
  33     ("ffi"              :target)
  34     ("read"             :both)
  35     ("defstruct"        :both)
  36     ("lambda-list"      :both)
  37     ("compiler"         :both)
  38     ("toplevel"         :target)))
  39
  40 (defun source-pathname
  41     (filename &key (directory '(:relative "src")) (type nil) (defaults filename))
  42   (if type
  43       (make-pathname :type type :directory directory :defaults defaults)
  44       (make-pathname            :directory directory :defaults defaults)))
  45
  46 ;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
  47 ;;; the bootstrap. Once everything is compiled, we want to dump the
  48 ;;; whole global environment to the output file to reproduce it in the
  49 ;;; run-time. However, the environment must contain expander functions
  50 ;;; rather than lists. We do not know how to dump function objects
  51 ;;; itself, so we mark the list definitions with this object and the
  52 ;;; compiler will be called when this object has to be dumped.
  53 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
  54 ;;;
  55 ;;; Indeed, perhaps to compile the object other macros need to be
  56 ;;; evaluated. For this reason we define a valid macro-function for
  57 ;;; this symbol.
  58 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
  59 (setf (macro-function *magic-unquote-marker*)
  60       (lambda (form env)
  61         (declare (ignore env))
  62         (second form)))
  63
  64 ;;; Compile jscl into the host
  65 (with-compilation-unit ()
  66   (dolist (input *source*)
  67     (when (member (cadr input) '(:host :both))
  68       (let ((fname (source-pathname (car input))))
  69         (multiple-value-bind (fasl warn fail) (compile-file fname)
  70           (declare (ignore fasl warn))
  71           (when fail
  72             (error "Compilation of ~A failed." fname)))))))
  73
  74 ;;; Load jscl into the host
  75 (dolist (input *source*)
  76   (when (member (cadr input) '(:host :both))
  77     (load (source-pathname (car input)))))
  78
  79 (defun read-whole-file (filename)
  80   (with-open-file (in filename)
  81     (let ((seq (make-array (file-length in) :element-type 'character)))
  82       (read-sequence seq in)
  83       seq)))
  84
  85 (defun ls-compile-file (filename out &key print)
  86   (let ((*compiling-file* t)
  87         (*compile-print-toplevels* print))
  88     (let* ((source (read-whole-file filename))
  89            (in (make-string-stream source)))
  90       (format t "Compiling ~a...~%" filename)
  91       (loop
  92          with eof-mark = (gensym)
  93          for x = (ls-read in nil eof-mark)
  94          until (eq x eof-mark)
  95          do (let ((compilation (ls-compile-toplevel x)))
  96               (when (plusp (length compilation))
  97                 (write-string compilation out)))))))
  98
  99 (defun dump-global-environment (stream)
 100   (flet ((late-compile (form)
 101            (write-string (ls-compile-toplevel form) stream)))
 102     ;; We assume that environments have a friendly list representation
 103     ;; for the compiler and it can be dumped.
 104     (dolist (b (lexenv-function *environment*))
 105       (when (eq (binding-type b) 'macro)
 106         (setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))
 107     (late-compile `(setq *environment* ',*environment*))
 108     ;; Set some counter variable properly, so user compiled code will
 109     ;; not collide with the compiler itself.
 110     (late-compile
 111      `(progn
 112         ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
 113                   (remove-if-not #'symbolp *literal-table* :key #'car))
 114         (setq *literal-table* ',*literal-table*)
 115         (setq *variable-counter* ,*variable-counter*)
 116         (setq *gensym-counter* ,*gensym-counter*)))
 117     (late-compile `(setq *literal-counter* ,*literal-counter*))))
 118
 119
 120 (defun bootstrap ()
 121   (let ((*package* (find-package "JSCL")))
 122     (setq *environment* (make-lexenv))
 123     (setq *literal-table* nil)
 124     (setq *variable-counter* 0
 125           *gensym-counter* 0
 126           *literal-counter* 0)
 127     (with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
 128       (write-string (read-whole-file (source-pathname "prelude.js")) out)
 129       (dolist (input *source*)
 130         (when (member (cadr input) '(:target :both))
 131           (ls-compile-file (source-pathname (car input) :type "lisp") out)))
 132       (dump-global-environment out))
 133     ;; Tests
 134     (with-open-file (out "tests.js" :direction :output :if-exists :supersede)
 135       (dolist (input (append (directory "tests.lisp")
 136                              (directory "tests/*.lisp")
 137                              (directory "tests-report.lisp")))
 138         (ls-compile-file input out)))))
 139
 140
 141 ;;; Run the tests in the host Lisp implementation. It is a quick way
 142 ;;; to improve the level of trust of the tests.
 143 (defun run-tests-in-host ()
 144   (let ((*package* (find-package "JSCL")))
 145     (load "tests.lisp")
 146     (let ((*use-html-output-p* nil))
 147       (declare (special *use-html-output-p*))
 148       (dolist (input (directory "tests/*.lisp"))
 149         (load input)))
 150     (load "tests-report.lisp")))