X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=9fd5cbaadb73e7cc09bbbb7a7d9df09d4cf899af;hb=a492f6e21f55974a21f2f8ec5ccf105fb3f1a832;hp=1984aaa0f7a36bf6786202d68293e0e058629961;hpb=4f0da09c413d372fed781990bdda736e2b0f68e3;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 1984aaa..9fd5cba 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -52,7 +52,7 @@
 
   (defconstant t 't)
   (defconstant nil 'nil)
-  (js-vset "nil" nil)
+  (%js-vset "nil" nil)
 
   (defmacro lambda (args &body body)
     `(function (lambda ,args ,@body)))
@@ -270,6 +270,18 @@
                (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.
@@ -371,18 +383,6 @@
   (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
@@ -457,6 +457,11 @@
         (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)
@@ -533,6 +538,14 @@
         (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))
@@ -818,9 +831,18 @@
                   (oset symbol "value" symbol)
                   (export (list symbol) package))
 		(when (eq package (find-package "JS"))
-		  (let ((sym-name (symbol-name symbol)))
-		    (fset symbol (lambda (&rest args)
-				   (%js-call sym-name args)))))
+		  (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)))))))
 
@@ -865,8 +887,13 @@
 
 (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))))
@@ -965,7 +992,9 @@
                        "()"
                        (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)
@@ -1122,40 +1151,48 @@
     (setq package (find-package package))
     ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
     ;; external symbol from PACKAGE.
-    (if (or internalp (or (eq package (find-package "KEYWORD"))
-			  (eq package (find-package "JS"))))
-	(intern name package)
-	(find-symbol name 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))
-      (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)
@@ -1266,48 +1303,93 @@
 ;;; 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))
 
@@ -1322,7 +1404,7 @@
 (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
@@ -1339,12 +1421,12 @@
 
 (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)))
 
@@ -1357,15 +1439,15 @@
     (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)
@@ -1600,22 +1682,16 @@
        "})"))))
 
 
-
 (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)))))
 
 
-;; receives the js function as first param and its arguments as a
-;; list.
-(define-compilation %js-call (fun args)
-  (let ((evaled-args (mapcar #'ls-compile args)))
-    (code fun "(" (join evaled-args ", ") ")")))
-
 (define-compilation setq (&rest pairs)
   (let ((result ""))
     (while t
@@ -1630,13 +1706,6 @@
 	 (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)
@@ -1727,14 +1796,14 @@
 
 
 (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))
@@ -1843,7 +1912,7 @@
     (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))))))
 
@@ -1886,9 +1955,9 @@
 
 (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))
@@ -1912,7 +1981,7 @@
          (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 ({"
@@ -1959,7 +2028,7 @@
   (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)))
 
@@ -2054,6 +2123,14 @@
     "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
@@ -2648,11 +2725,18 @@
       (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))))
@@ -2667,7 +2751,7 @@
               ;; 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)))
@@ -2702,7 +2786,7 @@
            ((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))))))
@@ -2729,6 +2813,14 @@
       (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
@@ -2738,6 +2830,12 @@
                            (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*))
@@ -2779,13 +2877,13 @@
   (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.
@@ -2797,7 +2895,7 @@
     (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*)
@@ -2821,8 +2919,9 @@
         (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))
@@ -2841,4 +2940,4 @@
           *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)))