Use JOIN instead of reduce/concat

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 56a70c6..286069d 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -27,16 +27,14 @@
   (eval-when-compile
     (%compile-defmacro 'defmacro
                        '(lambda (name args &rest body)
   (eval-when-compile
     (%compile-defmacro 'defmacro
                        '(lambda (name args &rest body)

-                         `(progn
-                            (eval-when-compile
-                              (%compile-defmacro ',name
-                                                 '(lambda ,(mapcar (lambda (x)
-                                                                     (if (eq x '&body)
-                                                                         '&rest
-                                                                         x))
-                                                                   args)
-                                                   ,@body)))
-                            ',name))))
+                         `(eval-when-compile
+                            (%compile-defmacro ',name
+                                               '(lambda ,(mapcar (lambda (x)
+                                                                   (if (eq x '&body)
+                                                                       '&rest
+                                                                       x))
+                                                                 args)
+                                                 ,@body))))))

 
   (setq nil 'nil)
   (setq t 't)
 
   (setq nil 'nil)
   (setq t 't)

@@ -47,15 +45,17 @@
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 
   (defmacro unless (condition &body body)
     `(if ,condition nil (progn ,@body)))
 

-  (defmacro defvar (name value)
+  (defmacro defvar (name value &optional docstring)

     `(progn
        (unless (boundp ',name)
         (setq ,name ,value))
     `(progn
        (unless (boundp ',name)
         (setq ,name ,value))

+       ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))

        ',name))
 
        ',name))
 

-  (defmacro defparameter (name value)
+  (defmacro defparameter (name value &optional docstring)

     `(progn
        (setq ,name ,value)
     `(progn
        (setq ,name ,value)

+       ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))

        ',name))
 
   (defmacro named-lambda (name args &rest body)
        ',name))
 
   (defmacro named-lambda (name args &rest body)

@@ -67,9 +67,12 @@
   (defmacro defun (name args &rest body)
     `(progn
        (fset ',name
   (defmacro defun (name args &rest body)
     `(progn
        (fset ',name

-             (named-lambda ,(symbol-name name)
-                 ,args
-               (block ,name ,@body)))
+             (named-lambda ,(symbol-name name) ,args
+               ,@(when (stringp (car body)) `(,(car body)))
+               (block ,name
+                 ,@(if (stringp (car body))
+                       (cdr body)
+                       body))))

        ',name))
 
   (defvar *package* (new))
        ',name))
 
   (defvar *package* (new))

@@ -119,7 +122,11 @@
 
   (defun cons (x y ) (cons x y))
   (defun consp (x) (consp x))
 
   (defun cons (x y ) (cons x y))
   (defun consp (x) (consp x))

-  (defun car (x) (car x))
+
+  (defun car (x)
+    "Return the CAR part of a cons, or NIL if X is null."
+    (car x))
+

   (defun cdr (x) (cdr x))
   (defun caar (x) (car (car x)))
   (defun cadr (x) (car (cdr x)))
   (defun cdr (x) (cdr x))
   (defun caar (x) (car (car x)))
   (defun cadr (x) (car (cdr x)))

@@ -438,8 +445,19 @@
 
   (defun disassemble (function)
     (write-line (lambda-code (fdefinition function)))
 
   (defun disassemble (function)
     (write-line (lambda-code (fdefinition function)))

-    nil))
-
+    nil)
+
+  (defun documentation (x type)
+    "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
+    (ecase type
+      (function
+       (let ((func (fdefinition x)))
+         (oget func "docstring")))
+      (variable
+       (unless (symbolp x)
+         (error "Wrong argument type! it should be a symbol"))
+       (oget x "vardoc"))))
+  )

 
 ;;; The compiler offers some primitives and special forms which are
 ;;; not found in Common Lisp, for instance, while. So, we grow Common
 
 ;;; The compiler offers some primitives and special forms which are
 ;;; not found in Common Lisp, for instance, while. So, we grow Common

@@ -750,7 +768,10 @@
 
 (defun binding-name (b) (first b))
 (defun binding-type (b) (second b))
 
 (defun binding-name (b) (first b))
 (defun binding-type (b) (second b))

-(defun binding-translation (b) (third b))
+(defun binding-value (b) (third b))
+(defun set-binding-value (b value)
+  (setcar (cdr (cdr b)) value))
+

 (defun binding-declared (b)
   (and b (fourth b)))
 (defun mark-binding-as-declared (b)
 (defun binding-declared (b)
   (and b (fourth b)))
 (defun mark-binding-as-declared (b)

@@ -796,7 +817,7 @@
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (defun translate-variable (symbol)
   (concat "v" (integer-to-string (incf *variable-counter*))))
 
 (defun translate-variable (symbol)

-  (binding-translation (lookup-in-lexenv symbol *environment* 'variable)))
+  (binding-value (lookup-in-lexenv symbol *environment* 'variable)))

 
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
 
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))

@@ -822,10 +843,13 @@
 
 (defvar *compilations* nil)
 
 
 (defvar *compilations* nil)
 

-(defun ls-compile-block (sexps)
-  (join-trailing
-   (remove-if #'null-or-empty-p  (mapcar #'ls-compile sexps))
-   (concat ";" *newline*)))
+(defun ls-compile-block (sexps &optional return-last-p)
+  (if return-last-p
+      (concat (ls-compile-block (butlast sexps))
+              "return " (ls-compile (car (last sexps))) ";")
+      (join-trailing
+       (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
+       (concat ";" *newline*))))

 
 (defmacro define-compilation (name args &body body)
   ;; Creates a new primitive `name' with parameters args and
 
 (defmacro define-compilation (name args &body body)
   ;; Creates a new primitive `name' with parameters args and

@@ -862,74 +886,90 @@
       (error "Bad lambda-list"))
     (car rest)))
 
       (error "Bad lambda-list"))
     (car rest)))
 

+
+(defun lambda-docstring-wrapper (docstring &rest strs)
+  (if docstring
+      (js!selfcall
+        "var func = " (join strs) ";" *newline*
+        "func.docstring = '" docstring "';" *newline*
+        "return func;" *newline*)
+      (join strs)))
+

 (define-compilation lambda (lambda-list &rest body)
   (let ((required-arguments (lambda-list-required-arguments lambda-list))
         (optional-arguments (lambda-list-optional-arguments lambda-list))
 (define-compilation lambda (lambda-list &rest body)
   (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)))
+        (rest-argument (lambda-list-rest-argument lambda-list))
+        documentation)
+    ;; Get the documentation string for the lambda function
+    (when (and (stringp (car body))
+               (not (null (cdr body))))
+      (setq documentation (car body))
+      (setq body (cdr body)))

     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))
           (*environment* (extend-local-env
                           (append (ensure-list rest-argument)
                                   required-arguments
                                   optional-arguments))))
     (let ((n-required-arguments (length required-arguments))
           (n-optional-arguments (length optional-arguments))
           (*environment* (extend-local-env
                           (append (ensure-list rest-argument)
                                   required-arguments
                                   optional-arguments))))

-      (concat "(function ("
-              (join (mapcar #'translate-variable
-                            (append required-arguments optional-arguments))
-                    ",")
-              "){" *newline*
-              ;; Check number of arguments
-              (indent
-               (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*
-                                                 (translate-variable (car arg))
-                                                 "="
-                                                 (ls-compile (cadr arg))
-                                                 ";" *newline*)
-                                         cases)
-                                   (incf idx)))
-                               (push (concat "default: break;" *newline*) cases)
-                               (join (reverse cases))))
-                           "}" *newline*)
-                   "")
-               ;; &rest/&body argument
-               (if rest-argument
-                   (let ((js!rest (translate-variable rest-argument)))
-                     (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
-                             "for (var i = arguments.length-1; i>="
-                             (integer-to-string (+ n-required-arguments n-optional-arguments))
-                             "; i--)" *newline*
-                             (indent js!rest " = "
-                                     "{car: arguments[i], cdr: ") js!rest "};"
-                             *newline*))
-                   "")
-               ;; Body
-               (concat (ls-compile-block (butlast body))
-                       "return " (ls-compile (car (last body))) ";")) *newline*
-              "})"))))
+      (lambda-docstring-wrapper
+       documentation
+       "(function ("
+       (join (mapcar #'translate-variable
+                     (append required-arguments optional-arguments))
+             ",")
+       "){" *newline*
+       ;; Check number of arguments
+       (indent
+        (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*
+                                          (translate-variable (car arg))
+                                          "="
+                                          (ls-compile (cadr arg))
+                                          ";" *newline*)
+                                  cases)
+                            (incf idx)))
+                        (push (concat "default: break;" *newline*) cases)
+                        (join (reverse cases))))
+                    "}" *newline*)
+            "")
+        ;; &rest/&body argument
+        (if rest-argument
+            (let ((js!rest (translate-variable rest-argument)))
+              (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
+                      "for (var i = arguments.length-1; i>="
+                      (integer-to-string (+ n-required-arguments n-optional-arguments))
+                      "; i--)" *newline*
+                      (indent js!rest " = "
+                              "{car: arguments[i], cdr: ") js!rest "};"
+                      *newline*))
+            "")
+        ;; Body
+        (ls-compile-block body t)) *newline*
+       "})"))))

 
 (define-compilation setq (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
     (if (eq (binding-type b) 'lexical-variable)
 
 (define-compilation setq (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
     (if (eq (binding-type b) 'lexical-variable)

-        (concat (binding-translation b) " = " (ls-compile val))
+        (concat (binding-value b) " = " (ls-compile val))

         (ls-compile `(set ',var ,val)))))
 
 ;;; FFI Variable accessors
         (ls-compile `(set ',var ,val)))))
 
 ;;; FFI Variable accessors

@@ -1010,10 +1050,7 @@
      (ls-compile ,form)))
 
 (define-compilation progn (&rest body)
      (ls-compile ,form)))
 
 (define-compilation progn (&rest body)

-  (js!selfcall
-    (ls-compile-block (butlast body))
-    "return " (ls-compile (car (last body))) ";" *newline*))
-
+  (js!selfcall (ls-compile-block body t)))

 
 (defun dynamic-binding-wrapper (bindings body)
   (if (null bindings)
 
 (defun dynamic-binding-wrapper (bindings body)
   (if (null bindings)

@@ -1059,10 +1096,7 @@
                               variables)
                       ",")
                 "){" *newline*
                               variables)
                       ",")
                 "){" *newline*

-                (let ((body
-                       (concat (ls-compile-block (butlast body))
-                               "return " (ls-compile (car (last body)))
-                               ";" *newline*)))
+                (let ((body (ls-compile-block body t)))

                   (indent (dynamic-binding-wrapper dynamic-bindings body)))
                 "})(" (join cvalues ",") ")")))))
 
                   (indent (dynamic-binding-wrapper dynamic-bindings body)))
                 "})(" (join cvalues ",") ")")))))
 

