;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
- ;; This program is free software: you can redistribute it and/or
+ ;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
- ;; This program is distributed in the hope that it will be useful, but
+ ;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
- ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+ ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
(defvar *source*
'(("boot" :target)
("compat" :host)
("utils" :both)
+ ("list" :target)
("print" :target)
+ ("package" :target)
("read" :both)
("compiler" :both)
- ("toplevel" :target)
- ;; Tests
- ("tests" :test)
- ("format" :test)
- ("setf" :test)
- ("eval" :test)
- ("tests-report" :test)))
+ ("toplevel" :target)))
(defun source-pathname
(filename &key (directory '(:relative "src")) (type nil) (defaults filename))
(with-compilation-unit ()
(dolist (input *source*)
(when (member (cadr input) '(:host :both))
- (compile-file (source-pathname (car input))))))
+ (let ((fname (source-pathname (car input))))
+ (multiple-value-bind (fasl warn fail) (compile-file fname)
+ (declare (ignore fasl warn))
+ (when fail
+ (error "Compilation of ~A failed." fname)))))))
;;; Load jscl into the host
(dolist (input *source*)
(load (source-pathname (car input)))))
(defun read-whole-file (filename)
- (with-open-file (in filename)
+ (with-open-file (in filename :external-format :latin-1)
(let ((seq (make-array (file-length in) :element-type 'character)))
(read-sequence seq in)
seq)))
(defun bootstrap ()
(setq *environment* (make-lexenv))
- (setq *literal-symbols* nil)
+ (setq *literal-table* nil)
(setq *variable-counter* 0
*gensym-counter* 0
- *literal-counter* 0
- *block-counter* 0)
+ *literal-counter* 0)
(with-open-file (out "jscl.js" :direction :output :if-exists :supersede)
(write-string (read-whole-file (source-pathname "prelude.js")) out)
(dolist (input *source*)
(ls-compile-file (source-pathname (car input) :type "lisp") out))))
;; Tests
(with-open-file (out "tests.js" :direction :output :if-exists :supersede)
- (dolist (input *source*)
- (when (member (cadr input) '(:test))
- (ls-compile-file (source-pathname (car input)
- :directory '(:relative "tests")
- :type "lisp")
- out)))))
+ (dolist (input (append (directory "tests.lisp")
+ (directory "tests/*.lisp")
- (directory "tests-report.lisp")))
++ (directory "tests-report.lisp")))
+ (ls-compile-file input out))))
+
+
+ ;;; Run the tests in the host Lisp implementation. It is a quick way
+ ;;; to improve the level of trust of the tests.
+ (defun run-tests-in-host ()
+ (load "tests.lisp")
+ (let ((*use-html-output-p* nil))
+ (declare (special *use-html-output-p*))
+ (dolist (input (directory "tests/*.lisp"))
+ (load input)))
+ (load "tests-report.lisp"))
-;;; print.lisp ---
+;;; print.lisp ---
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
- ;; This program is free software: you can redistribute it and/or
+ ;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
- ;; This program is distributed in the hope that it will be useful, but
+ ;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
- ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+ ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
;;; Printer
-(defun prin1-to-string (form)
+(defvar *print-escape* t)
+
+(defun write-to-string (form)
(cond
- ((symbolp form)
- (multiple-value-bind (symbol foundp)
- (find-symbol (symbol-name form) *package*)
- (if (and foundp (eq symbol form))
- (symbol-name form)
- (let ((package (symbol-package form))
- (name (symbol-name form)))
- (concat (cond
- ((null package) "#")
- ((eq package (find-package "KEYWORD")) "")
- (t (package-name package)))
- ":" name)))))
- ((integerp form) (integer-to-string form))
- ((floatp form) (float-to-string form))
- ((stringp form) (if *print-escape*
- (concat "\"" (escape-string form) "\"")
- form))
- ((functionp form)
- (let ((name (oget form "fname")))
- (if name
- (concat "#<FUNCTION " name ">")
- (concat "#<FUNCTION>"))))
- ((listp form)
- (concat "("
- (join-trailing (mapcar #'write-to-string (butlast form)) " ")
- (let ((last (last form)))
- (if (null (cdr last))
- (write-to-string (car last))
- (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
- ")"))
- ((arrayp form)
- (concat "#" (if (zerop (length form))
- "()"
- (write-to-string (vector-to-list form)))))
- ((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))
- (t
- (concat "#<javascript object>"))))
+ ((symbolp form)
+ (multiple-value-bind (symbol foundp)
+ (find-symbol (symbol-name form) *package*)
+ (if (and foundp (eq symbol form))
+ (symbol-name form)
+ (let ((package (symbol-package form))
+ (name (symbol-name form)))
+ (concat (cond
+ ((null package) "#")
+ ((eq package (find-package "KEYWORD")) "")
+ (t (package-name package)))
+ ":" name)))))
+ ((integerp form) (integer-to-string form))
+ ((floatp form) (float-to-string form))
+ ((characterp form)
- (concat "#\\"
++ (concat "#\\"
+ (case form
+ (#\newline "newline")
+ (#\space "space")
+ (otherwise (string form)))))
+ ((stringp form) (concat "\"" (escape-string form) "\""))
+ ((functionp form)
+ (let ((name (oget form "fname")))
+ (if name
+ (concat "#<FUNCTION " name ">")
+ (concat "#<FUNCTION>"))))
+ ((listp form)
+ (concat "("
- (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
++ (join-trailing (mapcar #'write-to-string (butlast form)) " ")
+ (let ((last (last form)))
+ (if (null (cdr last))
- (prin1-to-string (car last))
- (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
++ (write-to-string (car last))
++ (concat (write-to-string (car last)) " . " (write-to-string (cdr last)))))
+ ")"))
+ ((arrayp form)
+ (concat "#" (if (zerop (length form))
+ "()"
- (prin1-to-string (vector-to-list form)))))
++ (write-to-string (vector-to-list form)))))
+ ((packagep form)
+ (concat "#<PACKAGE " (package-name form) ">"))
+ (t
+ (concat "#<javascript object>"))))
+(defun prin1-to-string (form)
+ (let ((*print-escape* t))
+ (write-to-string form)))
+
+(defun princ-to-string (form)
+ (let ((*print-escape* nil))
+ (write-to-string form)))
+
(defun write-line (x)
(write-string x)
(write-string *newline*)
(defun print (x)
(write-line (prin1-to-string x))
x)
+
+(defun format (destination fmt &rest args)
+ (let ((len (length fmt))
+ (i 0)
+ (res "")
+ (arguments args))
+ (while (< i len)
+ (let ((c (char fmt i)))
+ (if (char= c #\~)
+ (let ((next (char fmt (incf i))))
+ (cond
+ ((char= next #\~)
+ (setq res (concat res "~")))
+ ((char= next #\%)
+ (setq res (concat res *newline*)))
+ (t
+ (setq res (concat res (format-special next (car arguments))))
+ (setq arguments (cdr arguments)))))
+ (setq res (concat res (char-to-string c))))
+ (incf i)))
+ (if destination
+ (progn
+ (write-string res)
+ nil)
+ res)))
+
+
+(defun format-special (chr arg)
+ (case chr
+ (#\S (prin1-to-string arg))
+ (#\a (princ-to-string arg))))
;; Copyright (C) 2012, 2013 David Vazquez
;; Copyright (C) 2012 Raimon Grau
- ;; This program is free software: you can redistribute it and/or
+ ;; JSCL is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
- ;; This program is distributed in the hope that it will be useful, but
+ ;; JSCL is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
- ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+ ;; along with JSCL. If not, see <http://www.gnu.org/licenses/>.
(defun eval (x)
*** **
** *
* (car results)))
+ (unless (boundp '*)
+ ;; FIXME: Handle error
+ (setf * nil))
(setf +++ ++
++ +
+ -)
(values-list /))
(export '(&body &key &optional &rest * ** *** *gensym-counter* *package* + ++
- +++ - / // /// 1+ 1- < <= = = > >= and append apply aref
- arrayp assoc atom block boundp butlast caar cadddr caddr
+ +++ - / // /// 1+ 1- < <= = = > >= and append apply aref arrayp
+ assoc atom block boundp butlast cadar caaar caadr cdaar cdadr
+ cddar caaaar caaadr caadar caaddr cadaar cadadr caddar cdaaar
+ cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr caar cadddr caddr
cadr car car case catch cdar cdddr cddr cdr cdr char
char-code char= code-char cond cons consp constantly
- copy-list decf declaim defconstant define-setf-expander
+ copy-list copy-tree decf declaim declare defconstant define-setf-expander
define-symbol-macro defmacro defparameter defun defvar
digit-char digit-char-p disassemble do do* documentation
dolist dotimes ecase eq eql equal error eval every export expt
- fdefinition find-package find-symbol first flet fourth fset
+ fdefinition find-package find-symbol first flet format fourth fset
- funcall function functionp gensym get-setf-expansion
- get-universal-time go identity if in-package incf integerp
- intern keywordp labels lambda last length let let* list
+ funcall function functionp gensym get-internal-real-time
+ get-setf-expansion get-universal-time go identity if in-package
+ incf integerp intern keywordp labels lambda last length let let* list
list* list-all-packages listp loop make-array make-package
make-symbol mapcar member minusp mod multiple-value-bind
multiple-value-call multiple-value-list multiple-value-prog1
- nconc nil not nreconc nth nthcdr null numberp or
- package-name package-use-list packagep parse-integer plusp
+ nconc nil not nreconc nth nthcdr null numberp or otherwise
+ package-name package-use-list packagep parse-integer plusp pop
prin1-to-string print proclaim prog1 prog2 progn psetq push
- quote remove remove-if remove-if-not return return-from
- revappend reverse rplaca rplacd second set setf setq some
- string string-upcase string= stringp subseq symbol-function
- symbol-name symbol-package symbol-plist symbol-value symbolp
- t tagbody third throw truncate unless unwind-protect values
- values-list variable warn when write-line write-string zerop))
+ quote read-from-string remove remove-if remove-if-not return
+ return-from revappend reverse rplaca rplacd second set setf
+ setq some string string-upcase string= stringp subseq subst
+ symbol-function symbol-name symbol-package symbol-plist
+ symbol-value symbolp t tagbody third throw truncate unless
+ unwind-protect values values-list variable warn when write-line
+ write-string zerop))
(setq *package* *user-package*)
(ls-compile
`(progn
,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
- *literal-symbols*)
- (setq *literal-symbols* ',*literal-symbols*)
+ *literal-table*)
+ (setq *literal-table* ',*literal-table*)
(setq *variable-counter* ,*variable-counter*)
- (setq *gensym-counter* ,*gensym-counter*)
- (setq *block-counter* ,*block-counter*)))))
+ (setq *gensym-counter* ,*gensym-counter*)))))
(eval-when-compile
(toplevel-compilation
projects / jscl.git / commitdiff