(%compile-defvar ',name))
(setq ,name ,value)))
-(defvar t 't)
-(defvar nil 'nil)
-
(defmacro defun (name args &rest body)
`(progn
(eval-when-compile
(%compile-defun ',name))
(fsetq ,name (lambda ,args ,@body))))
+(defvar *package* (new))
+
+(defun intern (name)
+ (let ((s (get *package* name)))
+ (if s s (set *package* name (make-symbol name)))))
+
+(defun find-symbol (name)
+ (get *package* name))
+
+(defvar t 't)
+(defvar nil 'nil)
+
(defmacro when (condition &rest body)
`(if ,condition (progn ,@body) nil))
(defmacro unless (condition &rest body)
`(if ,condition nil (progn ,@body)))
+(defmacro dolist (iter &rest body)
+ (let ((var (first iter))
+ (g!list (make-symbol "LIST")))
+ `(let ((,g!list ,(second iter))
+ (,var nil))
+ (while ,g!list
+ (setq ,var (car ,g!list))
+ ,@body
+ (setq ,g!list (cdr ,g!list))))))
+
(defun = (x y) (= x y))
(defun + (x y) (+ x y))
(defun - (x y) (- x y))
(defun car (x) (car x))
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
-(defun caddr (x) (car (cdr x)))
-(defun cadddr (x) (car (cdr x)))
+(defun caddr (x) (car (cdr (cdr x))))
+(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun cdr (x) (cdr x))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))
(defun atom (x)
(not (consp x)))
-(defun listp (x)
- (or (consp x) (null x)))
-
(defun ensure-list (x)
(if (listp x)
x
(defmacro decf (x)
`(setq ,x (1- ,x)))
-(defun length (list)
+(defun list-length (list)
(let ((l 0))
(while (not (null list))
(incf l)
(setq list (cdr list)))
l))
+(defun length (seq)
+ (if (stringp seq)
+ (string-length seq)
+ (list-length seq)))
+
(defun mapcar (func list)
(if (null list)
'()
(defmacro push (x place)
`(setq ,place (cons ,x ,place)))
-(defvar *package* (new))
-
-(defun intern (name)
- (let ((s (get *package* name)))
- (if s
- s
- (set *package* name (make-symbol name)))))
-
-(defun find-symbol (name)
- (get *package* name))
-
(defmacro cond (&rest clausules)
(if (null clausules)
nil
(defun char= (x y) (= x y))
+(defun <= (x y) (or (< x y) (= x y)))
+(defun >= (x y) (not (< x y)))
+
+(defun listp (x)
+ (or (consp x) (null x)))
+
(defun integerp (x)
(and (numberp x) (= (floor x) x)))
-
(defun last (x)
(if (null (cdr x))
x
((eql x (car list))
(remove x (cdr list)))
(t
- (cons (car x) (remove x (cdr list))))))
+ (cons (car list) (remove x (cdr list))))))
(defun digit-char-p (x)
- (if (and (< #\0 x) (< x #\9))
+ (if (and (<= #\0 x) (<= x #\9))
(- x #\0)
nil))
(defun parse-integer (string)
(let ((value 0)
(index 0)
- (size (string-length string)))
+ (size (length string)))
(while (< index size)
(setq value (+ (* value 10) (digit-char-p (char string index))))
- (incf index))))
+ (incf index))
+ value))
(defun every (function seq)
;; string
(let ((ret t)
(index 0)
- (size (string-length seq)))
+ (size (length seq)))
(while (and ret (< index size))
(unless (funcall function (char seq index))
- (setq ret nil)))))
+ (setq ret nil))
+ (incf index))
+ ret))
(defun eql (x y)
(eq x y))
(defun terminalp (ch)
(or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
-
(defun read-until (stream func)
(let ((string "")
(ch))
(parse-integer string)
(intern (string-upcase string))))))))
-
(defun ls-read-from-string (string)
(ls-read (make-string-stream string)))
-
;;;; Compiler
(defvar *compilation-unit-checks* '())
(push (make-binding name 'macro lambda t) *fenv*))
-
(defvar *compilations* nil)
(defun ls-compile-block (sexps env fenv)
`(push (list ',name (lambda (env fenv ,@args) ,@body))
*compilations*))
-
(define-compilation if (condition true false)
(concat "("
(ls-compile condition env fenv)
*newline*
(if rest-argument
(let ((js!rest (lookup-variable-translation rest-argument new-env)))
- (concat "var " js!rest ";" *newline*
+ (concat "var " js!rest "= false;" *newline*
"for (var i = arguments.length-1; i>="
(integer-to-string (length required-arguments))
"; i--)" *newline*
;;; Literals
+(defun escape-string (string)
+ (let ((output "")
+ (index 0)
+ (size (length string)))
+ (while (< index size)
+ (let ((ch (char string index)))
+ (when (or (char= ch #\") (char= ch #\\))
+ (setq output (concat output "\\")))
+ (when (or (char= ch #\newline))
+ (setq output (concat output "\\"))
+ (setq ch #\n))
+ (setq output (concat output (string ch))))
+ (incf index))
+ output))
+
(defun literal->js (sexp)
(cond
((null sexp) "false")
((integerp sexp) (integer-to-string sexp))
- ((stringp sexp) (concat "\"" sexp "\""))
- ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
+ ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
+ ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
((consp sexp) (concat "{car: "
(literal->js (car sexp))
", cdr: "
(let ((counter 0))
(defun literal (form)
- (if (null form)
- (literal->js form)
- (let ((var (concat "l" (integer-to-string (incf counter)))))
- (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
- var))))
+ (cond
+ ((null form)
+ (literal->js form))
+ (t
+ (let ((var (concat "l" (integer-to-string (incf counter)))))
+ (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
+ var)))))
(define-compilation quote (sexp)
(literal sexp))
(define-compilation = (x y)
(concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
+(define-compilation numberp (x)
+ (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")"))
+
+
(define-compilation mod (x y)
(concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
(define-compilation cons (x y)
(concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
+(define-compilation consp (x)
+ (concat "(function(){ var tmp = "
+ (ls-compile x env fenv)
+ "; return (typeof tmp == 'object' && 'car' in tmp);})()"))
+
(define-compilation car (x)
(concat "(" (ls-compile x env fenv) ").car"))
(define-compilation setcdr (x new)
(concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
+(define-compilation symbolp (x)
+ (concat "(function(){ var tmp = "
+ (ls-compile x env fenv)
+ "; return (typeof tmp == 'object' && 'name' in tmp); })()"))
+
(define-compilation make-symbol (name)
(concat "{name: " (ls-compile name env fenv) "}"))
(define-compilation string (x)
(concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
+(define-compilation stringp (x)
+ (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")"))
+
(define-compilation string-upcase (x)
(concat "(" (ls-compile x env fenv) ").toUpperCase()"))
", ")
")"))
+(define-compilation apply (func &rest args)
+ (if (null args)
+ (concat "(" (ls-compile func env fenv) ")()")
+ (let ((args (butlast args))
+ (last (car (last args))))
+ (concat "function(){" *newline*
+ "var f = " (ls-compile func env fenv) ";" *newline*
+ "var args = [" (join (mapcar (lambda (x)
+ (ls-compile x env fenv))
+ args)
+ ", ")
+ "];" *newline*
+ "var tail = (" (ls-compile last env fenv) ");" *newline*
+ "while (tail != false){" *newline*
+ " args.push(tail[0]);" *newline*
+ " args = args.slice(1);" *newline*
+ "}" *newline*
+ "return f.apply(this, args);" *newline*
+ "}" *newline*))))
+
+(define-compilation js-eval (string)
+ (concat "eval(" (ls-compile string env fenv) ")"))
+
+
(define-compilation error (string)
(concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
(defun macrop (x)
(and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
-(defun ls-macroexpand-1 (form &optional env fenv)
+(defun ls-macroexpand-1 (form env fenv)
(when (macrop (car form))
(let ((binding (lookup-function (car form) *env*)))
(if (eq (binding-type binding) 'macro)
(t
(error (concat "Invalid function designator " (symbol-name function))))))
-(defun ls-compile (sexp &optional env fenv)
+(defun ls-compile (sexp env fenv)
(cond
((symbolp sexp) (lookup-variable-translation sexp env))
((integerp sexp) (integer-to-string sexp))
- ((stringp sexp) (concat "\"" sexp "\""))
+ ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
((listp sexp)
(if (assoc (car sexp) *compilations*)
(let ((comp (second (assoc (car sexp) *compilations*))))
(defun ls-compile-toplevel (sexp)
(setq *toplevel-compilations* nil)
- (let ((code (ls-compile sexp)))
+ (let ((code (ls-compile sexp nil nil)))
(prog1
- (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
- *toplevel-compilations*)
- "")
- code)
+ (join (mapcar (lambda (x) (concat x ";" *newline*))
+ *toplevel-compilations*)
+ "")
+ code
(setq *toplevel-compilations* nil))))
+(defmacro with-compilation-unit (&rest body)
+ `(progn
+ (setq *compilation-unit-checks* nil)
+ ,@body
+ (dolist (check *compilation-unit-checks*)
+ (funcall check))
+ (setq *compilation-unit-checks* nil)))
+
+
+#+common-lisp
+(progn
+ (defun read-whole-file (filename)
+ (with-open-file (in filename)
+ (let ((seq (make-array (file-length in) :element-type 'character)))
+ (read-sequence seq in)
+ seq)))
+
+ (defun ls-compile-file (filename output)
+ (setq *env* nil *fenv* nil)
+ (setq *compilation-unit-checks* nil)
+ (with-open-file (out output :direction :output :if-exists :supersede)
+ (let* ((source (read-whole-file filename))
+ (in (make-string-stream source)))
+ (loop
+ for x = (ls-read in)
+ until (eq x *eof*)
+ for compilation = (ls-compile-toplevel x)
+ when (plusp (length compilation))
+ do (write-line (concat compilation "; ") out))
+ (dolist (check *compilation-unit-checks*)
+ (funcall check))
+ (setq *compilation-unit-checks* nil))))
+
+ (defun bootstrap ()
+ (ls-compile-file "lispstrack.lisp" "lispstrack.js")))
+
+
+
(defun eval (x)
(js-eval (ls-compile x nil nil)))
+
+
+(debug (ls-compile 't nil nil))
projects / jscl.git / blobdiff