(defconstant t 't)
(defconstant nil 'nil)
- (js-vset "nil" nil)
+ (%js-vset "nil" nil)
(defmacro lambda (args &body body)
`(function (lambda ,args ,@body)))
(cdr list)
:initial-value (funcall func initial-value (car list)))))
+(defmacro with-collect (&body body)
+ (let ((head (gensym))
+ (tail (gensym)))
+ `(let* ((,head (cons 'sentinel nil))
+ (,tail ,head))
+ (flet ((collect (x)
+ (rplacd ,tail (cons x nil))
+ (setq ,tail (cdr ,tail))
+ x))
+ ,@body)
+ (cdr ,head))))
+
;;; Go on growing the Lisp language in Ecmalisp, with more high
;;; level utilities as well as correct versions of other
;;; constructions.
(defun concat-two (s1 s2)
(concat-two s1 s2))
- (defmacro with-collect (&body body)
- (let ((head (gensym))
- (tail (gensym)))
- `(let* ((,head (cons 'sentinel nil))
- (,tail ,head))
- (flet ((collect (x)
- (rplacd ,tail (cons x nil))
- (setq ,tail (cdr ,tail))
- x))
- ,@body)
- (cdr ,head))))
-
(defun map1 (func list)
(with-collect
(while list
(return list))
(setq list (cdr list))))
+ (defun find (item list &key key (test #'eql))
+ (dolist (x list)
+ (when (funcall test (funcall key x) item)
+ (return x))))
+
(defun remove (x list)
(cond
((null list)
(return-from every nil)))
t)
+ (defun position (elt sequence)
+ (let ((pos 0))
+ (do-sequence (x seq)
+ (when (eq elt x)
+ (return))
+ (incf pos))
+ pos))
+
(defun assoc (x alist)
(while alist
(if (eql x (caar alist))
(oset symbol "value" symbol)
(export (list symbol) package))
(when (eq package (find-package "JS"))
- (in-package :js
- `(defun ,symbol (args)
- (apply #'%js-call ,(symbol-name symbol)
- args)))
- (export (list symbol) package))
+ (let ((sym-name (symbol-name symbol))
+ (args (gensym)))
+ ;; Generate a trampoline to call the JS function
+ ;; properly. This trampoline is very inefficient,
+ ;; but it still works. Ideas to optimize this are
+ ;; provide a special lambda keyword
+ ;; cl::&rest-vector to avoid list argument
+ ;; consing, as well as allow inline declarations.
+ (fset symbol
+ (eval `(lambda (&rest ,args)
+ (let ((,args (list-to-vector ,args)))
+ (%js-call (%js-vref ,sym-name) ,args)))))))
(oset symbols name symbol)
(values symbol nil)))))))
(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))))
"()"
(prin1-to-string (vector-to-list form)))))
((packagep form)
- (concat "#<PACKAGE " (package-name form) ">"))))
+ (concat "#<PACKAGE " (package-name form) ">"))
+ (t
+ (concat "#<javascript object>"))))
(defun write-line (x)
(write-string x)
(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 (or (find-package "KEYWORD")
- (find-package "JS"))))
+ (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))
- (when (zerop size) (return (values nil 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)))
+ (#\+ (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)))
+ (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)))
+ (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)
- (char= (char string index) #\space))
- (values (* sign value) index)
- (values nil index)))))
+ (= index size))
+ (values (* sign value) index)
+ (values nil index)))))
#+ecmalisp
(defun parse-integer (string)
;;; function call.
(defvar *multiple-value-p* nil)
-(defun make-binding (name type value &optional declarations)
- (list name type value declarations))
-
-(defun binding-name (b) (first b))
-(defun binding-type (b) (second b))
-(defun binding-value (b) (third b))
-(defun binding-declarations (b) (fourth b))
-
-(defun set-binding-value (b value)
- (rplaca (cddr b) value))
-
-(defun set-binding-declarations (b value)
- (rplaca (cdddr b) value))
-
-(defun push-binding-declaration (decl b)
- (set-binding-declarations b (cons decl (binding-declarations b))))
-
-
-(defun make-lexenv ()
- (list nil nil nil nil))
+;; A very simple defstruct built on lists. It supports just slot with
+;; an optional default initform, and it will create a constructor,
+;; predicate and accessors for you.
+(defmacro def!struct (name &rest slots)
+ (unless (symbolp name)
+ (error "It is not a full defstruct implementation."))
+ (let* ((name-string (symbol-name name))
+ (slot-descriptions
+ (mapcar (lambda (sd)
+ (cond
+ ((symbolp sd)
+ (list sd))
+ ((and (listp sd) (car sd) (cddr sd))
+ sd)
+ (t
+ (error "Bad slot accessor."))))
+ slots))
+ (predicate (intern (concat name-string "-P"))))
+ `(progn
+ ;; Constructor
+ (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
+ (list ',name ,@(mapcar #'car slot-descriptions)))
+ ;; Predicate
+ (defun ,predicate (x)
+ (and (consp x) (eq (car x) ',name)))
+ ;; Copier
+ (defun ,(intern (concat "COPY-" name-string)) (x)
+ (copy-list x))
+ ;; Slot accessors
+ ,@(with-collect
+ (let ((index 1))
+ (dolist (slot slot-descriptions)
+ (let* ((name (car slot))
+ (accessor-name (intern (concat name-string "-" (string name)))))
+ (collect
+ `(defun ,accessor-name (x)
+ (unless (,predicate x)
+ (error ,(concat "The object is not a type " name-string)))
+ (nth ,index x)))
+ ;; TODO: Implement this with a higher level
+ ;; abstraction like defsetf or (defun (setf ..))
+ (collect
+ `(define-setf-expander ,accessor-name (x)
+ (let ((object (gensym))
+ (new-value (gensym)))
+ (values (list object)
+ (list x)
+ (list new-value)
+ `(progn
+ (rplaca (nthcdr ,',index ,object) ,new-value)
+ ,new-value)
+ `(,',accessor-name ,object)))))
+ (incf index)))))
+ ',name)))
+
+(def!struct binding
+ name
+ type
+ value
+ declarations)
+
+(def!struct lexenv
+ variable
+ function
+ block
+ gotag)
-(defun copy-lexenv (lexenv)
- (copy-list lexenv))
+(defun lookup-in-lexenv (name lexenv namespace)
+ (find name (ecase namespace
+ (variable (lexenv-variable lexenv))
+ (function (lexenv-function lexenv))
+ (block (lexenv-block lexenv))
+ (gotag (lexenv-gotag lexenv)))
+ :key #'binding-name))
(defun push-to-lexenv (binding lexenv namespace)
(ecase namespace
- (variable (rplaca lexenv (cons binding (car lexenv))))
- (function (rplaca (cdr lexenv) (cons binding (cadr lexenv))))
- (block (rplaca (cddr lexenv) (cons binding (caddr lexenv))))
- (gotag (rplaca (cdddr lexenv) (cons binding (cadddr lexenv))))))
+ (variable (push binding (lexenv-variable lexenv)))
+ (function (push binding (lexenv-function lexenv)))
+ (block (push binding (lexenv-block lexenv)))
+ (gotag (push binding (lexenv-gotag lexenv)))))
(defun extend-lexenv (bindings lexenv namespace)
(let ((env (copy-lexenv lexenv)))
(dolist (binding (reverse bindings) env)
(push-to-lexenv binding env namespace))))
-(defun lookup-in-lexenv (name lexenv namespace)
- (assoc name (ecase namespace
- (variable (first lexenv))
- (function (second lexenv))
- (block (third lexenv))
- (gotag (fourth lexenv)))))
(defvar *environment* (make-lexenv))
(defun extend-local-env (args)
(let ((new (copy-lexenv *environment*)))
(dolist (symbol args new)
- (let ((b (make-binding symbol 'variable (gvarname symbol))))
+ (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
(push-to-lexenv b new 'variable)))))
;;; Toplevel compilations
(defun %compile-defmacro (name lambda)
(toplevel-compilation (ls-compile `',name))
- (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function)
+ (push-to-lexenv (make-binding :name name :type 'macro :value lambda) *environment* 'function)
name)
(defun global-binding (name type namespace)
(or (lookup-in-lexenv name *environment* namespace)
- (let ((b (make-binding name type nil)))
+ (let ((b (make-binding :name name :type type :value nil)))
(push-to-lexenv b *environment* namespace)
b)))
(special
(dolist (name (cdr decl))
(let ((b (global-binding name 'variable 'variable)))
- (push-binding-declaration 'special b))))
+ (push 'special (binding-declarations b)))))
(notinline
(dolist (name (cdr decl))
(let ((b (global-binding name 'function 'function)))
- (push-binding-declaration 'notinline b))))
+ (push 'notinline (binding-declarations b)))))
(constant
(dolist (name (cdr decl))
(let ((b (global-binding name 'variable 'variable)))
- (push-binding-declaration 'constant b))))))
+ (push 'constant (binding-declarations b)))))))
#+ecmalisp
(fset 'proclaim #'!proclaim)
"})"))))
-
(defun setq-pair (var val)
(let ((b (lookup-in-lexenv var *environment* 'variable)))
- (if (and (eq (binding-type b) 'variable)
+ (if (and (binding-p b)
+ (eq (binding-type b) 'variable)
(not (member 'special (binding-declarations b)))
(not (member 'constant (binding-declarations b))))
(code (binding-value b) " = " (ls-compile val))
(ls-compile `(set ',var ,val)))))
-(define-compilation %js-call (fun &rest args)
- (let ((evaled-args (mapcar #'ls-compile args)))
- (code fun "(" (join evaled-args ", ") ")")))
-
(define-compilation setq (&rest pairs)
(let ((result ""))
(while t
(setq pairs (cddr pairs)))))
(code "(" result ")")))
-;;; FFI Variable accessors
-(define-compilation js-vref (var)
- var)
-
-(define-compilation js-vset (var val)
- (code "(" var " = " (ls-compile val) ")"))
-
;;; Literals
(defun escape-string (string)
(defun make-function-binding (fname)
- (make-binding fname 'function (gvarname fname)))
+ (make-binding :name fname :type 'function :value (gvarname fname)))
(defun compile-function-definition (list)
(compile-lambda (car list) (cdr list)))
(defun translate-function (name)
(let ((b (lookup-in-lexenv name *environment* 'function)))
- (binding-value b)))
+ (and b (binding-value b))))
(define-compilation flet (definitions &rest body)
(let* ((fnames (mapcar #'car definitions))
(if (special-variable-p var)
(code (ls-compile `(setq ,var ,value)) ";" *newline*)
(let* ((v (gvarname var))
- (b (make-binding var 'variable v)))
+ (b (make-binding :name var :type 'variable :value v)))
(prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
(push-to-lexenv b *environment* 'variable))))))
(define-compilation block (name &rest body)
(let* ((tr (incf *block-counter*))
- (b (make-binding name 'block tr)))
+ (b (make-binding :name name :type 'block :value tr)))
(when *multiple-value-p*
- (push-binding-declaration 'multiple-value b))
+ (push 'multiple-value (binding-declarations b)))
(let* ((*environment* (extend-lexenv (list b) *environment* 'block))
(cbody (ls-compile-block body t)))
(if (member 'used (binding-declarations b))
(multiple-value-p (member 'multiple-value (binding-declarations b))))
(when (null b)
(error (concat "Unknown block `" (symbol-name name) "'.")))
- (push-binding-declaration 'used b)
+ (push 'used (binding-declarations b))
(js!selfcall
(when multiple-value-p (code "var values = mv;" *newline*))
"throw ({"
(let ((bindings
(mapcar (lambda (label)
(let ((tagidx (integer-to-string (incf *go-tag-counter*))))
- (make-binding label 'gotag (list tbidx tagidx))))
+ (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
(remove-if-not #'go-tag-p body))))
(extend-lexenv bindings *environment* 'gotag)))
"return args;" *newline*))
+;;; Javascript FFI
+
+(define-compilation %js-vref (var) var)
+
+(define-compilation %js-vset (var val)
+ (code "(" var " = " (ls-compile val) ")"))
+
+
;;; Backquote implementation.
;;;
;;; Author: Guy L. Steele Jr. Date: 27 December 1985
(code "values(" (join (mapcar #'ls-compile args) ", ") ")")
(code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
+;; Receives the JS function as first argument as a literal string. The
+;; second argument is compiled and should evaluate to a vector of
+;; values to apply to the the function. The result returned.
+(define-builtin %js-call (fun args)
+ (code fun ".apply(this, " args ")"))
+
(defun macro (x)
(and (symbolp x)
(let ((b (lookup-in-lexenv x *environment* 'function)))
- (and (eq (binding-type b) 'macro)
- b))))
+ (if (and b (eq (binding-type b) 'macro))
+ b
+ nil))))
(defun ls-macroexpand-1 (form)
(let ((macro-binding (macro (car form))))
;; us replace the list representation version of the
;; function with the compiled one.
;;
- #+ecmalisp (set-binding-value macro-binding compiled)
+ #+ecmalisp (setf (binding-value macro-binding) compiled)
(setq expander compiled)))
(apply expander (cdr form)))
form)))
((and b (not (member 'special (binding-declarations b))))
(binding-value b))
((or (keywordp sexp)
- (member 'constant (binding-declarations b)))
+ (and b (member 'constant (binding-declarations b))))
(code (ls-compile `',sexp) ".value"))
(t
(ls-compile `(symbol-value ',sexp))))))
(t
(error (concat "How should I compile " (prin1-to-string sexp) "?"))))))
+
+(defvar *compile-print-toplevels* nil)
+
+(defun truncate-string (string &optional (width 60))
+ (let ((n (or (position #\newline string)
+ (min width (length string)))))
+ (subseq string 0 n)))
+
(defun ls-compile-toplevel (sexp &optional multiple-value-p)
(let ((*toplevel-compilations* nil))
(cond
(cdr sexp))))
(join (remove-if #'null-or-empty-p subs))))
(t
+ (when *compile-print-toplevels*
+ (let ((form-string (prin1-to-string sexp)))
+ (write-string "Compiling ")
+ (write-string (truncate-string form-string))
+ (write-line "...")))
+
(let ((code (ls-compile sexp multiple-value-p)))
(code (join-trailing (get-toplevel-compilations)
(code ";" *newline*))
(setq *package* *user-package*)
(js-eval "var lisp")
- (js-vset "lisp" (new))
- (js-vset "lisp.read" #'ls-read-from-string)
- (js-vset "lisp.print" #'prin1-to-string)
- (js-vset "lisp.eval" #'eval)
- (js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t)))
- (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
- (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))
+ (%js-vset "lisp" (new))
+ (%js-vset "lisp.read" #'ls-read-from-string)
+ (%js-vset "lisp.print" #'prin1-to-string)
+ (%js-vset "lisp.eval" #'eval)
+ (%js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t)))
+ (%js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
+ (%js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))
;; Set the initial global environment to be equal to the host global
;; environment at this point of the compilation.
(toplevel-compilation
(ls-compile
`(progn
- ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))
+ ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
*literal-symbols*)
(setq *literal-symbols* ',*literal-symbols*)
(setq *variable-counter* ,*variable-counter*)
(read-sequence seq in)
seq)))
- (defun ls-compile-file (filename output)
- (let ((*compiling-file* t))
+ (defun ls-compile-file (filename output &key print)
+ (let ((*compiling-file* t)
+ (*compile-print-toplevels* print))
(with-open-file (out output :direction :output :if-exists :supersede)
(write-string (read-whole-file "prelude.js") out)
(let* ((source (read-whole-file filename))
*gensym-counter* 0
*literal-counter* 0
*block-counter* 0)
- (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))
+ (ls-compile-file "ecmalisp.lisp" "ecmalisp.js" :print t)))
projects / jscl.git / blobdiff