#+common-lisp
(eval-when (:load-toplevel :compile-toplevel :execute)
- (load "compat"))
-
-;;; At this point, no matter if Common Lisp or ecmalisp is compiling
-;;; from here, this code will compile on both. We define some helper
-;;; functions now for string manipulation and so on. They will be
-;;; useful in the compiler, mostly.
-
-(defvar *newline* (string (code-char 10)))
-
-#+ecmalisp
-(defun concat (&rest strs)
- (!reduce #'concat-two strs :initial-value ""))
-#+common-lisp
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun concat (&rest strs)
- (apply #'concatenate 'string strs)))
-
-(defmacro concatf (variable &body form)
- `(setq ,variable (concat ,variable (progn ,@form))))
-
-;;; This couple of helper functions will be defined in both Common
-;;; Lisp and in Ecmalisp.
-(defun ensure-list (x)
- (if (listp x)
- x
- (list x)))
-
-(defun !reduce (func list &key initial-value)
- (if (null list)
- initial-value
- (!reduce func
- (cdr list)
- :initial-value (funcall func initial-value (car list)))))
-
-;;; Concatenate a list of strings, with a separator
-(defun join (list &optional (separator ""))
- (cond
- ((null list)
- "")
- ((null (cdr list))
- (car list))
- (t
- (concat (car list)
- separator
- (join (cdr list) separator)))))
-
-(defun join-trailing (list &optional (separator ""))
- (if (null list)
- ""
- (concat (car list) separator (join-trailing (cdr list) separator))))
-
-(defun mapconcat (func list)
- (join (mapcar func list)))
-
-(defun vector-to-list (vector)
- (let ((list nil)
- (size (length vector)))
- (dotimes (i size (reverse list))
- (push (aref vector i) list))))
-
-(defun list-to-vector (list)
- (let ((v (make-array (length list)))
- (i 0))
- (dolist (x list v)
- (aset v i x)
- (incf i))))
-
-(defmacro awhen (condition &body body)
- `(let ((it ,condition))
- (when it ,@body)))
-
-#+ecmalisp
-(progn
- (defun values-list (list)
- (values-array (list-to-vector list)))
-
- (defun values (&rest args)
- (values-list args)))
-
-(defun integer-to-string (x)
- (cond
- ((zerop x)
- "0")
- ((minusp x)
- (concat "-" (integer-to-string (- 0 x))))
- (t
- (let ((digits nil))
- (while (not (zerop x))
- (push (mod x 10) digits)
- (setq x (truncate x 10)))
- (mapconcat (lambda (x) (string (digit-char x)))
- digits)))))
-
-
-;;; Printer
-
-#+ecmalisp
-(progn
- (defun prin1-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))
- ((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)) " ")
- (let ((last (last form)))
- (if (null (cdr last))
- (prin1-to-string (car last))
- (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
- ")"))
- ((arrayp form)
- (concat "#" (if (zerop (length form))
- "()"
- (prin1-to-string (vector-to-list form)))))
- ((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))
- (t
- (concat "#<javascript object>"))))
-
- (defun write-line (x)
- (write-string x)
- (write-string *newline*)
- x)
-
- (defun warn (string)
- (write-string "WARNING: ")
- (write-line string))
-
- (defun print (x)
- (write-line (prin1-to-string x))
- x))
-
-
-
-;;;; Reader
-
-;;; The Lisp reader, parse strings and return Lisp objects. The main
-;;; entry points are `ls-read' and `ls-read-from-string'.
-
-(defun make-string-stream (string)
- (cons string 0))
-
-(defun %peek-char (stream)
- (and (< (cdr stream) (length (car stream)))
- (char (car stream) (cdr stream))))
-
-(defun %read-char (stream)
- (and (< (cdr stream) (length (car stream)))
- (prog1 (char (car stream) (cdr stream))
- (rplacd stream (1+ (cdr stream))))))
-
-(defun whitespacep (ch)
- (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
-
-(defun skip-whitespaces (stream)
- (let (ch)
- (setq ch (%peek-char stream))
- (while (and ch (whitespacep ch))
- (%read-char stream)
- (setq ch (%peek-char stream)))))
-
-(defun terminalp (ch)
- (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
-
-(defun read-until (stream func)
- (let ((string "")
- (ch))
- (setq ch (%peek-char stream))
- (while (and ch (not (funcall func ch)))
- (setq string (concat string (string ch)))
- (%read-char stream)
- (setq ch (%peek-char stream)))
- string))
-
-(defun skip-whitespaces-and-comments (stream)
- (let (ch)
- (skip-whitespaces stream)
- (setq ch (%peek-char stream))
- (while (and ch (char= ch #\;))
- (read-until stream (lambda (x) (char= x #\newline)))
- (skip-whitespaces stream)
- (setq ch (%peek-char stream)))))
-
-(defun %read-list (stream)
- (skip-whitespaces-and-comments stream)
- (let ((ch (%peek-char stream)))
- (cond
- ((null ch)
- (error "Unspected EOF"))
- ((char= ch #\))
- (%read-char stream)
- nil)
- ((char= ch #\.)
- (%read-char stream)
- (prog1 (ls-read stream)
- (skip-whitespaces-and-comments stream)
- (unless (char= (%read-char stream) #\))
- (error "')' was expected."))))
- (t
- (cons (ls-read stream) (%read-list stream))))))
-
-(defun read-string (stream)
- (let ((string "")
- (ch nil))
- (setq ch (%read-char stream))
- (while (not (eql ch #\"))
- (when (null ch)
- (error "Unexpected EOF"))
- (when (eql ch #\\)
- (setq ch (%read-char stream)))
- (setq string (concat string (string ch)))
- (setq ch (%read-char stream)))
- string))
-
-(defun read-sharp (stream)
- (%read-char stream)
- (ecase (%read-char stream)
- (#\'
- (list 'function (ls-read stream)))
- (#\( (list-to-vector (%read-list stream)))
- (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
- (#\\
- (let ((cname
- (concat (string (%read-char stream))
- (read-until stream #'terminalp))))
- (cond
- ((string= cname "space") (char-code #\space))
- ((string= cname "tab") (char-code #\tab))
- ((string= cname "newline") (char-code #\newline))
- (t (char-code (char cname 0))))))
- (#\+
- (let ((feature (read-until stream #'terminalp)))
- (cond
- ((string= feature "common-lisp")
- (ls-read stream) ;ignore
- (ls-read stream))
- ((string= feature "ecmalisp")
- (ls-read stream))
- (t
- (error "Unknown reader form.")))))))
-
-;;; Parse a string of the form NAME, PACKAGE:NAME or
-;;; PACKAGE::NAME and return the name. If the string is of the
-;;; form 1) or 3), but the symbol does not exist, it will be created
-;;; and interned in that package.
-(defun read-symbol (string)
- (let ((size (length string))
- package name internalp index)
- (setq index 0)
- (while (and (< index size)
- (not (char= (char string index) #\:)))
- (incf index))
- (cond
- ;; No package prefix
- ((= index size)
- (setq name string)
- (setq package *package*)
- (setq internalp t))
- (t
- ;; Package prefix
- (if (zerop index)
- (setq package "KEYWORD")
- (setq package (string-upcase (subseq string 0 index))))
- (incf index)
- (when (char= (char string index) #\:)
- (setq internalp t)
- (incf index))
- (setq name (subseq string index))))
- ;; Canonalize symbol name and package
- (when (not (eq package "JS"))
- (setq name (string-upcase name)))
- (setq package (find-package package))
- ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
- ;; external symbol from PACKAGE.
- (if (or internalp
- (eq package (find-package "KEYWORD"))
- (eq package (find-package "JS")))
- (intern name package)
- (find-symbol name package))))
-
-
-(defun !parse-integer (string junk-allow)
- (block nil
- (let ((value 0)
- (index 0)
- (size (length string))
- (sign 1))
- ;; Leading whitespace
- (while (and (< index size)
- (whitespacep (char string index)))
- (incf index))
- (unless (< index size) (return (values nil 0)))
- ;; Optional sign
- (case (char string 0)
- (#\+ (incf index))
- (#\- (setq sign -1)
- (incf index)))
- ;; First digit
- (unless (and (< index size)
- (setq value (digit-char-p (char string index))))
- (return (values nil index)))
- (incf index)
- ;; Other digits
- (while (< index size)
- (let ((digit (digit-char-p (char string index))))
- (unless digit (return))
- (setq value (+ (* value 10) digit))
- (incf index)))
- ;; Trailing whitespace
- (do ((i index (1+ i)))
- ((or (= i size) (not (whitespacep (char string i))))
- (and (= i size) (setq index i))))
- (if (or junk-allow
- (= index size))
- (values (* sign value) index)
- (values nil index)))))
-
-#+ecmalisp
-(defun parse-integer (string &key junk-allowed)
- (multiple-value-bind (num index)
- (!parse-integer string junk-allowed)
- (when num
- (values num index)
- (error "junk detected."))))
-
-(defvar *eof* (gensym))
-(defun ls-read (stream)
- (skip-whitespaces-and-comments stream)
- (let ((ch (%peek-char stream)))
- (cond
- ((or (null ch) (char= ch #\)))
- *eof*)
- ((char= ch #\()
- (%read-char stream)
- (%read-list stream))
- ((char= ch #\')
- (%read-char stream)
- (list 'quote (ls-read stream)))
- ((char= ch #\`)
- (%read-char stream)
- (list 'backquote (ls-read stream)))
- ((char= ch #\")
- (%read-char stream)
- (read-string stream))
- ((char= ch #\,)
- (%read-char stream)
- (if (eql (%peek-char stream) #\@)
- (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
- (list 'unquote (ls-read stream))))
- ((char= ch #\#)
- (read-sharp stream))
- (t
- (let ((string (read-until stream #'terminalp)))
- (or (values (!parse-integer string nil))
- (read-symbol string)))))))
-
-(defun ls-read-from-string (string)
- (ls-read (make-string-stream string)))
+ (load "compat")
+ (load "utils")
+ (load "print")
+ (load "read"))
+;; At this point, no matter if Common Lisp or ecmalisp is compiling
+;; from here, this code will compile on both. We define some helper
+;; functions now for string manipulation and so on. They will be
+;; useful in the compiler, mostly.
;;;; Compiler
*block-counter* 0)
(with-open-file (out "ecmalisp.js" :direction :output :if-exists :supersede)
(write-string (read-whole-file "prelude.js") out)
- (ls-compile-file "boot.lisp" out :print t)
- (ls-compile-file "ecmalisp.lisp" out :print t))))
+ (dolist (file '("boot.lisp"
+ "utils.lisp"
+ "print.lisp"
+ "read.lisp"
+ "ecmalisp.lisp"))
+ (ls-compile-file file out :print t)))))
--- /dev/null
+;;;; Reader
+
+;;; The Lisp reader, parse strings and return Lisp objects. The main
+;;; entry points are `ls-read' and `ls-read-from-string'.
+
+(defun make-string-stream (string)
+ (cons string 0))
+
+(defun %peek-char (stream)
+ (and (< (cdr stream) (length (car stream)))
+ (char (car stream) (cdr stream))))
+
+(defun %read-char (stream)
+ (and (< (cdr stream) (length (car stream)))
+ (prog1 (char (car stream) (cdr stream))
+ (rplacd stream (1+ (cdr stream))))))
+
+(defun whitespacep (ch)
+ (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
+
+(defun skip-whitespaces (stream)
+ (let (ch)
+ (setq ch (%peek-char stream))
+ (while (and ch (whitespacep ch))
+ (%read-char stream)
+ (setq ch (%peek-char stream)))))
+
+(defun terminalp (ch)
+ (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
+
+(defun read-until (stream func)
+ (let ((string "")
+ (ch))
+ (setq ch (%peek-char stream))
+ (while (and ch (not (funcall func ch)))
+ (setq string (concat string (string ch)))
+ (%read-char stream)
+ (setq ch (%peek-char stream)))
+ string))
+
+(defun skip-whitespaces-and-comments (stream)
+ (let (ch)
+ (skip-whitespaces stream)
+ (setq ch (%peek-char stream))
+ (while (and ch (char= ch #\;))
+ (read-until stream (lambda (x) (char= x #\newline)))
+ (skip-whitespaces stream)
+ (setq ch (%peek-char stream)))))
+
+(defun %read-list (stream)
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (cond
+ ((null ch)
+ (error "Unspected EOF"))
+ ((char= ch #\))
+ (%read-char stream)
+ nil)
+ ((char= ch #\.)
+ (%read-char stream)
+ (prog1 (ls-read stream)
+ (skip-whitespaces-and-comments stream)
+ (unless (char= (%read-char stream) #\))
+ (error "')' was expected."))))
+ (t
+ (cons (ls-read stream) (%read-list stream))))))
+
+(defun read-string (stream)
+ (let ((string "")
+ (ch nil))
+ (setq ch (%read-char stream))
+ (while (not (eql ch #\"))
+ (when (null ch)
+ (error "Unexpected EOF"))
+ (when (eql ch #\\)
+ (setq ch (%read-char stream)))
+ (setq string (concat string (string ch)))
+ (setq ch (%read-char stream)))
+ string))
+
+(defun read-sharp (stream)
+ (%read-char stream)
+ (ecase (%read-char stream)
+ (#\'
+ (list 'function (ls-read stream)))
+ (#\( (list-to-vector (%read-list stream)))
+ (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
+ (#\\
+ (let ((cname
+ (concat (string (%read-char stream))
+ (read-until stream #'terminalp))))
+ (cond
+ ((string= cname "space") (char-code #\space))
+ ((string= cname "tab") (char-code #\tab))
+ ((string= cname "newline") (char-code #\newline))
+ (t (char-code (char cname 0))))))
+ (#\+
+ (let ((feature (read-until stream #'terminalp)))
+ (cond
+ ((string= feature "common-lisp")
+ (ls-read stream) ;ignore
+ (ls-read stream))
+ ((string= feature "ecmalisp")
+ (ls-read stream))
+ (t
+ (error "Unknown reader form.")))))))
+
+;;; Parse a string of the form NAME, PACKAGE:NAME or
+;;; PACKAGE::NAME and return the name. If the string is of the
+;;; form 1) or 3), but the symbol does not exist, it will be created
+;;; and interned in that package.
+(defun read-symbol (string)
+ (let ((size (length string))
+ package name internalp index)
+ (setq index 0)
+ (while (and (< index size)
+ (not (char= (char string index) #\:)))
+ (incf index))
+ (cond
+ ;; No package prefix
+ ((= index size)
+ (setq name string)
+ (setq package *package*)
+ (setq internalp t))
+ (t
+ ;; Package prefix
+ (if (zerop index)
+ (setq package "KEYWORD")
+ (setq package (string-upcase (subseq string 0 index))))
+ (incf index)
+ (when (char= (char string index) #\:)
+ (setq internalp t)
+ (incf index))
+ (setq name (subseq string index))))
+ ;; Canonalize symbol name and package
+ (when (not (eq package "JS"))
+ (setq name (string-upcase name)))
+ (setq package (find-package package))
+ ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
+ ;; external symbol from PACKAGE.
+ (if (or internalp
+ (eq package (find-package "KEYWORD"))
+ (eq package (find-package "JS")))
+ (intern name package)
+ (find-symbol name package))))
+
+
+(defun !parse-integer (string junk-allow)
+ (block nil
+ (let ((value 0)
+ (index 0)
+ (size (length string))
+ (sign 1))
+ ;; Leading whitespace
+ (while (and (< index size)
+ (whitespacep (char string index)))
+ (incf index))
+ (unless (< index size) (return (values nil 0)))
+ ;; Optional sign
+ (case (char string 0)
+ (#\+ (incf index))
+ (#\- (setq sign -1)
+ (incf index)))
+ ;; First digit
+ (unless (and (< index size)
+ (setq value (digit-char-p (char string index))))
+ (return (values nil index)))
+ (incf index)
+ ;; Other digits
+ (while (< index size)
+ (let ((digit (digit-char-p (char string index))))
+ (unless digit (return))
+ (setq value (+ (* value 10) digit))
+ (incf index)))
+ ;; Trailing whitespace
+ (do ((i index (1+ i)))
+ ((or (= i size) (not (whitespacep (char string i))))
+ (and (= i size) (setq index i))))
+ (if (or junk-allow
+ (= index size))
+ (values (* sign value) index)
+ (values nil index)))))
+
+#+ecmalisp
+(defun parse-integer (string &key junk-allowed)
+ (multiple-value-bind (num index)
+ (!parse-integer string junk-allowed)
+ (when num
+ (values num index)
+ (error "junk detected."))))
+
+(defvar *eof* (gensym))
+(defun ls-read (stream)
+ (skip-whitespaces-and-comments stream)
+ (let ((ch (%peek-char stream)))
+ (cond
+ ((or (null ch) (char= ch #\)))
+ *eof*)
+ ((char= ch #\()
+ (%read-char stream)
+ (%read-list stream))
+ ((char= ch #\')
+ (%read-char stream)
+ (list 'quote (ls-read stream)))
+ ((char= ch #\`)
+ (%read-char stream)
+ (list 'backquote (ls-read stream)))
+ ((char= ch #\")
+ (%read-char stream)
+ (read-string stream))
+ ((char= ch #\,)
+ (%read-char stream)
+ (if (eql (%peek-char stream) #\@)
+ (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
+ (list 'unquote (ls-read stream))))
+ ((char= ch #\#)
+ (read-sharp stream))
+ (t
+ (let ((string (read-until stream #'terminalp)))
+ (or (values (!parse-integer string nil))
+ (read-symbol string)))))))
+
+(defun ls-read-from-string (string)
+ (ls-read (make-string-stream string)))
--- /dev/null
+;;; utils.lisp ---
+
+;; Copyright (C) 2012, 2013 David Vazquez
+;; Copyright (C) 2012 Raimon Grau
+
+;; This program 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
+;; 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/>.
+
+(defmacro concatf (variable &body form)
+ `(setq ,variable (concat ,variable (progn ,@form))))
+
+;;; This couple of helper functions will be defined in both Common
+;;; Lisp and in Ecmalisp.
+(defun ensure-list (x)
+ (if (listp x)
+ x
+ (list x)))
+
+(defun !reduce (func list &key initial-value)
+ (if (null list)
+ initial-value
+ (!reduce func
+ (cdr list)
+ :initial-value (funcall func initial-value (car list)))))
+
+;;; Concatenate a list of strings, with a separator
+(defun join (list &optional (separator ""))
+ (cond
+ ((null list)
+ "")
+ ((null (cdr list))
+ (car list))
+ (t
+ (concat (car list)
+ separator
+ (join (cdr list) separator)))))
+
+(defun join-trailing (list &optional (separator ""))
+ (if (null list)
+ ""
+ (concat (car list) separator (join-trailing (cdr list) separator))))
+
+(defun mapconcat (func list)
+ (join (mapcar func list)))
+
+(defun vector-to-list (vector)
+ (let ((list nil)
+ (size (length vector)))
+ (dotimes (i size (reverse list))
+ (push (aref vector i) list))))
+
+(defun list-to-vector (list)
+ (let ((v (make-array (length list)))
+ (i 0))
+ (dolist (x list v)
+ (aset v i x)
+ (incf i))))
+
+(defmacro awhen (condition &body body)
+ `(let ((it ,condition))
+ (when it ,@body)))
+
+#+ecmalisp
+(progn
+ )
+
+(defun integer-to-string (x)
+ (cond
+ ((zerop x)
+ "0")
+ ((minusp x)
+ (concat "-" (integer-to-string (- 0 x))))
+ (t
+ (let ((digits nil))
+ (while (not (zerop x))
+ (push (mod x 10) digits)
+ (setq x (truncate x 10)))
+ (mapconcat (lambda (x) (string (digit-char x)))
+ digits)))))
projects / jscl.git / commitdiff