picolisp

commit 0f5e0d742c857f700e0bf1fb5c7588bc64882603
parent a2cde072a5cb1059b38cfacd69b8ff9df67c40c0
Author: Alexander Burger <abu@software-lab.de>
Date:   Fri, 25 Feb 2011 08:44:19 +0100

pretty 'if2'
Diffstat:
M
ersatz/lib.l
 | 
45
+++++++++++++++++++++++++--------------------
M
ersatz/picolisp.jar
 | 
0

M
lib.l
 | 
45
+++++++++++++++++++++++++--------------------
M
src64/version.l
 | 
4
++--

4 files changed, 52 insertions(+), 42 deletions(-)
diff --git a/ersatz/lib.l b/ersatz/lib.l
@@ -1,4 +1,4 @@
-# 02feb11abu
+# 25feb11abu
 # (c) Software Lab. Alexander Burger
 
 ############ lib.l ############
@@ -259,6 +259,7 @@
    prog1 recur redef =: in out tab new )
 (de *PP1 let let? for redef)
 (de *PP2 setq default)
+(de *PP3 if2)
 
 (de pretty (X N . @)
    (setq N (abs (space (or N 0))))
@@ -271,27 +272,31 @@
          (pop 'X) )
       (let Z X
          (prin "(")
-         (when (memq (print (pop 'X)) *PP)
-            (cond
-               ((memq (car Z) *PP1)
-                  (if (and (pair (car X)) (pair (cdar X)))
-                     (when (>= 12 (size (car X)))
+         (cond
+            ((memq (print (pop 'X)) *PP)
+               (cond
+                  ((memq (car Z) *PP1)
+                     (if (and (pair (car X)) (pair (cdar X)))
+                        (when (>= 12 (size (car X)))
+                           (space)
+                           (print (pop 'X)) )
                         (space)
-                        (print (pop 'X)) )
+                        (print (pop 'X))
+                        (when (or (atom (car X)) (>= 12 (size (car X))))
+                           (space)
+                           (print (pop 'X)) ) ) )
+                  ((memq (car Z) *PP2)
+                     (inc 'N 3)
+                     (loop
+                        (prinl)
+                        (pretty (cadr X) N (car X))
+                        (NIL (setq X (cddr X)) (space)) ) )
+                  ((or (atom (car X)) (>= 12 (size (car X))))
                      (space)
-                     (print (pop 'X))
-                     (when (or (atom (car X)) (>= 12 (size (car X))))
-                        (space)
-                        (print (pop 'X)) ) ) )
-               ((memq (car Z) *PP2)
-                  (inc 'N 3)
-                  (loop
-                     (prinl)
-                     (pretty (cadr X) N (car X))
-                     (NIL (setq X (cddr X)) (space)) ) )
-               ((or (atom (car X)) (>= 12 (size (car X))))
-                  (space)
-                  (print (pop 'X)) ) ) )
+                     (print (pop 'X)) ) ) )
+            ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X))))
+               (space)
+               (print (pop 'X) (pop 'X)) ) )
          (when X
             (loop
                (T (== Z X) (prin " ."))
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/lib.l b/lib.l
@@ -1,4 +1,4 @@
-# 18jan11abu
+# 25feb11abu
 # (c) Software Lab. Alexander Burger
 
 (de task (Key . Prg)
@@ -300,6 +300,7 @@
    prog1 later recur redef =: in out ctl tab new )
 (de *PP1 let let? for redef)
 (de *PP2 setq default)
+(de *PP3 if2)
 
 (de pretty (X N . @)
    (setq N (abs (space (or N 0))))
@@ -312,27 +313,31 @@
          (pop 'X) )
       (let Z X
          (prin "(")
-         (when (memq (print (pop 'X)) *PP)
-            (cond
-               ((memq (car Z) *PP1)
-                  (if (and (pair (car X)) (pair (cdar X)))
-                     (when (>= 12 (size (car X)))
+         (cond
+            ((memq (print (pop 'X)) *PP)
+               (cond
+                  ((memq (car Z) *PP1)
+                     (if (and (pair (car X)) (pair (cdar X)))
+                        (when (>= 12 (size (car X)))
+                           (space)
+                           (print (pop 'X)) )
                         (space)
-                        (print (pop 'X)) )
+                        (print (pop 'X))
+                        (when (or (atom (car X)) (>= 12 (size (car X))))
+                           (space)
+                           (print (pop 'X)) ) ) )
+                  ((memq (car Z) *PP2)
+                     (inc 'N 3)
+                     (loop
+                        (prinl)
+                        (pretty (cadr X) N (car X))
+                        (NIL (setq X (cddr X)) (space)) ) )
+                  ((or (atom (car X)) (>= 12 (size (car X))))
                      (space)
-                     (print (pop 'X))
-                     (when (or (atom (car X)) (>= 12 (size (car X))))
-                        (space)
-                        (print (pop 'X)) ) ) )
-               ((memq (car Z) *PP2)
-                  (inc 'N 3)
-                  (loop
-                     (prinl)
-                     (pretty (cadr X) N (car X))
-                     (NIL (setq X (cddr X)) (space)) ) )
-               ((or (atom (car X)) (>= 12 (size (car X))))
-                  (space)
-                  (print (pop 'X)) ) ) )
+                     (print (pop 'X)) ) ) )
+            ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X))))
+               (space)
+               (print (pop 'X) (pop 'X)) ) )
          (when X
             (loop
                (T (== Z X) (prin " ."))
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 21feb11abu
+# 25feb11abu
 # (c) Software Lab. Alexander Burger
 
-(de *Version 3 0 5 16)
+(de *Version 3 0 5 17)
 
 # vi:et:ts=3:sw=3