From b6dd0415650fe24621a42ad676960697f77ca96c Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 26 Jun 2010 14:00:47 +0000 Subject: * algebra/aggcat.spad.pamphlet (HomogeneousAggregate): Satisfy BasicType if element type satisfies it. --- src/algebra/strap/HOAGG-.lsp | 95 +++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 46 deletions(-) (limited to 'src/algebra/strap/HOAGG-.lsp') diff --git a/src/algebra/strap/HOAGG-.lsp b/src/algebra/strap/HOAGG-.lsp index 22fc5a79..c5d5b902 100644 --- a/src/algebra/strap/HOAGG-.lsp +++ b/src/algebra/strap/HOAGG-.lsp @@ -20,15 +20,15 @@ (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%List|) |HOAGG-;members;AL;6|)) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Boolean|) + |HOAGG-;=;2AB;7|)) + (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) (|%IntegerSection| 0)) - |HOAGG-;count;SANni;7|)) + |HOAGG-;count;SANni;8|)) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Boolean|) - |HOAGG-;member?;SAB;8|)) - -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Boolean|) - |HOAGG-;=;2AB;9|)) + |HOAGG-;member?;SAB;9|)) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) |HOAGG-;coerce;AOf;10|)) @@ -88,35 +88,19 @@ (DEFUN |HOAGG-;members;AL;6| (|x| $) (SPADCALL |x| (|getShellEntry| $ 15))) -(DEFUN |HOAGG-;count;SANni;7| (|s| |x| $) - (SPADCALL (CONS #'|HOAGG-;count;SANni;7!0| (VECTOR $ |s|)) |x| - (|getShellEntry| $ 33))) - -(DEFUN |HOAGG-;count;SANni;7!0| (|#1| $$) - (SPADCALL (|getShellEntry| $$ 1) |#1| - (|getShellEntry| (|getShellEntry| $$ 0) 32))) - -(DEFUN |HOAGG-;member?;SAB;8| (|e| |c| $) - (SPADCALL (CONS #'|HOAGG-;member?;SAB;8!0| (VECTOR $ |e|)) |c| - (|getShellEntry| $ 35))) - -(DEFUN |HOAGG-;member?;SAB;8!0| (|#1| $$) - (SPADCALL (|getShellEntry| $$ 1) |#1| - (|getShellEntry| (|getShellEntry| $$ 0) 32))) - -(DEFUN |HOAGG-;=;2AB;9| (|x| |y| $) +(DEFUN |HOAGG-;=;2AB;7| (|x| |y| $) (COND - ((SPADCALL |x| (SPADCALL |y| (|getShellEntry| $ 37)) - (|getShellEntry| $ 38)) - (LET ((#0=#:G1421 NIL) (#1=#:G1422 T) + ((SPADCALL |x| (SPADCALL |y| (|getShellEntry| $ 32)) + (|getShellEntry| $ 33)) + (LET ((#0=#:G1419 NIL) (#1=#:G1420 T) (#2=#:G1431 (SPADCALL |x| (|getShellEntry| $ 15))) (#3=#:G1432 (SPADCALL |y| (|getShellEntry| $ 15)))) (LOOP (COND ((OR (ATOM #2#) (ATOM #3#)) (RETURN (COND (#1# T) (T #0#)))) (T (LET ((|a| (CAR #2#)) (|b| (CAR #3#))) - (LET ((#4=#:G1420 - (SPADCALL |a| |b| (|getShellEntry| $ 32)))) + (LET ((#4=#:G1418 + (SPADCALL |a| |b| (|getShellEntry| $ 34)))) (COND (#1# (SETQ #0# #4#)) (T (SETQ #0# (AND #0# #4#)))) @@ -125,6 +109,22 @@ (SETQ #3# (CDR #3#))))) ('T NIL))) +(DEFUN |HOAGG-;count;SANni;8| (|s| |x| $) + (SPADCALL (CONS #'|HOAGG-;count;SANni;8!0| (VECTOR $ |s|)) |x| + (|getShellEntry| $ 36))) + +(DEFUN |HOAGG-;count;SANni;8!0| (|#1| $$) + (SPADCALL (|getShellEntry| $$ 1) |#1| + (|getShellEntry| (|getShellEntry| $$ 0) 34))) + +(DEFUN |HOAGG-;member?;SAB;9| (|e| |c| $) + (SPADCALL (CONS #'|HOAGG-;member?;SAB;9!0| (VECTOR $ |e|)) |c| + (|getShellEntry| $ 38))) + +(DEFUN |HOAGG-;member?;SAB;9!0| (|#1| $$) + (SPADCALL (|getShellEntry| $$ 1) |#1| + (|getShellEntry| (|getShellEntry| $$ 0) 34))) + (DEFUN |HOAGG-;coerce;AOf;10| (|x| $) (SPADCALL (SPADCALL @@ -151,6 +151,7 @@ (|HasCategory| |#2| (LIST '|Evalable| (|devaluate| |#2|))) (|HasCategory| |#2| '(|SetCategory|)) + (|HasCategory| |#2| '(|BasicType|)) (|HasCategory| |#2| (LIST '|CoercibleTo| '(|OutputForm|))))))) (|setShellEntry| $ 0 |dv$|) @@ -175,17 +176,19 @@ (CONS (|dispatchFunction| |HOAGG-;count;MANni;5|) $)) (|setShellEntry| $ 31 (CONS (|dispatchFunction| |HOAGG-;members;AL;6|) $)) + (COND + ((|testBitVector| |pv$| 5) + (|setShellEntry| $ 35 + (CONS (|dispatchFunction| |HOAGG-;=;2AB;7|) $)))) (COND ((|testBitVector| |pv$| 4) (PROGN - (|setShellEntry| $ 34 - (CONS (|dispatchFunction| |HOAGG-;count;SANni;7|) $)) - (|setShellEntry| $ 36 - (CONS (|dispatchFunction| |HOAGG-;member?;SAB;8|) $)) + (|setShellEntry| $ 37 + (CONS (|dispatchFunction| |HOAGG-;count;SANni;8|) $)) (|setShellEntry| $ 39 - (CONS (|dispatchFunction| |HOAGG-;=;2AB;9|) $))))) + (CONS (|dispatchFunction| |HOAGG-;member?;SAB;9|) $))))) (COND - ((|testBitVector| |pv$| 5) + ((|testBitVector| |pv$| 6) (|setShellEntry| $ 45 (CONS (|dispatchFunction| |HOAGG-;coerce;AOf;10|) $))))))) $)) @@ -198,10 +201,10 @@ (33 . |or|) (39 . |false|) (|Mapping| 19 7) (43 . |any?|) (49 . |and|) (55 . |true|) (59 . |every?|) (65 . |One|) (69 . +) (75 . |Zero|) (79 . |count|) (85 . |members|) - (90 . =) (96 . |count|) (102 . |count|) (108 . |any?|) - (114 . |member?|) (120 . |#|) (125 . |size?|) (131 . =) - (|OutputForm|) (137 . |coerce|) (|List| $) - (142 . |commaSeparate|) (147 . |bracket|) + (90 . |#|) (95 . |size?|) (101 . =) (107 . =) + (113 . |count|) (119 . |count|) (125 . |any?|) + (131 . |member?|) (|OutputForm|) (137 . |coerce|) + (|List| $) (142 . |commaSeparate|) (147 . |bracket|) (152 . |coerce|)) '#(|members| 157 |member?| 162 |every?| 168 |eval| 174 |count| 180 |coerce| 192 |any?| 197 = 203 |#| 209) @@ -215,13 +218,13 @@ 18 2 19 0 0 0 20 0 19 0 21 2 0 19 22 0 23 2 19 0 0 0 24 0 19 0 25 2 0 19 22 0 26 0 16 0 27 2 16 0 0 0 28 0 16 - 0 29 2 0 16 22 0 30 1 0 14 0 31 2 7 - 19 0 0 32 2 6 16 22 0 33 2 0 16 7 0 - 34 2 6 19 22 0 35 2 0 19 7 0 36 1 6 - 16 0 37 2 6 19 0 16 38 2 0 19 0 0 39 - 1 7 40 0 41 1 40 0 42 43 1 40 0 0 44 - 1 0 40 0 45 1 0 14 0 31 2 0 19 7 0 36 - 2 0 19 22 0 26 2 0 0 0 9 13 2 0 16 7 - 0 34 2 0 16 22 0 30 1 0 40 0 45 2 0 - 19 22 0 23 2 0 19 0 0 39 1 0 16 0 18))))) + 0 29 2 0 16 22 0 30 1 0 14 0 31 1 6 + 16 0 32 2 6 19 0 16 33 2 7 19 0 0 34 + 2 0 19 0 0 35 2 6 16 22 0 36 2 0 16 7 + 0 37 2 6 19 22 0 38 2 0 19 7 0 39 1 7 + 40 0 41 1 40 0 42 43 1 40 0 0 44 1 0 + 40 0 45 1 0 14 0 31 2 0 19 7 0 39 2 0 + 19 22 0 26 2 0 0 0 9 13 2 0 16 7 0 37 + 2 0 16 22 0 30 1 0 40 0 45 2 0 19 22 + 0 23 2 0 19 0 0 35 1 0 16 0 18))))) '|lookupComplete|)) -- cgit v1.2.3