Define lexenv with def!struct

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8b1dcd5..9fd5cba 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -52,7 +52,7 @@
 
   (defconstant t 't)
   (defconstant nil 'nil)
 
   (defconstant t 't)
   (defconstant nil 'nil)

-  (js-vset "nil" nil)
+  (%js-vset "nil" nil)

 
   (defmacro lambda (args &body body)
     `(function (lambda ,args ,@body)))
 
   (defmacro lambda (args &body body)
     `(function (lambda ,args ,@body)))

@@ -163,7 +163,14 @@
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)

-    `(setq ,place (cons ,x ,place)))
+    (multiple-value-bind (dummies vals newval setter getter)
+        (get-setf-expansion place)
+      (let ((g (gensym)))
+        `(let* ((,g ,x)
+                ,@(mapcar #'list dummies vals)
+                (,(car newval) (cons ,g ,getter))
+                ,@(cdr newval))
+           ,setter))))

 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))
 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))

@@ -263,6 +270,18 @@
                (cdr list)
                :initial-value (funcall func initial-value (car list)))))
 
                (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.
 ;;; Go on growing the Lisp language in Ecmalisp, with more high
 ;;; level utilities as well as correct versions of other
 ;;; constructions.

@@ -364,18 +383,6 @@
   (defun concat-two (s1 s2)
     (concat-two s1 s2))
 
   (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
   (defun map1 (func list)
     (with-collect
         (while list

@@ -450,6 +457,11 @@
         (return list))
       (setq list (cdr 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)
   (defun remove (x list)
     (cond
       ((null list)

@@ -466,6 +478,7 @@
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t

+       ;;

        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)
        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)

@@ -495,39 +508,43 @@
       (t
        (error "Unsupported argument."))))
 
       (t
        (error "Unsupported argument."))))
 

+  (defmacro do-sequence (iteration &body body)
+    (let ((seq (gensym))
+          (index (gensym)))
+      `(let ((,seq ,(second iteration)))
+         (cond
+           ;; Strings
+           ((stringp ,seq)
+            (let ((,index 0))
+              (dotimes (,index (length ,seq))
+                (let ((,(first iteration)
+                       (char ,seq ,index)))
+                  ,@body))))
+           ;; Lists
+           ((listp ,seq)
+            (dolist (,(first iteration) ,seq)
+              ,@body))
+           (t
+            (error "type-error!"))))))
+

   (defun some (function seq)
   (defun some (function seq)

-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (when (funcall function (char seq index))
-             (return-from some t))
-           (incf index))
-         nil))
-      ((listp seq)
-       (dolist (x seq nil)
-         (when (funcall function x)
-           (return t))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (when (funcall function elt)
+        (return-from some t))))

 
   (defun every (function seq)
 
   (defun every (function seq)

-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (unless (funcall function (char seq index))
-             (return-from every nil))
-           (incf index))
-         t))
-      ((listp seq)
-       (dolist (x seq t)
-         (unless (funcall function x)
-           (return))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (unless (funcall function elt)
+        (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
 
   (defun assoc (x alist)
     (while alist

@@ -645,17 +662,6 @@
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 

-<<<<<<< HEAD
-  (defmacro push (x place)
-    (multiple-value-bind (dummies vals newval setter getter)
-        (get-setf-expansion place)
-      (let ((g (gensym)))
-        `(let* ((,g ,x)
-                ,@(mapcar #'list dummies vals)
-                (,(car newval) (cons ,g ,getter))
-                ,@(cdr newval))
-           ,setter))))
-=======

   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))
   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))

@@ -705,15 +711,14 @@
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))

-         (2nd x 1st) ; 2nd follows first down the list.
-         (3rd y 2nd)) ;3rd follows 2nd down the list.
+         (2nd x 1st)                ; 2nd follows first down the list.
+         (3rd y 2nd))               ;3rd follows 2nd down the list.

         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 
   (defun notany (fn seq)
     (not (some fn seq)))
 
         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 
   (defun notany (fn seq)
     (not (some fn seq)))
 

