X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=6150d86a7638c3214e617ef7c873c769303204d0;hb=d46de145191d4d4bc1b4759a6d49c0daf6e57c33;hp=f31ca0fc2d3b72f63f7f71045f50d1f268470f31;hpb=a950d44c9486f304e0d9ac9dbe3bd26660bb5771;p=jscl.git

diff --git a/lispstrack.lisp b/lispstrack.lisp
index f31ca0f..6150d86 100644
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -29,18 +29,24 @@
                         `(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"))
@@ -60,22 +66,7 @@
  (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))
@@ -84,16 +75,16 @@
  (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)))
@@ -101,18 +92,99 @@
  (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
@@ -125,8 +197,21 @@
                (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
@@ -144,12 +229,6 @@
   (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))
@@ -162,82 +241,36 @@
         (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))
@@ -310,9 +343,6 @@
         (incf index))
       ret))
 
-  (defun eql (x y)
-    (eq x y))
-
   (defun assoc (x alist)
     (cond
       ((null alist)
@@ -357,12 +387,10 @@
 (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)
      "")
@@ -373,22 +401,36 @@
              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
 
@@ -470,6 +512,31 @@
       (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)
@@ -495,29 +562,7 @@
            (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)
@@ -615,11 +660,13 @@
 
 (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
@@ -636,43 +683,92 @@
           (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)
@@ -738,14 +834,17 @@
 
 (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)))
@@ -857,7 +956,7 @@
            "; 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"))
@@ -955,6 +1054,11 @@
   (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)))
 
@@ -999,10 +1103,8 @@
   (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))))
 
@@ -1026,7 +1128,7 @@
  (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
@@ -1043,6 +1145,7 @@
  (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*