r12415@gauss: gdr | 2008-12-06 11:42:45 -0600

 Implement basic support for pattern matching.
 r12416@gauss:  gdr | 2008-12-06 18:09:19 -0600
 	Parse case pattern match.
 r12417@gauss:  gdr | 2008-12-06 21:28:30 -0600
 	Implement basic case pattern matching for retractable domain.
 r12418@gauss:  gdr | 2008-12-07 00:58:58 -0600
 	Refine retractability implementation.
 r12419@gauss:  gdr | 2008-12-07 01:39:32 -0600
 Update cached Lisp translation
 r12420@gauss:  gdr | 2008-12-07 03:52:09 -0600
 
 r12421@gauss:  gdr | 2008-12-07 10:30:44 -0600
 	Implement type recovery too.
 r12422@gauss:  gdr | 2008-12-07 19:18:09 -0600
 	Simplify LET-forms and COND-forms.
 r12423@gauss:  gdr | 2008-12-07 21:21:12 -0600
 Fix typos
 r12424@gauss:  gdr | 2008-12-08 01:14:54 -0600
 	Parse case-pattern in the interpreter.
 r12427@gauss:  gdr | 2008-12-08 20:32:29 -0600
 	Handle RetractableTo T.

5 files changed, 31 insertions, 39 deletions