->>>>>>> backquote

 
   ;; Packages
 
 
   ;; Packages
 

@@ -766,6 +771,9 @@
   (defvar *common-lisp-package*
     (make-package "CL"))
 
   (defvar *common-lisp-package*
     (make-package "CL"))
 

+  (defvar *js-package*
+    (make-package "JS"))
+

   (defvar *user-package*
     (make-package "CL-USER" :use (list *common-lisp-package*)))
 
   (defvar *user-package*
     (make-package "CL-USER" :use (list *common-lisp-package*)))
 

@@ -822,6 +830,19 @@
                 (when (eq package *keyword-package*)
                   (oset symbol "value" symbol)
                   (export (list symbol) package))
                 (when (eq package *keyword-package*)
                   (oset symbol "value" symbol)
                   (export (list symbol) package))

+               (when (eq package (find-package "JS"))
+                 (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)))))))
 
                 (oset symbols name symbol)
                 (values symbol nil)))))))
 

@@ -866,8 +887,13 @@
 
 (defvar *newline* (string (code-char 10)))
 
 
 (defvar *newline* (string (code-char 10)))
 

+#+ecmalisp

 (defun concat (&rest strs)
   (!reduce #'concat-two strs :initial-value ""))
 (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))))
 
 (defmacro concatf (variable &body form)
   `(setq ,variable (concat ,variable (progn ,@form))))

@@ -962,9 +988,13 @@
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)

-       (concat "#" (prin1-to-string (vector-to-list form))))
+       (concat "#" (if (zerop (length form))
+                       "()"
+                       (prin1-to-string (vector-to-list form)))))

       ((packagep form)
       ((packagep form)

-       (concat "#<PACKAGE " (package-name form) ">"))))
+       (concat "#<PACKAGE " (package-name form) ">"))
+      (t
+       (concat "#<javascript object>"))))

 
   (defun write-line (x)
     (write-string x)
 
   (defun write-line (x)
     (write-string x)

@@ -1116,11 +1146,14 @@
          (incf index))
        (setq name (subseq string index))))
     ;; Canonalize symbol name and package
          (incf index))
        (setq name (subseq string index))))
     ;; Canonalize symbol name and package

-    (setq name (string-upcase name))
+    (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.
     (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")))
+    (if (or internalp
+            (eq package (find-package "KEYWORD"))
+            (eq package (find-package "JS")))

         (intern name package)
         (find-symbol name package))))
 
         (intern name package)
         (find-symbol name package))))
 

@@ -1128,31 +1161,38 @@
 (defun !parse-integer (string junk-allow)
   (block nil
     (let ((value 0)
 (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)
       ;; 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)
       ;; 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)
       (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
       (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)
 
 #+ecmalisp
 (defun parse-integer (string)

@@ -1263,52 +1303,98 @@
 ;;; function call.
 (defvar *multiple-value-p* nil)
 
 ;;; 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
 
 (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 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))
 
 (defvar *variable-counter* 0)
 
 (defvar *environment* (make-lexenv))
 
 (defvar *variable-counter* 0)

+

 (defun gvarname (symbol)
   (code "v" (incf *variable-counter*)))
 
 (defun gvarname (symbol)
   (code "v" (incf *variable-counter*)))
 

@@ -1318,7 +1404,7 @@
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
     (dolist (symbol args new)
 (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
         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations

@@ -1335,12 +1421,12 @@
 
 (defun %compile-defmacro (name lambda)
   (toplevel-compilation (ls-compile `',name))
 
 (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)
   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)))
 
         (push-to-lexenv b *environment* namespace)
         b)))
 

@@ -1353,15 +1439,15 @@
     (special
      (dolist (name (cdr decl))
        (let ((b (global-binding name 'variable 'variable)))
     (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)))
     (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)))
     (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)
 
 #+ecmalisp
 (fset 'proclaim #'!proclaim)

