* 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.

4 files changed, 99 insertions, 19 deletions

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|)))