diff --git a/src/algebra/strap/ILIST.lsp b/src/algebra/strap/ILIST.lsp
index 872490b2..addea91c 100644
--- a/src/algebra/strap/ILIST.lsp
+++ b/src/algebra/strap/ILIST.lsp
@@ -151,26 +151,22 @@
 
 (DEFUN |ILIST;setfirst!;$2S;10| (|x| |s| $)
   (COND
-    ((SPADCALL |x| (|getShellEntry| $ 17))
-     (|error| "Cannot update an empty list"))
+    ((NULL |x|) (|error| "Cannot update an empty list"))
     ('T (QCAR (RPLACA |x| |s|))))) 
 
 (DEFUN |ILIST;setelt;$first2S;11| (|x| T2 |s| $)
   (COND
-    ((SPADCALL |x| (|getShellEntry| $ 17))
-     (|error| "Cannot update an empty list"))
+    ((NULL |x|) (|error| "Cannot update an empty list"))
     ('T (QCAR (RPLACA |x| |s|))))) 
 
 (DEFUN |ILIST;setrest!;3$;12| (|x| |y| $)
   (COND
-    ((SPADCALL |x| (|getShellEntry| $ 17))
-     (|error| "Cannot update an empty list"))
+    ((NULL |x|) (|error| "Cannot update an empty list"))
     ('T (QCDR (RPLACD |x| |y|))))) 
 
 (DEFUN |ILIST;setelt;$rest2$;13| (|x| T3 |y| $)
   (COND
-    ((SPADCALL |x| (|getShellEntry| $ 17))
-     (|error| "Cannot update an empty list"))
+    ((NULL |x|) (|error| "Cannot update an empty list"))
     ('T (QCDR (RPLACD |x| |y|))))) 
 
 (DEFUN |ILIST;construct;L$;14| (|l| $) (DECLARE (IGNORE $)) |l|) 
@@ -235,8 +231,7 @@
                 NIL (GO G190) G191 (EXIT NIL))
            (LETT |y| (NREVERSE |y|) |ILIST;coerce;$Of;21|)
            (EXIT (COND
-                   ((SPADCALL |s| (|getShellEntry| $ 17))
-                    (SPADCALL |y| (|getShellEntry| $ 40)))
+                   ((NULL |s|) (SPADCALL |y| (|getShellEntry| $ 40)))
                    ('T
                     (SEQ (LETT |z|
                                (SPADCALL
@@ -475,10 +470,8 @@
       (SEQ (COND
              ((EQL |n| 2)
               (COND
-                ((SPADCALL
-                     (SPADCALL (SPADCALL |p| (|getShellEntry| $ 18))
-                         (|getShellEntry| $ 13))
-                     (SPADCALL |p| (|getShellEntry| $ 13)) |f|)
+                ((SPADCALL (|SPADfirst| (CDR |p|)) (|SPADfirst| |p|)
+                     |f|)
                  (LETT |p| (NREVERSE |p|) |ILIST;mergeSort|)))))
            (EXIT (COND
                    ((< |n| 3) |p|)
diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp
index d3c63504..d9dea6b1 100644
--- a/src/algebra/strap/ISTRING.lsp
+++ b/src/algebra/strap/ISTRING.lsp
@@ -702,8 +702,7 @@
                        (|getShellEntry| $ 6))))
                  |ISTRING;elt;$Us$;31|)
            (COND
-             ((OR (< |l| 0)
-                  (NULL (< |h| (SPADCALL |s| (|getShellEntry| $ 13)))))
+             ((OR (< |l| 0) (NULL (< |h| (QCSIZE |s|))))
               (EXIT (|error| "index out of bound"))))
            (EXIT (SUBSTRING |s| |l| (MAX 0 (+ (- |h| |l|) 1)))))))) 
 
@@ -768,10 +767,11 @@
                                        (COND
                                          ((NULL
                                            (SPADCALL
-                                            (SPADCALL |pattern|
+                                            (|ISTRING;elt;$Us$;31|
+                                             |pattern|
                                              (SPADCALL |m| (- |p| 1)
                                               (|getShellEntry| $ 20))
-                                             (|getShellEntry| $ 21))
+                                             $)
                                             |target|
                                             (|getShellEntry| $ 72)))
                                           (EXIT 'NIL)))))
@@ -842,13 +842,13 @@
                                         (|getShellEntry| $ 71))
                                        (COND
                                          ((NULL
-                                           (SPADCALL
-                                            (SPADCALL |pattern|
+                                           (|ISTRING;suffix?;2$B;21|
+                                            (|ISTRING;elt;$Us$;31|
+                                             |pattern|
                                              (SPADCALL (+ |p| 1) |n|
                                               (|getShellEntry| $ 20))
-                                             (|getShellEntry| $ 21))
-                                            |target|
-                                            (|getShellEntry| $ 51)))
+                                             $)
+                                            |target| $))
                                           (EXIT 'NIL)))))
                                     (EXIT 'T)))))))
            #3# (EXIT #3#))))) 
diff --git a/src/algebra/strap/LIST.lsp b/src/algebra/strap/LIST.lsp
index c97fecf3..43656399 100644
--- a/src/algebra/strap/LIST.lsp
+++ b/src/algebra/strap/LIST.lsp
@@ -164,7 +164,7 @@
            (EXIT |lu|))))) 
 
 (DEFUN |LIST;convert;$If;13| (|x| $)
-  (PROG (#0=#:G1447 |a| #1=#:G1448)
+  (PROG (#0=#:G1442 |a| #1=#:G1443)
     (RETURN
       (SEQ (SPADCALL
                (CONS (SPADCALL
@@ -191,10 +191,10 @@
                             (GO G190) G191 (EXIT (NREVERSE0 #0#)))))
                (|getShellEntry| $ 44)))))) 
 
-(DEFUN |List| (#0=#:G1449)
+(DEFUN |List| (#0=#:G1444)
   (PROG ()
     (RETURN
-      (PROG (#1=#:G1450)
+      (PROG (#1=#:G1445)
         (RETURN
           (COND
             ((LETT #1#
diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp
index d89865c0..027e0a17 100644
--- a/src/algebra/strap/OUTFORM.lsp
+++ b/src/algebra/strap/OUTFORM.lsp
@@ -668,7 +668,7 @@
 
 (DEFUN |OUTFORM;prefix;$L$;76| (|a| |l| $)
   (COND
-    ((NULL (SPADCALL |a| (|getShellEntry| $ 98))) (CONS |a| |l|))
+    ((NULL (|OUTFORM;infix?;$B;74| |a| $)) (CONS |a| |l|))
     ('T
      (|OUTFORM;hconcat;3$;48| |a|
          (|OUTFORM;paren;2$;40| (|OUTFORM;commaSeparate;L$;33| |l| $)
@@ -681,7 +681,7 @@
     ((SPADCALL (SPADCALL |l| (|getShellEntry| $ 69))
          (|getShellEntry| $ 68))
      (SPADCALL |l| (|getShellEntry| $ 70)))
-    ((SPADCALL |a| (|getShellEntry| $ 98)) (CONS |a| |l|))
+    ((|OUTFORM;infix?;$B;74| |a| $) (CONS |a| |l|))
     ('T
      (|OUTFORM;hconcat;L$;49|
          (LIST (SPADCALL |l| (|getShellEntry| $ 70)) |a|
@@ -691,7 +691,7 @@
 
 (DEFUN |OUTFORM;infix;4$;78| (|a| |b| |c| $)
   (COND
-    ((SPADCALL |a| (|getShellEntry| $ 98))
+    ((|OUTFORM;infix?;$B;74| |a| $)
      (|OUTFORM;bless| (LIST |a| |b| |c|) $))
     ('T (|OUTFORM;hconcat;L$;49| (LIST |b| |a| |c|) $)))) 
 
diff --git a/src/algebra/strap/SYMBOL.lsp b/src/algebra/strap/SYMBOL.lsp
index cbbd5a3b..8c1044f6 100644
--- a/src/algebra/strap/SYMBOL.lsp
+++ b/src/algebra/strap/SYMBOL.lsp
@@ -115,7 +115,7 @@
 
 (DEFUN |SYMBOL;writeOMSym| (|dev| |x| $)
   (COND
-    ((SPADCALL |x| (|getShellEntry| $ 22))
+    ((|SYMBOL;scripted?;$B;30| |x| $)
      (|error| "Cannot convert a scripted symbol to OpenMath"))
     ('T (SPADCALL |dev| |x| (|getShellEntry| $ 26))))) 
 
@@ -293,7 +293,7 @@
 
 (DEFUN |SYMBOL;script;$R$;23| (|sy| |sc| $)
   (COND
-    ((SPADCALL |sy| (|getShellEntry| $ 22))
+    ((|SYMBOL;scripted?;$B;30| |sy| $)
      (|error| "Cannot add scripts to a scripted symbol"))
     ('T
      (CONS (|SYMBOL;coerce;$Of;11|
@@ -307,7 +307,7 @@
 
 (DEFUN |SYMBOL;string;$S;24| (|e| $)
   (COND
-    ((NULL (SPADCALL |e| (|getShellEntry| $ 22))) (PNAME |e|))
+    ((NULL (|SYMBOL;scripted?;$B;30| |e| $)) (PNAME |e|))
     ('T (|error| "Cannot form string from non-atomic symbols.")))) 
 
 (DEFUN |SYMBOL;latex;$S;25| (|e| $)
@@ -323,8 +323,7 @@
                      (|getShellEntry| $ 86))
                  (LETT |s| (STRCONC "\\mbox{\\it " (STRCONC |s| "}"))
                        |SYMBOL;latex;$S;25|)))))
-           (COND
-             ((NULL (SPADCALL |e| (|getShellEntry| $ 22))) (EXIT |s|)))
+           (COND ((NULL (|SYMBOL;scripted?;$B;30| |e| $)) (EXIT |s|)))
            (LETT |ss| (|SYMBOL;scripts;$R;32| |e| $)
                  |SYMBOL;latex;$S;25|)
            (LETT |lo| (QVELT |ss| 0) |SYMBOL;latex;$S;25|)
@@ -511,7 +510,7 @@
                (|getShellEntry| $ 98))
            (LETT |xx|
                  (COND
-                   ((NULL (SPADCALL |x| (|getShellEntry| $ 22)))
+                   ((NULL (|SYMBOL;scripted?;$B;30| |x| $))
                     (|SYMBOL;string;$S;24| |x| $))
                    ('T
                     (|SYMBOL;string;$S;24| (|SYMBOL;name;2$;31| |x| $)
@@ -538,7 +537,7 @@
                                  (|getShellEntry| $ 18) $))))
                  |SYMBOL;new;2$;28|)
            (COND
-             ((NULL (SPADCALL |x| (|getShellEntry| $ 22)))
+             ((NULL (|SYMBOL;scripted?;$B;30| |x| $))
               (EXIT (|SYMBOL;coerce;S$;8| |xx| $))))
            (EXIT (|SYMBOL;script;$R$;23| (|SYMBOL;coerce;S$;8| |xx| $)
                      (|SYMBOL;scripts;$R;32| |x| $) $)))))) 
@@ -572,7 +571,7 @@
   (PROG (|str| |i| #0=#:G1551 #1=#:G1531 #2=#:G1529)
     (RETURN
       (SEQ (EXIT (COND
-                   ((NULL (SPADCALL |sy| (|getShellEntry| $ 22))) |sy|)
+                   ((NULL (|SYMBOL;scripted?;$B;30| |sy| $)) |sy|)
                    ('T
                     (SEQ (LETT |str|
                                (|SYMBOL;string;$S;24|
@@ -626,7 +625,7 @@
             #1=#:G1552 |i| #2=#:G1553 |a| #3=#:G1554 |allscripts|)
     (RETURN
       (SEQ (COND
-             ((NULL (SPADCALL |sy| (|getShellEntry| $ 22)))
+             ((NULL (|SYMBOL;scripted?;$B;30| |sy| $))
               (VECTOR NIL NIL NIL NIL NIL))
              ('T
               (SEQ (LETT |nscripts| (LIST 0 0 0 0 0)
@@ -764,7 +763,7 @@
 
 (DEFUN |SYMBOL;list;$L;34| (|sy| $)
   (COND
-    ((NULL (SPADCALL |sy| (|getShellEntry| $ 22)))
+    ((NULL (|SYMBOL;scripted?;$B;30| |sy| $))
      (|error| "Cannot convert a symbol to a list if it is not subscripted"))
     ('T |sy|)))