Add PROG2 macro

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 82b207d..41c06f0 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -153,7 +153,7 @@
                (,var nil))
            (%while ,g!list
                    (setq ,var (car ,g!list))
-                   ,@body
+                   (tagbody ,@body)
                    (setq ,g!list (cdr ,g!list)))
            ,(third iter)))))
 
@@ -166,7 +166,7 @@
          (let ((,var 0)
                (,g!to ,to))
            (%while (< ,var ,g!to)
-                   ,@body
+                   (tagbody ,@body)
                    (incf ,var))
            ,result))))
 
@@ -223,7 +223,14 @@
     (let ((value (gensym)))
       `(let ((,value ,form))
          ,@body
-         ,value))))
+         ,value)))
+
+  (defmacro prog2 (form1 result &body body)
+    `(prog1 (progn ,form1 ,result) ,@body))
+
+
+
+)
 
 ;;; This couple of helper functions will be defined in both Common
 ;;; Lisp and in Ecmalisp.
@@ -263,13 +270,14 @@
   (defun append (&rest lists)
     (!reduce #'append-two lists '()))
 
-  (defun reverse-aux (list acc)
-    (if (null list)
-        acc
-        (reverse-aux (cdr list) (cons (car list) acc))))
+  (defun revappend (list1 list2)
+    (while list1
+      (push (car list1) list2)
+      (setq list1 (cdr list1)))
+    list2)
 
   (defun reverse (list)
-    (reverse-aux list '()))
+    (revappend list '()))
 
   (defun list-length (list)
     (let ((l 0))
@@ -310,29 +318,29 @@
   (defun listp (x)
     (or (consp x) (null x)))
 
+  (defun nthcdr (n list)
+    (while (and (plusp n) list)
+      (setq n (1- n))
+      (setq list (cdr list)))
+    list)
+
   (defun nth (n list)
-    (cond
-      ((null list) list)
-      ((zerop n) (car list))
-      (t (nth (1- n) (cdr list)))))
+    (car (nthcdr n list)))
 
   (defun last (x)
-    (if (consp (cdr x))
-        (last (cdr x))
-        x))
+    (while (consp (cdr x))
+      (setq x (cdr x)))
+    x)
 
   (defun butlast (x)
     (and (consp (cdr x))
          (cons (car x) (butlast (cdr x)))))
 
   (defun member (x list)
-    (cond
-      ((null list)
-       nil)
-      ((eql x (car list))
-       list)
-      (t
-       (member x (cdr list)))))
+    (while list
+      (when (eql x (car list))
+        (return list))
+      (setq list (cdr list))))
 
   (defun remove (x list)
     (cond
@@ -481,25 +489,40 @@
       ""
       (concat (car list) separator (join-trailing (cdr list) separator))))
 
-;;; Like CONCAT, but prefix each line with four spaces.
+
+;;; Like CONCAT, but prefix each line with four spaces. Two versions
+;;; of this function are available, because the Ecmalisp version is
+;;; very slow and bootstraping was annoying.
+
+#+ecmalisp
 (defun indent (&rest string)
   (let ((input (join string)))
     (let ((output "")
           (index 0)
           (size (length input)))
-      (when (plusp size)
-        (setq output "    "))
+      (when (plusp (length input)) (concatf output "    "))
       (while (< index size)
-        (setq output
-              (concat output
-                      (if (and (char= (char input index) #\newline)
-                               (< index (1- size))
-                               (not (char= (char input (1+ index)) #\newline)))
-                          (concat (string #\newline) "    ")
-                          (subseq input index (1+ index)))))
+        (let ((str
+               (if (and (char= (char input index) #\newline)
+                        (< index (1- size))
+                        (not (char= (char input (1+ index)) #\newline)))
+                   (concat (string #\newline) "    ")
+                   (string (char input index)))))
+          (concatf output str))
         (incf index))
       output)))
 
+#+common-lisp
+(defun indent (&rest string)
+  (with-output-to-string (*standard-output*)
+    (with-input-from-string (input (join string))
+      (loop
+         for line = (read-line input nil)
+         while line
+         do (write-string "    ")
+         do (write-line line)))))
+
+
 (defun integer-to-string (x)
   (cond
     ((zerop x)
@@ -755,9 +778,10 @@
 (defvar *environment* (make-lexenv))
 
 (defun clear-undeclared-global-bindings ()
-  (let ((variables (first *environment*))
-        (functions (second *environment*)))
-    (setq *environment* (list variables functions (third *environment*)))))
+  (setq *environment*
+       (mapcar (lambda (namespace)
+                 (remove-if-not #'binding-declared namespace))
+               *environment*)))
 
 
 (defvar *variable-counter* 0)
@@ -771,8 +795,9 @@
             (binding (make-binding symbol 'variable (gvarname symbol) nil)))
         (push-to-lexenv binding *environment* 'variable)
         (push (lambda ()
-                (unless (lookup-in-lexenv symbol *environment* 'variable)
-                  (error (concat "Undefined variable `" name "'"))))
+               (let ((b (lookup-in-lexenv symbol *environment* 'variable)))
+                 (unless (binding-declared b)
+                     (error (concat "Undefined variable `" name "'")))))
               *compilation-unit-checks*)
         binding)))
 
@@ -797,8 +822,9 @@
                            nil)))
         (push-to-lexenv binding *environment* 'function)
         (push (lambda ()
-                (unless (binding-declared (lookup-in-lexenv symbol *environment* 'function))
-                  (error (concat "Undefined function `" name "'"))))
+               (let ((b (lookup-in-lexenv symbol *environment* 'function)))
+                 (unless (binding-declared b)
+                   (error (concat "Undefined function `" name "'")))))
               *compilation-unit-checks*)
         binding)))