@@ -1090,7 +1124,7 @@
         (js!selfcall
           "throw ({"
           "type: 'block', "
         (js!selfcall
           "throw ({"
           "type: 'block', "

-          "id: " (binding-translation b) ", "
+          "id: " (binding-value b) ", "

           "value: " (ls-compile value) ", "
           "message: 'Return from unknown block " (symbol-name name) ".'"
           "})")
           "value: " (ls-compile value) ", "
           "message: 'Return from unknown block " (symbol-name name) ".'"
           "})")

@@ -1149,7 +1183,7 @@
     (let ((*environment* (declare-tagbody-tags tbidx body))
           initag)
       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
     (let ((*environment* (declare-tagbody-tags tbidx body))
           initag)
       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))

-        (setq initag (second (binding-translation b))))
+        (setq initag (second (binding-value b))))

       (js!selfcall
         "var tagbody_" tbidx " = " initag ";" *newline*
         "tbloop:" *newline*
       (js!selfcall
         "var tagbody_" tbidx " = " initag ";" *newline*
         "tbloop:" *newline*

@@ -1163,7 +1197,7 @@
                                       (if (not (go-tag-p form))
                                           (indent (ls-compile form) ";" *newline*)
                                           (let ((b (lookup-in-lexenv form *environment* 'gotag)))
                                       (if (not (go-tag-p form))
                                           (indent (ls-compile form) ";" *newline*)
                                           (let ((b (lookup-in-lexenv form *environment* 'gotag)))

-                                            (concat "case " (second (binding-translation b)) ":" *newline*)))))
+                                            (concat "case " (second (binding-value b)) ":" *newline*)))))

                                   "default:" *newline*
                                   "    break tbloop;" *newline*
                                   "}" *newline*)))
                                   "default:" *newline*
                                   "    break tbloop;" *newline*
                                   "}" *newline*)))

