* boot/parser.boot (bpArgtypeList): Accept mapping types.

	* boot/ast.boot (bfType): New.
	* boot/translator.boot (genDeclaration): Use it.
	* boot/utility.boot (every?): New.  Export.
	(any?): Likewise.
	(takeWhile): Lilkewise.

8 files changed, 134 insertions, 29 deletions

diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index be52533d..4a476189 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1344,6 +1344,18 @@ bfThrow e ==
   ["THROW",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,
     ["CONS",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,["CONS",t,x]]]
 
+--%
+
+bfType x ==
+  x is ['%Mapping,t,s] =>
+    if bfTupleP s then
+      s := s.args
+    if ident? s then
+      s := [s]
+    ['FUNCTION,[bfType y for y in s],bfType t]
+  x is [.,:.] => [x.op,:[bfType y for y in x.args]]
+  x
+
 --% Type alias definition
 
 backquote: (%Form,%List %Symbol) -> %Form
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index f9ae96dc..dde2bd3e 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -507,10 +507,10 @@ bpSimpleMapping() ==
 ++ ArgtypeList:
 ++   ( ArgtypeSequence )
 ++ ArgtypeSequence:
-++   Application
-++   Application , ArgtypeSequence
+++   SimpleMapping
+++   SimpleMapping , ArgtypeSequence
 bpArgtypeList() ==
-  bpTuple function bpApplication
+  bpTuple function bpSimpleMapping
 
 ++ Parse a mapping expression
 ++   Mapping:
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index f074ad0b..3bf3ce53 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -2392,6 +2392,52 @@
       (LIST 'THROW :OPEN-AXIOM-CATCH-POINT
             (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|)))))))
 
