`(eval-when-compile
(%compile-defmacro ',name '(lambda ,args ,@body))))))
- (defmacro defvar (name value)
+ (defmacro %defvar (name value)
`(progn
(eval-when-compile
(%compile-defvar ',name))
(setq ,name ,value)))
- (defmacro defun (name args &rest body)
+ (defmacro defvar (name &optional value)
+ `(%defvar ,name ,value))
+
+ (defmacro %defun (name args &rest body)
`(progn
(eval-when-compile
(%compile-defun ',name))
(fsetq ,name (lambda ,args ,@body))))
+ (defmacro defun (name args &rest body)
+ `(%defun ,name ,args ,@body))
+
(defvar *package* (new))
(defvar nil (make-symbol "NIL"))
(defun find-symbol (name)
(get *package* name))
- (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))))))
-
+ ;; Basic functions
(defun = (x y) (= x y))
(defun + (x y) (+ x y))
(defun - (x y) (- x y))
(defun 1+ (x) (+ x 1))
(defun 1- (x) (- x 1))
(defun zerop (x) (= x 0))
- (defun not (x) (if x nil t))
-
(defun truncate (x y) (floor (/ x y)))
+ (defun eql (x y) (eq x y))
+
+ (defun not (x) (if x nil t))
+
(defun cons (x y ) (cons x y))
(defun consp (x) (consp x))
-
(defun car (x) (car x))
(defun cdr (x) (cdr x))
-
(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdddr (x) (cdr (cdr (cdr x))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
-
(defun first (x) (car x))
(defun second (x) (cadr x))
(defun third (x) (caddr x))
(defun fourth (x) (cadddr x))
- (defun list (&rest args)
- args)
-
+ (defun list (&rest args) args)
(defun atom (x)
- (not (consp x))))
+ (not (consp x)))
+
+ ;; Basic macros
+
+ (defmacro incf (x &optional (delta 1))
+ `(setq ,x (+ ,x ,delta)))
+
+ (defmacro decf (x &optional (delta 1))
+ `(setq ,x (- ,x ,delta)))
+
+ (defmacro push (x place)
+ `(setq ,place (cons ,x ,place)))
+
+ (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))))))
+
+ (defmacro cond (&rest clausules)
+ (if (null clausules)
+ nil
+ (if (eq (caar clausules) t)
+ `(progn ,@(cdar clausules))
+ `(if ,(caar clausules)
+ (progn ,@(cdar clausules))
+ (cond ,@(cdr clausules))))))
+
+ (defmacro case (form &rest clausules)
+ (let ((!form (make-symbol "FORM")))
+ `(let ((,!form ,form))
+ (cond
+ ,@(mapcar (lambda (clausule)
+ (if (eq (car clausule) t)
+ clausule
+ `((eql ,!form ,(car clausule))
+ ,@(cdr clausule))))
+ clausules)))))
+
+ (defmacro ecase (form &rest clausules)
+ `(case ,form
+ ,@(append
+ clausules
+ `((t
+ (error "ECASE expression failed."))))))
+
+ (defmacro and (&rest forms)
+ (cond
+ ((null forms)
+ t)
+ ((null (cdr forms))
+ (car forms))
+ (t
+ `(if ,(car forms)
+ (and ,@(cdr forms))
+ nil))))
+ (defmacro or (&rest forms)
+ (cond
+ ((null forms)
+ nil)
+ ((null (cdr forms))
+ (car forms))
+ (t
+ (let ((g (make-symbol "VAR")))
+ `(let ((,g ,(car forms)))
+ (if ,g ,g (or ,@(cdr forms))))))))
+
+ (defmacro prog1 (form &rest body)
+ (let ((value (make-symbol "VALUE")))
+ `(let ((,value ,form))
+ ,@body
+ ,value))))
+
+;;; This couple of helper functions will be defined in both Common
+;;; Lisp and in Lispstrack.
(defun ensure-list (x)
(if (listp x)
x
(cdr list)
(funcall func initial (car list)))))
+;;; Go on growing the Lisp language in Lispstrack, with more high
+;;; level utilities as well as correct versions of other
+;;; constructions.
#+lispstrack
(progn
+ (defmacro defun (name args &rest body)
+ `(progn
+ (%defun ,name ,args ,@body)
+ ',name))
+
+ (defmacro defvar (name &optional value)
+ `(progn
+ (%defvar ,name ,value)
+ ',name))
+
(defun append-two (list1 list2)
(if (null list1)
list2
(defun reverse (list)
(reverse-aux list '()))
- (defmacro incf (x)
- `(setq ,x (1+ ,x)))
-
- (defmacro decf (x)
- `(setq ,x (1- ,x)))
-
(defun list-length (list)
(let ((l 0))
(while (not (null list))
(string-length seq)
(list-length seq)))
+ (defun concat-two (s1 s2)
+ (concat-two s1 s2))
+
(defun mapcar (func list)
(if (null list)
'()
(cons (funcall func (car list))
(mapcar func (cdr list)))))
- (defmacro push (x place)
- `(setq ,place (cons ,x ,place)))
-
- (defmacro cond (&rest clausules)
- (if (null clausules)
- nil
- (if (eq (caar clausules) t)
- `(progn ,@(cdar clausules))
- `(if ,(caar clausules)
- (progn ,@(cdar clausules))
- (cond ,@(cdr clausules))))))
-
- (defmacro case (form &rest clausules)
- (let ((!form (make-symbol "FORM")))
- `(let ((,!form ,form))
- (cond
- ,@(mapcar (lambda (clausule)
- (if (eq (car clausule) t)
- clausule
- `((eql ,!form ,(car clausule))
- ,@(cdr clausule))))
- clausules)))))
-
- (defmacro ecase (form &rest clausules)
- `(case ,form
- ,@(append
- clausules
- `((t
- (error "ECASE expression failed."))))))
-
(defun code-char (x) x)
(defun char-code (x) x)
(defun char= (x y) (= x y))
- (defmacro and (&rest forms)
- (cond
- ((null forms)
- t)
- ((null (cdr forms))
- (car forms))
- (t
- `(if ,(car forms)
- (and ,@(cdr forms))
- nil))))
-
- (defmacro or (&rest forms)
- (cond
- ((null forms)
- nil)
- ((null (cdr forms))
- (car forms))
- (t
- (let ((g (make-symbol "VAR")))
- `(let ((,g ,(car forms)))
- (if ,g ,g (or ,@(cdr forms))))))))
-
- (defmacro prog1 (form &rest body)
- (let ((value (make-symbol "VALUE")))
- `(let ((,value ,form))
- ,@body
- ,value)))
-
(defun <= (x y) (or (< x y) (= x y)))
(defun >= (x y) (not (< x y)))
+ (defun integerp (x)
+ (and (numberp x) (= (floor x) x)))
+
+ (defun plusp (x) (< 0 x))
+ (defun minusp (x) (< x 0))
+
(defun listp (x)
(or (consp x) (null x)))
- (defun integerp (x)
- (and (numberp x) (= (floor x) x)))
+ (defun nth (n list)
+ (cond
+ ((null list) list)
+ ((zerop n) (car list))
+ (t (nth (1- n) (cdr list)))))
(defun last (x)
(if (null (cdr x))
(incf index))
ret))
- (defun eql (x y)
- (eq x y))
-
(defun assoc (x alist)
(cond
((null alist)
(defvar *newline* (string (code-char 10)))
(defun concat (&rest strs)
- (!reduce (lambda (s1 s2) (concat-two s1 s2))
- strs
- ""))
+ (!reduce #'concat-two strs ""))
;;; Concatenate a list of strings, with a separator
-(defun join (list separator)
+(defun join (list &optional (separator ""))
(cond
((null list)
"")
separator
(join (cdr list) separator)))))
-(defun join-trailing (list separator)
+(defun join-trailing (list &optional (separator ""))
(if (null list)
""
(concat (car list) separator (join-trailing (cdr list) separator))))
(defun integer-to-string (x)
- (if (zerop x)
- "0"
- (let ((digits nil))
- (while (not (zerop x))
- (push (mod x 10) digits)
- (setq x (truncate x 10)))
- (join (mapcar (lambda (d) (string (char "0123456789" d)))
- digits)
- ""))))
-
+ (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)))
+ (join (mapcar (lambda (d) (string (char "0123456789" d)))
+ digits))))))
+
+(defun print-to-string (form)
+ (cond
+ ((symbolp form) (symbol-name form))
+ ((integerp form) (integer-to-string form))
+ ((stringp form) (concat "\"" (escape-string form) "\""))
+ ((functionp form) (concat "#<FUNCTION>"))
+ ((listp form)
+ (concat "("
+ (join (mapcar #'print-to-string form)
+ " ")
+ ")"))))
;;;; Reader
(setq ch (%read-char stream)))
string))
+(defun read-sharp (stream)
+ (%read-char stream)
+ (ecase (%read-char stream)
+ (#\'
+ (list 'function (ls-read stream)))
+ (#\\
+ (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 "lispstrack")
+ (ls-read stream))
+ (t
+ (error "Unknown reader form.")))))))
+
(defvar *eof* (make-symbol "EOF"))
(defun ls-read (stream)
(skip-whitespaces-and-comments stream)
(progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
(list 'unquote (ls-read stream))))
((char= ch #\#)
- (%read-char stream)
- (ecase (%read-char stream)
- (#\'
- (list 'function (ls-read stream)))
- (#\\
- (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 "lispstrack")
- (ls-read stream))
- (t
- (error "Unknown reader form.")))))))
+ (read-sharp stream))
(t
(let ((string (read-until stream #'terminalp)))
(if (every #'digit-char-p string)
(defun ls-compile-block (sexps env fenv)
(join-trailing
- (remove nil (mapcar (lambda (x)
- (ls-compile x env fenv))
- sexps))
- ";
-"))
+ (remove-if (lambda (x)
+ (or (null x)
+ (and (stringp x)
+ (zerop (length x)))))
+ (mapcar (lambda (x) (ls-compile x env fenv)) sexps))
+ (concat ";" *newline*)))
+
(defmacro define-compilation (name args &rest body)
;; Creates a new primitive `name' with parameters args and
;; @body. The body can access to the local environment through the
(ls-compile false env fenv)
")"))
-;;; Return the required args of a lambda list
-(defun lambda-list-required-argument (lambda-list)
- (if (or (null lambda-list) (eq (car lambda-list) '&rest))
+
+(defvar *lambda-list-keywords* '(&optional &rest))
+
+(defun list-until-keyword (list)
+ (if (or (null list) (member (car list) *lambda-list-keywords*))
nil
- (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
+ (cons (car list) (list-until-keyword (cdr list)))))
+
+(defun lambda-list-required-arguments (lambda-list)
+ (list-until-keyword lambda-list))
+
+(defun lambda-list-optional-arguments-with-default (lambda-list)
+ (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list)))))
+
+(defun lambda-list-optional-arguments (lambda-list)
+ (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list)))
(defun lambda-list-rest-argument (lambda-list)
- (second (member '&rest lambda-list)))
+ (let ((rest (list-until-keyword (cdr (member '&rest lambda-list)))))
+ (when (cdr rest)
+ (error "Bad lambda-list"))
+ (car rest)))
(define-compilation lambda (lambda-list &rest body)
- (let ((required-arguments (lambda-list-required-argument lambda-list))
+ (let ((required-arguments (lambda-list-required-arguments lambda-list))
+ (optional-arguments (lambda-list-optional-arguments lambda-list))
(rest-argument (lambda-list-rest-argument lambda-list)))
- (let ((new-env (extend-local-env
- (append (and rest-argument (list rest-argument))
- required-arguments)
+ (let ((n-required-arguments (length required-arguments))
+ (n-optional-arguments (length optional-arguments))
+ (new-env (extend-local-env
+ (append (ensure-list rest-argument)
+ required-arguments
+ optional-arguments)
env)))
(concat "(function ("
(join (mapcar (lambda (x)
(lookup-variable-translation x new-env))
- required-arguments)
+ (append required-arguments optional-arguments))
",")
- "){"
- *newline*
+ "){" *newline*
+ ;; Check number of arguments
+ (if required-arguments
+ (concat "if (arguments.length < " (integer-to-string n-required-arguments)
+ ") throw 'too few arguments';" *newline*)
+ "")
+ (if (not rest-argument)
+ (concat "if (arguments.length > "
+ (integer-to-string (+ n-required-arguments n-optional-arguments))
+ ") throw 'too many arguments';" *newline*)
+ "")
+ ;; Optional arguments
+ (if optional-arguments
+ (concat "switch(arguments.length){" *newline*
+ (let ((optional-and-defaults
+ (lambda-list-optional-arguments-with-default lambda-list))
+ (cases nil)
+ (idx 0))
+ (progn (while (< idx n-optional-arguments)
+ (let ((arg (nth idx optional-and-defaults)))
+ (push (concat "case "
+ (integer-to-string (+ idx n-required-arguments)) ":" *newline*
+ (lookup-variable-translation (car arg) new-env)
+ "="
+ (ls-compile (cadr arg) new-env fenv)
+ ";" *newline*)
+ cases)
+ (incf idx)))
+ (push (concat "default: break;" *newline*) cases)
+ (join (reverse cases))))
+ "}" *newline*)
+ "")
+ ;; &rest argument
(if rest-argument
(let ((js!rest (lookup-variable-translation rest-argument new-env)))
(concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
"for (var i = arguments.length-1; i>="
- (integer-to-string (length required-arguments))
+ (integer-to-string (+ n-required-arguments n-optional-arguments))
"; i--)" *newline*
js!rest " = "
"{car: arguments[i], cdr: " js!rest "};"
*newline*))
"")
+ ;; Body
(concat (ls-compile-block (butlast body) new-env fenv)
"return " (ls-compile (car (last body)) new-env fenv) ";")
- *newline*
- "})"))))
+ *newline* "})"))))
(define-compilation fsetq (var val)
(concat (lookup-function-translation var fenv)
(define-compilation eval-when-compile (&rest body)
(eval (cons 'progn body))
- nil)
+ "")
(defmacro define-transformation (name args form)
`(define-compilation ,name ,args
(ls-compile ,form env fenv)))
-(define-transformation progn (&rest body)
- `((lambda () ,@body)))
+(define-compilation progn (&rest body)
+ (concat "(function(){" *newline*
+ (ls-compile-block (butlast body) env fenv)
+ "return " (ls-compile (car (last body)) env fenv) ";"
+ "})()" *newline*))
(define-transformation let (bindings &rest body)
(let ((bindings (mapcar #'ensure-list bindings)))
"; return (typeof tmp == 'object' && 'name' in tmp); })()")))
(define-compilation make-symbol (name)
- (concat "{name: " (ls-compile name env fenv) "}"))
+ (concat "({name: " (ls-compile name env fenv) "})"))
(define-compilation symbol-name (x)
(concat "(" (ls-compile x env fenv) ").name"))
(compile-bool
(concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
+(define-compilation functionp (x)
+ (compile-bool
+ (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
+
+
(defun macrop (x)
(and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
(setq *toplevel-compilations* nil)
(let ((code (ls-compile sexp nil nil)))
(prog1
- (concat #+common-lisp (concat "/* " (princ-to-string sexp) " */")
- (join (mapcar (lambda (x) (concat x ";" *newline*))
- *toplevel-compilations*)
- "")
+ (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
+ *toplevel-compilations*))
code)
(setq *toplevel-compilations* nil))))
(defun eval (x)
(let ((code
(with-compilation-unit
- (ls-compile-toplevel x nil nil))))
+ (ls-compile-toplevel x))))
(js-eval code)))
;; Set the initial global environment to be equal to the host global
(js-eval
(concat "var lisp = {};"
"lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
+ "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
"lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
"lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
"lisp.evalString = function(str){" *newline*
projects / jscl.git / blobdiff