@@ -1186,8 +1220,8 @@
         (js!selfcall
           "throw ({"
           "type: 'tagbody', "
         (js!selfcall
           "throw ({"
           "type: 'tagbody', "

-          "id: " (first (binding-translation b)) ", "
-          "label: " (second (binding-translation b)) ", "
+          "id: " (first (binding-value b)) ", "
+          "label: " (second (binding-value b)) ", "

           "message: 'Attempt to GO to non-existing tag " n "'"
           "})" *newline*)
         (error (concat "Unknown tag `" n "'.")))))
           "message: 'Attempt to GO to non-existing tag " n "'"
           "})" *newline*)
         (error (concat "Unknown tag `" n "'.")))))

@@ -1459,7 +1493,19 @@
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
     (if macro-binding
 (defun ls-macroexpand-1 (form)
   (let ((macro-binding (macro (car form))))
     (if macro-binding

-        (apply (eval (binding-translation macro-binding)) (cdr form))
+        (let ((expander (binding-value macro-binding)))
+          (when (listp expander)
+            (let ((compiled (eval expander)))
+              ;; The list representation are useful while
+              ;; bootstrapping, as we can dump the definition of the
+              ;; macros easily, but they are slow because we have to
+              ;; evaluate them and compile them now and again. So, let
+              ;; us replace the list representation version of the
+              ;; function with the compiled one.
+              ;;
+              #+ecmalisp (set-binding-value macro-binding compiled)
+              (setq expander compiled)))
+          (apply expander (cdr form)))

         form)))
 
 (defun compile-funcall (function args)
         form)))
 
 (defun compile-funcall (function args)

@@ -1473,7 +1519,7 @@
     ((symbolp sexp)
      (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
        (if (eq (binding-type b) 'lexical-variable)
     ((symbolp sexp)
      (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
        (if (eq (binding-type b) 'lexical-variable)

-           (binding-translation b)
+           (binding-value b)

            (ls-compile `(symbol-value ',sexp)))))
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
            (ls-compile `(symbol-value ',sexp)))))
     ((integerp sexp) (integer-to-string sexp))
     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))