@@ -1596,15 +1682,16 @@
        "})"))))
 
 
        "})"))))
 
 

-

 (defun setq-pair (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 (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)))))
 
              (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 setq (&rest pairs)
   (let ((result ""))
     (while t
 (define-compilation setq (&rest pairs)
   (let ((result ""))
     (while t

@@ -1619,13 +1706,6 @@
         (setq pairs (cddr pairs)))))
     (code "(" result ")")))
 
         (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)
 
 ;;; Literals
 (defun escape-string (string)

@@ -1716,14 +1796,14 @@
 
 
 (defun make-function-binding (fname)
 
 
 (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)))
 
 (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))
 
 (define-compilation flet (definitions &rest body)
   (let* ((fnames (mapcar #'car definitions))

@@ -1832,7 +1912,7 @@
     (if (special-variable-p var)
         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
         (let* ((v (gvarname var))
     (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))))))
 
           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
             (push-to-lexenv b *environment* 'variable))))))
 

@@ -1875,9 +1955,9 @@
 
 (define-compilation block (name &rest body)
   (let* ((tr (incf *block-counter*))
 
 (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*
     (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))
     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
            (cbody (ls-compile-block body t)))
       (if (member 'used (binding-declarations b))

@@ -1901,7 +1981,7 @@
          (multiple-value-p (member 'multiple-value (binding-declarations b))))
     (when (null b)
       (error (concat "Unknown block `" (symbol-name name) "'.")))
          (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 ({"
     (js!selfcall
       (when multiple-value-p (code "var values = mv;" *newline*))
       "throw ({"

@@ -1948,7 +2028,7 @@
   (let ((bindings
          (mapcar (lambda (label)
                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
   (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)))
 
                  (remove-if-not #'go-tag-p body))))
     (extend-lexenv bindings *environment* 'gotag)))
 

@@ -2043,6 +2123,14 @@
     "return args;" *newline*))
 
 
     "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
 ;;; Backquote implementation.
 ;;;
 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985

@@ -2637,11 +2725,18 @@
       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
 
       (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)))
 (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))))
 
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))

@@ -2656,7 +2751,7 @@
               ;; us replace the list representation version of the
               ;; function with the compiled one.
               ;;
               ;; 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)))
               (setq expander compiled)))
           (apply expander (cdr form)))
         form)))

@@ -2691,7 +2786,7 @@
            ((and b (not (member 'special (binding-declarations b))))
             (binding-value b))
            ((or (keywordp sexp)
            ((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))))))
             (code (ls-compile `',sexp) ".value"))
            (t
             (ls-compile `(symbol-value ',sexp))))))

@@ -2718,6 +2813,14 @@
       (t
        (error (concat "How should I compile " (prin1-to-string 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
 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
   (let ((*toplevel-compilations* nil))
     (cond

@@ -2727,6 +2830,12 @@
                            (cdr sexp))))
          (join (remove-if #'null-or-empty-p subs))))
       (t
                            (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*))
        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))

@@ -2768,13 +2877,13 @@
   (setq *package* *user-package*)
 
   (js-eval "var lisp")
   (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.
 
   ;; Set the initial global environment to be equal to the host global
   ;; environment at this point of the compilation.

@@ -2786,7 +2895,7 @@
     (toplevel-compilation
      (ls-compile
       `(progn
     (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*)
                    *literal-symbols*)
          (setq *literal-symbols* ',*literal-symbols*)
          (setq *variable-counter* ,*variable-counter*)

@@ -2810,8 +2919,9 @@
         (read-sequence seq in)
         seq)))
 
         (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))
       (with-open-file (out output :direction :output :if-exists :supersede)
         (write-string (read-whole-file "prelude.js") out)
         (let* ((source (read-whole-file filename))

@@ -2830,4 +2940,4 @@
           *gensym-counter* 0
           *literal-counter* 0
           *block-counter* 0)
           *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)))