+(DEFUN |bfType| (|x|)
+  (PROG (|s| |ISTMP#2| |t| |ISTMP#1|)
+    (RETURN
+     (COND
+      ((AND (CONSP |x|) (EQ (CAR |x|) '|%Mapping|)
+            (PROGN
+             (SETQ |ISTMP#1| (CDR |x|))
+             (AND (CONSP |ISTMP#1|)
+                  (PROGN
+                   (SETQ |t| (CAR |ISTMP#1|))
+                   (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+                   (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+                        (PROGN (SETQ |s| (CAR |ISTMP#2|)) T))))))
+       (COND ((|bfTupleP| |s|) (SETQ |s| (CDR |s|))))
+       (COND ((|ident?| |s|) (SETQ |s| (LIST |s|))))
+       (LIST 'FUNCTION
+             (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|y| NIL))
+               (LOOP
+                (COND
+                 ((OR (NOT (CONSP |bfVar#1|))
+                      (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
+                  (RETURN |bfVar#2|))
+                 ((NULL |bfVar#2|)
+                  (SETQ |bfVar#2| #1=(CONS (|bfType| |y|) NIL))
+                  (SETQ |bfVar#3| |bfVar#2|))
+                 (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+                (SETQ |bfVar#1| (CDR |bfVar#1|))))
+             (|bfType| |t|)))
+      ((CONSP |x|)
+       (CONS (CAR |x|)
+             (LET ((|bfVar#5| NIL)
+                   (|bfVar#6| NIL)
+                   (|bfVar#4| (CDR |x|))
+                   (|y| NIL))
+               (LOOP
+                (COND
+                 ((OR (NOT (CONSP |bfVar#4|))
+                      (PROGN (SETQ |y| (CAR |bfVar#4|)) NIL))
+                  (RETURN |bfVar#5|))
+                 ((NULL |bfVar#5|)
+                  (SETQ |bfVar#5| #2=(CONS (|bfType| |y|) NIL))
+                  (SETQ |bfVar#6| |bfVar#5|))
+                 (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|))))
+                (SETQ |bfVar#4| (CDR |bfVar#4|))))))
+      (T |x|)))))
+
 (DECLAIM (FTYPE (FUNCTION (|%Form| (|%List| |%Symbol|)) |%Form|) |backquote|))
 
 (DEFUN |backquote| (|form| |params|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index a91db6cc..f6799dbf 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -494,7 +494,7 @@
     T)
    (T NIL)))
 
-(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|))
+(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpSimpleMapping|))
 
 (DEFUN |bpMapping| ()
   (AND (|bpParenthesized| #'|bpArgtypeList|) (|bpEqKey| 'ARROW)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 9abbe2ca..4294b1ba 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -484,23 +484,11 @@
             ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) (T (CAR |$stack|)))))))
 
 (DEFUN |genDeclaration| (|n| |t|)
-  (PROG (|t'| |vars| |argTypes| |ISTMP#2| |valType| |ISTMP#1|)
+  (PROG (|t'| |ISTMP#2| |vars| |ISTMP#1|)
     (RETURN
      (COND
-      ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|)
-            (PROGN
-             (SETQ |ISTMP#1| (CDR |t|))
-             (AND (CONSP |ISTMP#1|)
-                  (PROGN
-                   (SETQ |valType| (CAR |ISTMP#1|))
-                   (SETQ |ISTMP#2| (CDR |ISTMP#1|))
-                   (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
-                        (PROGN (SETQ |argTypes| (CAR |ISTMP#2|)) T))))))
-       (COND ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|))))
-       (COND
-        ((AND |argTypes| (SYMBOLP |argTypes|))
-         (SETQ |argTypes| (LIST |argTypes|))))
-       (LIST 'DECLAIM (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|)))
+      ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|))
+       (LIST 'DECLAIM (LIST 'FTYPE (|bfType| |t|) |n|)))
       ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|)
             (PROGN
              (SETQ |ISTMP#1| (CDR |t|))
@@ -533,7 +521,7 @@
                                       (SETQ |bfVar#3| (CDR |bfVar#3|))))
                                     (SETQ |bfVar#1| (CDR |bfVar#1|))))
                                  |t'|)))))
-      (T (LIST 'DECLAIM (LIST 'TYPE |t| |n|)))))))
+      (T (LIST 'DECLAIM (LIST 'TYPE (|bfType| |t|) |n|)))))))
 
 (DEFUN |translateSignatureDeclaration| (|d|)
   (CASE (CAR |d|)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 457ea66e..73e14218 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -20,8 +20,8 @@
                      |lastNode| |append| |append!| |copyList| |substitute|
                      |substitute!| |setDifference| |setUnion| |setIntersection|
                      |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ|
-                     |objectAssoc| |remove| |removeSymbol| |atomic?| |copyTree|
-                     |finishLine|)))
+                     |objectAssoc| |remove| |removeSymbol| |atomic?| |every?|
+                     |any?| |takeWhile| |copyTree| |finishLine|)))
 
 (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
 
@@ -74,6 +74,20 @@
 
 (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|))
 
+(DECLAIM
+ (FTYPE (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|)) |%Thing|)
+  |every?|))
+
+(DECLAIM
+ (FTYPE (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|)) |%Thing|)
+  |any?|))
+
+(DECLAIM
+ (FTYPE
+  (FUNCTION ((FUNCTION (|%Thing|) |%Thing|) (|%List| |%Thing|))
+   (|%List| |%Thing|))
+  |takeWhile|))
+
 (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |copyTree|))
 
 (DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|))
@@ -86,6 +100,38 @@
 
 (DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE)))
 
+(DEFUN |every?| (|f| |l|)
+  (LET ((|bfVar#2| T) (|bfVar#1| |l|) (|x| NIL))
+    (LOOP
+     (COND
+      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+       (RETURN |bfVar#2|))
+      (T (SETQ |bfVar#2| (APPLY |f| |x| NIL))
+       (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+     (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |any?| (|f| |l|)
+  (LET ((|bfVar#2| NIL) (|bfVar#1| |l|) (|x| NIL))
+    (LOOP
+     (COND
+      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+       (RETURN |bfVar#2|))
+      (T (SETQ |bfVar#2| (APPLY |f| |x| NIL))
+       (COND (|bfVar#2| (RETURN |bfVar#2|)))))
+     (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
+(DEFUN |takeWhile| (|f| |l|)
+  (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|x| NIL))
+    (LOOP
+     (COND
+      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)
+           (NOT (APPLY |f| |x| NIL)))
+       (RETURN |bfVar#2|))
+      ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |x| NIL))
+       (SETQ |bfVar#3| |bfVar#2|))
+      (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+     (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+
 (DEFUN |copyTree| (|t|)
   (COND ((CONSP |t|) (CONS (|copyTree| (CAR |t|)) (|copyTree| (CDR |t|))))
         (T |t|)))
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 7179d8fa..a58f55eb 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -380,17 +380,13 @@ shoeOutParse stream ==
  
 ++ Generate a global signature declaration for symbol `n'.
 genDeclaration(n,t) ==
-  t is ["%Mapping",valType,argTypes] =>
-    if bfTupleP argTypes then argTypes := rest argTypes
-    if argTypes ~= nil and symbol? argTypes 
-    then argTypes := [argTypes]
-    ["DECLAIM",["FTYPE",["FUNCTION",argTypes,valType],n]]
+  t is ["%Mapping",:.] => ["DECLAIM",["FTYPE",bfType t,n]]
   t is ["%Forall",vars,t'] =>
     vars = nil => genDeclaration(n,t')
     if symbol? vars then
       vars := [vars]
     genDeclaration(n,applySubst([[v,:"*"] for v in vars],t'))
-  ["DECLAIM",["TYPE",t,n]]
+  ["DECLAIM",["TYPE",bfType t,n]]
 
 ++ Translate the signature declaration `d' to its Lisp equivalent.
 translateSignatureDeclaration d ==
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 5b870a6d..6e08acb5 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -48,7 +48,8 @@ module utility (objectMember?, symbolMember?, stringMember?,
   lastNode, append, append!, copyList, substitute, substitute!,
   setDifference, setUnion, setIntersection,
   symbolAssoc, applySubst, applySubst!, applySubstNQ, objectAssoc,
-  remove,removeSymbol,atomic?,copyTree,finishLine) where
+  remove, removeSymbol, atomic?, every?, any?, takeWhile, copyTree,
+  finishLine) where
     substitute: (%Thing,%Thing,%Thing) -> %Thing
     substitute!: (%Thing,%Thing,%Thing) -> %Thing
     append: (%List %Thing,%List %Thing) -> %List %Thing
@@ -63,6 +64,9 @@ module utility (objectMember?, symbolMember?, stringMember?,
     setUnion: (%List %Thing,%List %Thing) -> %List %Thing
     setIntersection: (%List %Thing,%List %Thing) -> %List %Thing
     atomic?: %Thing -> %Boolean
+    every?: (%Thing -> %Thing, %List %Thing) -> %Thing
+    any?: (%Thing -> %Thing, %List %Thing) -> %Thing
+    takeWhile: (%Thing -> %Thing, %List %Thing) -> %List %Thing
     copyTree: %Thing -> %Thing
     finishLine: %Thing -> %Void
     --FIXME: Next signature commented out because of GCL bugs
@@ -77,6 +81,19 @@ module utility (objectMember?, symbolMember?, stringMember?,
 atomic? x ==
   x isnt [.,:.] or x.op is 'QUOTE
 
+++ Return the last image of `f' if all images of elements in `l'
+++ are non-nil.  Otherwise return nil.
+every?(f,l) ==
+  and/[apply(f,x,nil) for x in l]
+
+++ Return the first non-nil image of `f' of elements in `l'.
+any?(f,l) ==
+  or/[apply(f,x,nil) for x in l]
+
+++ Return the sublist of `l' whose elements have non-nil image by `f'.
+takeWhile(f,l) ==
+  [x for x in l while apply(f,x,nil)]
+
 copyTree t ==
   t is [.,:.] => [copyTree first t,:copyTree rest t]
   t