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 *version* "0.0.2")
  26
  27 (defvar *base-directory*
  28   (or #.*load-pathname* *default-pathname-defaults*))
  29
  30 ;;; List of all the source files that need to be compiled, and whether they
  31 ;;; are to be compiled just by the host, by the target JSCL, or by both.
  32 ;;; All files have a `.lisp' extension, and
  33 ;;; are relative to src/
  34 ;;; Subdirectories are indicated by the presence of a list rather than a
  35 ;;; keyword in the second element of the list. For example, this list:
  36 ;;;  (("foo"    :target)
  37 ;;;   ("bar"
  38 ;;;     ("baz"  :host)
  39 ;;;     ("quux" :both)))
  40 ;;; Means that src/foo.lisp and src/bar/quux.lisp need to be compiled in the
  41 ;;; target, and that src/bar/baz.lisp and src/bar/quux.lisp need to be
  42 ;;; compiled in the host
  43 (defvar *source*
  44   '(("boot"          :target)
  45     ("compat"        :host)
  46     ("setf"          :target)
  47     ("utils"         :both)
  48     ("numbers"       :target)
  49     ("char"          :target)
  50     ("list"          :target)
  51     ("array"         :target)
  52     ("string"        :target)
  53     ("sequence"      :target)
  54     ("stream"        :target)
  55     ("hash-table"    :target)
  56     ("print"         :target)
  57     ("documentation" :target)
  58     ("misc"          :target)
  59     ("ffi"           :target)
  60     ("symbol"        :target)
  61     ("package"       :target)
  62     ("read"          :both)
  63     ("defstruct"     :both)
  64     ("lambda-list"   :both)
  65     ("backquote"     :both)
  66     ("compiler"
  67      ("codegen"      :both)
  68      ("compiler"     :both))
  69     ("toplevel"      :target)))
  70
  71 (defun get-files (file-list type dir)
  72   "Traverse FILE-LIST and retrieve a list of the files within which match
  73    either TYPE or :BOTH, processing subdirectories."
  74   (let ((file (car file-list)))
  75     (cond
  76       ((null file-list)
  77        ())
  78       ((listp (cadr file))
  79        (append
  80          (get-files (cdr file)      type (append dir (list (car file))))
  81          (get-files (cdr file-list) type dir)))
  82       ((member (cadr file) (list type :both))
  83        (cons (source-pathname (car file) :directory dir :type "lisp")
  84              (get-files (cdr file-list) type dir)))
  85       (t
  86        (get-files (cdr file-list) type dir)))))
  87
  88 (defmacro do-source (name type &body body)
  89   "Iterate over all the source files that need to be compiled in the host or
  90    the target, depending on the TYPE argument."
  91   (unless (member type '(:host :target))
  92     (error "TYPE must be one of :HOST or :TARGET, not ~S" type))
  93   `(dolist (,name (get-files *source* ,type '(:relative "src")))
  94      ,@body))
  95
  96 (defun source-pathname (filename &key (directory '(:relative "src")) (type nil) (defaults filename))
  97   (merge-pathnames
  98    (if type
  99        (make-pathname :type type :directory directory :defaults defaults)
 100        (make-pathname            :directory directory :defaults defaults))
 101    *base-directory*))
 102
 103 ;;; Compile jscl into the host
 104 (with-compilation-unit ()
 105   (do-source input :host
 106     (multiple-value-bind (fasl warn fail) (compile-file input)
 107       (declare (ignore fasl warn))
 108       (when fail
 109         (error "Compilation of ~A failed." input)))))
 110
 111 ;;; Load jscl into the host
 112 (do-source input :host
 113   (load input))
 114
 115 (defun read-whole-file (filename)
 116   (with-open-file (in filename)
 117     (let ((seq (make-array (file-length in) :element-type 'character)))
 118       (read-sequence seq in)
 119       seq)))
 120
 121 (defun !compile-file (filename out &key print)
 122   (let ((*compiling-file* t)
 123         (*compile-print-toplevels* print))
 124     (let* ((source (read-whole-file filename))
 125            (in (make-string-stream source)))
 126       (format t "Compiling ~a...~%" (enough-namestring filename))
 127       (loop
 128          with eof-mark = (gensym)
 129          for x = (ls-read in nil eof-mark)
 130          until (eq x eof-mark)
 131          do (let ((compilation (compile-toplevel x)))
 132               (when (plusp (length compilation))
 133                 (write-string compilation out)))))))
 134
 135 (defun dump-global-environment (stream)
 136   (flet ((late-compile (form)
 137            (let ((*standard-output* stream))
 138              (write-string (compile-toplevel form)))))
 139     ;; We assume that environments have a friendly list representation
 140     ;; for the compiler and it can be dumped.
 141     (dolist (b (lexenv-function *environment*))
 142       (when (eq (binding-type b) 'macro)
 143         (setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))
 144     (late-compile `(setq *environment* ',*environment*))
 145     ;; Set some counter variable properly, so user compiled code will
 146     ;; not collide with the compiler itself.
 147     (late-compile
 148      `(progn
 149         (progn ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(string (cdr s)))))
 150                          (remove-if-not #'symbolp *literal-table* :key #'car)))
 151         (setq *literal-table* ',*literal-table*)
 152         (setq *variable-counter* ,*variable-counter*)
 153         (setq *gensym-counter* ,*gensym-counter*)))
 154     (late-compile `(setq *literal-counter* ,*literal-counter*))))
 155
 156
 157 (defun bootstrap ()
 158   (let ((*features* (cons :jscl *features*))
 159         (*package* (find-package "JSCL")))
 160     (setq *environment* (make-lexenv))
 161     (setq *literal-table* nil)
 162     (setq *variable-counter* 0
 163           *gensym-counter* 0
 164           *literal-counter* 0)
 165     (with-open-file (out (merge-pathnames "jscl.js" *base-directory*)
 166                          :direction :output
 167                          :if-exists :supersede)
 168       (write-string (read-whole-file (source-pathname "prelude.js")) out)
 169       (do-source input :target
 170         (!compile-file input out))
 171       (dump-global-environment out))
 172     ;; Tests
 173     (with-open-file (out (merge-pathnames "tests.js" *base-directory*)
 174                          :direction :output
 175                          :if-exists :supersede)
 176       (dolist (input (append (directory "tests.lisp")
 177                              (directory "tests/*.lisp")
 178                              (directory "tests-report.lisp")))
 179         (!compile-file input out)))
 180     (report-undefined-functions)))
 181
 182
 183 ;;; Run the tests in the host Lisp implementation. It is a quick way
 184 ;;; to improve the level of trust of the tests.
 185 (defun run-tests-in-host ()
 186   (let ((*package* (find-package "JSCL")))
 187     (load "tests.lisp")
 188     (let ((*use-html-output-p* nil))
 189       (declare (special *use-html-output-p*))
 190       (dolist (input (directory "tests/*.lisp"))
 191         (load input)))
 192     (load "tests-report.lisp")))