X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=bd51e288a4ff1d72ae77e798c1edd840cde11f42;hb=405e505cf5a764e58f00911950623ad652b874ef;hp=1f802706555fb2d02c03428a09e00518da358669;hpb=25b9b86398e4dd561f4eebc5067b5531173e0e3e;p=jscl.git

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 1f80270..bd51e28 100644
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -35,7 +35,7 @@
         (%compile-defvar ',name))
       (setq ,name ,value)))
 
-  (defmacro defvar (name value)
+  (defmacro defvar (name &optional value)
     `(%defvar ,name ,value))
 
  (defmacro %defun (name args &rest body)
@@ -66,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))
@@ -90,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)))
@@ -107,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
@@ -131,6 +197,9 @@
                (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)
@@ -138,7 +207,7 @@
        (%defun ,name ,args ,@body)
        ',name))
 
-  (defmacro defvar (name value)
+  (defmacro defvar (name &optional value)
     `(progn
        (%defvar ,name ,value)
        ',name))
@@ -160,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))
@@ -187,79 +250,27 @@
         (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))
@@ -332,9 +343,6 @@
         (incf index))
       ret))
 
-  (defun eql (x y)
-    (eq x y))
-
   (defun assoc (x alist)
     (cond
       ((null alist)
@@ -382,7 +390,7 @@
   (!reduce #'concat-two strs ""))
 
 ;;; Concatenate a list of strings, with a separator
-(defun join (list separator)
+(defun join (list &optional (separator ""))
   (cond
     ((null list)
      "")
@@ -393,7 +401,7 @@
              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))))
@@ -669,43 +677,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)
@@ -777,8 +834,11 @@
   `(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)))
@@ -1063,7 +1123,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