X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=562f004228962bef1da46536f6d20b03534e825f;hb=7a3b48bc54c5540a963c6aca4c974ca90c41bfca;hp=12b3a69975c3f273b09d0c55d22e26a45fb93690;hpb=00d4d47bed875a7bb56a6618cfd659a3c8741f15;p=jscl.git

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 12b3a69..562f004 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,71 +250,16 @@
         (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))
 
@@ -264,18 +272,14 @@
       ((zerop n) (car list))
       (t (nth (1- n) (cdr list)))))
 
-  (defun integerp (x)
-    (and (numberp x) (= (floor x) x)))
-
   (defun last (x)
-    (if (null (cdr x))
-        x
-        (last (cdr x))))
+    (if (consp (cdr x))
+        (last (cdr x))
+        x))
 
   (defun butlast (x)
-    (if (null (cdr x))
-        nil
-        (cons (car x) (butlast (cdr x)))))
+    (and (consp (cdr x))
+         (cons (car x) (butlast (cdr x)))))
 
   (defun member (x list)
     (cond
@@ -318,6 +322,15 @@
         (- x #\0)
         nil))
 
+  (defun subseq (seq a &optional b)
+    (cond
+     ((stringp seq)
+      (if b
+          (slice seq a b)
+          (slice seq a)))
+     (t
+      (error "Unsupported argument."))))
+
   (defun parse-integer (string)
     (let ((value 0)
           (index 0)
@@ -338,9 +351,6 @@
         (incf index))
       ret))
 
-  (defun eql (x y)
-    (eq x y))
-
   (defun assoc (x alist)
     (cond
       ((null alist)
@@ -388,7 +398,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)
      "")
@@ -399,21 +409,24 @@
              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
@@ -507,6 +520,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)
@@ -532,29 +570,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)
@@ -738,12 +754,12 @@
                                                      (integer-to-string (+ idx n-required-arguments)) ":" *newline*
                                                      (lookup-variable-translation (car arg) new-env)
                                                      "="
-                                                     (ls-compile (cdr arg) new-env fenv)
+                                                     (ls-compile (cadr arg) new-env fenv)
                                                      ";" *newline*)
                                              cases)
                                        (incf idx)))
                                    (push (concat "default: break;" *newline*) cases)
-                                   (join (reverse cases) "")))
+                                   (join (reverse cases))))
                           "}" *newline*)
                   "")
               ;; &rest argument
@@ -974,6 +990,17 @@
 (define-compilation string-length (x)
   (concat "(" (ls-compile x env fenv) ").length"))
 
+(define-compilation slice (string a &optional b)
+  (concat "(function(){" *newline*
+          "var str = " (ls-compile string env fenv) ";" *newline*
+          "var a = " (ls-compile a env fenv) ";" *newline*
+          "var b;" *newline*
+          (if b
+              (concat "b = " (ls-compile b env fenv) ";" *newline*)
+              "")
+          "return str.slice(a,b);" *newline*
+          "})()"))
+
 (define-compilation char (string index)
   (concat "("
           (ls-compile string env fenv)
@@ -1096,8 +1123,7 @@
   (let ((code (ls-compile sexp nil nil)))
     (prog1
         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
-                              *toplevel-compilations*)
-               "")
+                              *toplevel-compilations*))
                 code)
       (setq *toplevel-compilations* nil))))