diff options
| author | dos-reis <gdr@axiomatics.org> | 2009-01-06 06:53:21 +0000 |
|---|---|---|
| committer | dos-reis <gdr@axiomatics.org> | 2009-01-06 06:53:21 +0000 |
| commit | 258d6427280f1ee0cce0dcdf12c38ad65b5e36cc (patch) | |
| tree | 7c37449e24bbcfba741729b6d16a71b9c5007ea4 | |
| parent | bd3fb898659b91542e7a3109f36b2f8b17e05a5d (diff) | |
| download | open-axiom-258d6427280f1ee0cce0dcdf12c38ad65b5e36cc.tar.gz | |
* interp/sys-utility.boot (getVMType): IndexList are lists.
* interp/g-util.boot (isSubDomain): Tidy.
* interp/g-opt.boot (isVMConstantForm): New.
(findVMFreeVars): Likewise.
* interp/define.boot (insertViewMorphisms): Remove.
(emitSubdomainInfo): New.
(checkVariableName): Likewise.
(checkParameterNames): Likewise.
(checkRepresentation): Set $subdomain where appropriate.
(compDefines): Check parameter names.
(compDefineFunctor1): Propagate subdomain info.
(doIt): Don't call insertViewMorphisms.
* interp/compiler.boot (setqSingle): Check variable name.
(compIterator): Likewise.
(commonSuperType): New.
(satisfies): Likewise.
(coerceSubset): Use them to implemen cross-subdomain coercion.
(coerceSuperset): New.
(comCoerce1): Use it.
(compPer): New.
(compRep): Likewise.
* interp/c-util.boot (getRepresentation): New.
(proclaimCapsuleFunction): Improve for specialized subdomains.
* algebra/stream.spad.pamphlet: Don't use `per' as variable name.
* algebra/si.spad.pamphlet (size$SingleInteger): Tidy.
(coerce$SingleInteger): Likewise.
* algebra/reclos.spad.pamphlet (nonNull$RealClosure): Don't use
`rep' as parameter name.
* algebra/data.spad.pamphlet (Byte): Now a subdomain of
NonNegativeInteger. Tidy.
87 files changed, 807 insertions, 587 deletions
@@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.60 for OpenAxiom 1.3.0-2009-01-03. +# Generated by GNU Autoconf 2.60 for OpenAxiom 1.3.0-2009-01-05. # # Report bugs to <open-axiom-bugs@lists.sf.net>. # @@ -713,8 +713,8 @@ SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='OpenAxiom' PACKAGE_TARNAME='openaxiom' -PACKAGE_VERSION='1.3.0-2009-01-03' -PACKAGE_STRING='OpenAxiom 1.3.0-2009-01-03' +PACKAGE_VERSION='1.3.0-2009-01-05' +PACKAGE_STRING='OpenAxiom 1.3.0-2009-01-05' PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net' ac_unique_file="src/Makefile.pamphlet" @@ -1405,7 +1405,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures OpenAxiom 1.3.0-2009-01-03 to adapt to many kinds of systems. +\`configure' configures OpenAxiom 1.3.0-2009-01-05 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1475,7 +1475,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of OpenAxiom 1.3.0-2009-01-03:";; + short | recursive ) echo "Configuration of OpenAxiom 1.3.0-2009-01-05:";; esac cat <<\_ACEOF @@ -1579,7 +1579,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -OpenAxiom configure 1.3.0-2009-01-03 +OpenAxiom configure 1.3.0-2009-01-05 generated by GNU Autoconf 2.60 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, @@ -1593,7 +1593,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by OpenAxiom $as_me 1.3.0-2009-01-03, which was +It was created by OpenAxiom $as_me 1.3.0-2009-01-05, which was generated by GNU Autoconf 2.60. Invocation command line was $ $0 $@ @@ -26424,7 +26424,7 @@ exec 6>&1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by OpenAxiom $as_me 1.3.0-2009-01-03, which was +This file was extended by OpenAxiom $as_me 1.3.0-2009-01-05, which was generated by GNU Autoconf 2.60. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -26473,7 +26473,7 @@ Report bugs to <bug-autoconf@gnu.org>." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -OpenAxiom config.status 1.3.0-2009-01-03 +OpenAxiom config.status 1.3.0-2009-01-05 configured by $0, generated by GNU Autoconf 2.60, with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.ac b/configure.ac index 537aec75..ab01e655 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.3.0-2009-01-03], +AC_INIT([OpenAxiom], [1.3.0-2009-01-05], [open-axiom-bugs@lists.sf.net]) AC_CONFIG_AUX_DIR(config) diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet index 3e4b757b..c88ce121 100644 --- a/configure.ac.pamphlet +++ b/configure.ac.pamphlet @@ -1126,7 +1126,7 @@ information: <<Autoconf init>>= sinclude(config/open-axiom.m4) sinclude(config/aclocal.m4) -AC_INIT([OpenAxiom], [1.3.0-2009-01-03], +AC_INIT([OpenAxiom], [1.3.0-2009-01-05], [open-axiom-bugs@lists.sf.net]) @ diff --git a/src/ChangeLog b/src/ChangeLog index 17c7ef0d..8053d465 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,36 @@ +2009-01-06 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/sys-utility.boot (getVMType): IndexList are lists. + * interp/g-util.boot (isSubDomain): Tidy. + * interp/g-opt.boot (isVMConstantForm): New. + (findVMFreeVars): Likewise. + * interp/define.boot (insertViewMorphisms): Remove. + (emitSubdomainInfo): New. + (checkVariableName): Likewise. + (checkParameterNames): Likewise. + (checkRepresentation): Set $subdomain where appropriate. + (compDefines): Check parameter names. + (compDefineFunctor1): Propagate subdomain info. + (doIt): Don't call insertViewMorphisms. + * interp/compiler.boot (setqSingle): Check variable name. + (compIterator): Likewise. + (commonSuperType): New. + (satisfies): Likewise. + (coerceSubset): Use them to implemen cross-subdomain coercion. + (coerceSuperset): New. + (comCoerce1): Use it. + (compPer): New. + (compRep): Likewise. + * interp/c-util.boot (getRepresentation): New. + (proclaimCapsuleFunction): Improve for specialized subdomains. + * algebra/stream.spad.pamphlet: Don't use `per' as variable name. + * algebra/si.spad.pamphlet (size$SingleInteger): Tidy. + (coerce$SingleInteger): Likewise. + * algebra/reclos.spad.pamphlet (nonNull$RealClosure): Don't use + `rep' as parameter name. + * algebra/data.spad.pamphlet (Byte): Now a subdomain of + NonNegativeInteger. Tidy. + 2009-01-04 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/daase.lisp (setdatabase): Set superdomain slot too. diff --git a/src/algebra/data.spad.pamphlet b/src/algebra/data.spad.pamphlet index 123948b3..d684c59d 100644 --- a/src/algebra/data.spad.pamphlet +++ b/src/algebra/data.spad.pamphlet @@ -25,39 +25,23 @@ import OutputForm ++ Description: ++ Byte is the datatype of 8-bit sized unsigned integer values. Byte(): Public == Private where - Public == Join(OrderedSet, CoercibleTo NonNegativeInteger, - HomotopicTo Character) with + Public == Join(OrderedSet, HomotopicTo Character) with byte: NonNegativeInteger -> % ++ byte(x) injects the unsigned integer value `v' into ++ the Byte algebra. `v' must be non-negative and less than 256. - coerce: NonNegativeInteger -> % - ++ coerce(x) has the same effect as byte(x). bitand: (%,%) -> % ++ bitand(x,y) returns the bitwise `and' of `x' and `y'. bitior: (%,%) -> % ++ bitor(x,y) returns the bitwise `inclusive or' of `x' and `y'. sample: () -> % ++ sample() returns a sample datum of type Byte. - Private == add - byte(x: NonNegativeInteger): % == - not (x < 256$Lisp) => - userError "integer value cannot be represented by a byte" - x : % + Private == SubDomain(NonNegativeInteger, #1 < 256) add + byte(x: NonNegativeInteger): % == x::% sample() = 0$Lisp - hash x == SXHASH(x)$Lisp - - coerce(x: NonNegativeInteger): % == byte x - coerce(x: %): NonNegativeInteger == x : NonNegativeInteger - coerce(c: Character) == ord(c)::% - coerce(x: %): Character == char(x::NonNegativeInteger) - - coerce(x: %): OutputForm == - x::NonNegativeInteger::OutputForm - + coerce(x: %): Character == char rep x x = y == byteEqual(x,y)$Lisp x < y == byteLessThan(x,y)$Lisp - bitand(x,y) == bitand(x,y)$Lisp bitior(x,y) == bitior(x,y)$Lisp @ diff --git a/src/algebra/reclos.spad.pamphlet b/src/algebra/reclos.spad.pamphlet index e5d2ece2..3aa33230 100644 --- a/src/algebra/reclos.spad.pamphlet +++ b/src/algebra/reclos.spad.pamphlet @@ -1137,11 +1137,11 @@ RealClosure(TheField): PUB == PRIV where x.outForm, x.order]$Rec) - nonNull(rep:Rec):$ == - degree(rep.val)=0 => leadingCoefficient(rep.val) - numberOfMonomials(rep.val) = 1 => rep - zero?(rep.val,rep.seg)$SEG => 0 - rep + nonNull(r:Rec):$ == + degree(r.val)=0 => leadingCoefficient(r.val) + numberOfMonomials(r.val) = 1 => r + zero?(r.val,r.seg)$SEG => 0 + r -- zero?(x) == -- x case TheField => zero?(x)$TheField diff --git a/src/algebra/si.spad.pamphlet b/src/algebra/si.spad.pamphlet index 809a9f67..b6767706 100644 --- a/src/algebra/si.spad.pamphlet +++ b/src/algebra/si.spad.pamphlet @@ -319,9 +319,7 @@ SingleInteger(): Join(IntegerNumberSystem,OrderedFinite,Logic,OpenMath) with submod(a,b,p) == QSDIFMOD(a,b,p)$Lisp negative?(x) == QSMINUSP$Lisp x size() == (MAXINT -$Lisp MININT +$Lisp 1$Lisp) pretend NonNegativeInteger - index i == - i > size() => error ["index %1b out of range",i] - per(i + MININT - 1$Lisp) + index i == per(i + MININT - 1$Lisp) lookup x == (x -$Lisp MININT +$Lisp 1$Lisp) pretend PositiveInteger @@ -336,9 +334,7 @@ SingleInteger(): Join(IntegerNumberSystem,OrderedFinite,Logic,OpenMath) with QSPLUS(r, n)$Lisp r - coerce(x:Integer):% == - (x <= rep max) and (x >= rep min) => per x - error "integer too large to represent in a machine word" + coerce(x:Integer):% == per x random() == seed := REMAINDER(TIMES(MULTIPLIER,seed)$Lisp,MODULUS)$Lisp diff --git a/src/algebra/strap/ABELGRP.lsp b/src/algebra/strap/ABELGRP.lsp index e2f7daf4..467559ce 100644 --- a/src/algebra/strap/ABELGRP.lsp +++ b/src/algebra/strap/ABELGRP.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |AbelianGroup;AL| 'NIL) (DEFUN |AbelianGroup;| () - (PROG (#0=#:G1398) + (PROG (#0=#:G1399) (RETURN (PROG1 (LETT #0# (|Join| (|CancellationAbelianMonoid|) diff --git a/src/algebra/strap/ABELMON.lsp b/src/algebra/strap/ABELMON.lsp index af28662b..85ac824d 100644 --- a/src/algebra/strap/ABELMON.lsp +++ b/src/algebra/strap/ABELMON.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |AbelianMonoid;AL| 'NIL) (DEFUN |AbelianMonoid;| () - (PROG (#0=#:G1398) + (PROG (#0=#:G1399) (RETURN (PROG1 (LETT #0# (|Join| (|AbelianSemiGroup|) diff --git a/src/algebra/strap/ABELSG.lsp b/src/algebra/strap/ABELSG.lsp index 062071e2..fa84d4fa 100644 --- a/src/algebra/strap/ABELSG.lsp +++ b/src/algebra/strap/ABELSG.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |AbelianSemiGroup;AL| 'NIL) (DEFUN |AbelianSemiGroup;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|SetCategory|) diff --git a/src/algebra/strap/ALAGG.lsp b/src/algebra/strap/ALAGG.lsp index 8d0f1fea..59eceb44 100644 --- a/src/algebra/strap/ALAGG.lsp +++ b/src/algebra/strap/ALAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |AssociationListAggregate;AL| 'NIL) (DEFUN |AssociationListAggregate;| (|t#1| |t#2|) - (PROG (#0=#:G1399) + (PROG (#0=#:G1400) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -14,7 +14,7 @@ (LIST (|devaluate| |t#1|) (|devaluate| |t#2|))) (|sublisV| - (PAIR '(#1=#:G1398) + (PAIR '(#1=#:G1399) (LIST '(|Record| (|:| |key| |t#1|) (|:| |entry| |t#2|)))) (COND @@ -38,9 +38,9 @@ (LIST '|AssociationListAggregate| (|devaluate| |t#1|) (|devaluate| |t#2|))))))) -(DEFUN |AssociationListAggregate| (&REST #0=#:G1402 &AUX #1=#:G1400) +(DEFUN |AssociationListAggregate| (&REST #0=#:G1403 &AUX #1=#:G1401) (DSETQ #1# #0#) - (LET (#2=#:G1401) + (LET (#2=#:G1402) (COND ((SETQ #2# (|assoc| (|devaluateList| #1#) diff --git a/src/algebra/strap/BOOLEAN.lsp b/src/algebra/strap/BOOLEAN.lsp index 2b44cfda..882c8a74 100644 --- a/src/algebra/strap/BOOLEAN.lsp +++ b/src/algebra/strap/BOOLEAN.lsp @@ -157,7 +157,7 @@ (DEFUN |Boolean| () (PROG () (RETURN - (PROG (#0=#:G1425) + (PROG (#0=#:G1426) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|Boolean|) |Boolean|) diff --git a/src/algebra/strap/CABMON.lsp b/src/algebra/strap/CABMON.lsp index 11a8f26a..60c3073e 100644 --- a/src/algebra/strap/CABMON.lsp +++ b/src/algebra/strap/CABMON.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |CancellationAbelianMonoid;AL| 'NIL) (DEFUN |CancellationAbelianMonoid;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|AbelianMonoid|) diff --git a/src/algebra/strap/CHAR.lsp b/src/algebra/strap/CHAR.lsp index 6dd6b594..9fd5e64d 100644 --- a/src/algebra/strap/CHAR.lsp +++ b/src/algebra/strap/CHAR.lsp @@ -96,17 +96,18 @@ (DEFUN |CHAR;size;Nni;3| ($) (DECLARE (IGNORE $)) 256) (DEFUN |CHAR;index;Pi$;4| (|n| $) - (PROG (#0=#:G1401) + (PROG (#0=#:G1402) (RETURN (CODE-CHAR (PROG1 (LETT #0# (- |n| 1) |CHAR;index;Pi$;4|) - (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) #0#)))))) + (|check-subtype| (COND ((< #0# 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) #0#)))))) (DEFUN |CHAR;lookup;$Pi;5| (|c| $) - (PROG (#0=#:G1403) + (PROG (#0=#:G1404) (RETURN (PROG1 (LETT #0# (+ 1 (CHAR-CODE |c|)) |CHAR;lookup;$Pi;5|) - (|check-subtype| (> #0# 0) '(|PositiveInteger|) #0#))))) + (|check-subtype| (< 0 #0#) '(|PositiveInteger|) #0#))))) (DEFUN |CHAR;char;Nni$;6| (|n| $) (DECLARE (IGNORE $)) @@ -163,7 +164,7 @@ (DEFUN |Character| () (PROG () (RETURN - (PROG (#0=#:G1424) + (PROG (#0=#:G1425) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|Character|) diff --git a/src/algebra/strap/CLAGG-.lsp b/src/algebra/strap/CLAGG-.lsp index 09d47ce4..8af8cab5 100644 --- a/src/algebra/strap/CLAGG-.lsp +++ b/src/algebra/strap/CLAGG-.lsp @@ -45,7 +45,7 @@ (LENGTH (SPADCALL |c| (|getShellEntry| $ 9)))) (DEFUN |CLAGG-;count;MANni;2| (|f| |c| $) - (PROG (|x| #0=#:G1429 #1=#:G1403 #2=#:G1401 #3=#:G1402) + (PROG (|x| #0=#:G1430 #1=#:G1404 #2=#:G1402 #3=#:G1403) (RETURN (SEQ (PROGN (LETT #3# NIL |CLAGG-;count;MANni;2|) @@ -78,7 +78,7 @@ (COND (#3# #2#) ('T 0))))))) (DEFUN |CLAGG-;any?;MAB;3| (|f| |c| $) - (PROG (|x| #0=#:G1430 #1=#:G1408 #2=#:G1406 #3=#:G1407) + (PROG (|x| #0=#:G1431 #1=#:G1409 #2=#:G1407 #3=#:G1408) (RETURN (SEQ (PROGN (LETT #3# NIL |CLAGG-;any?;MAB;3|) @@ -108,7 +108,7 @@ (COND (#3# #2#) ('T 'NIL))))))) (DEFUN |CLAGG-;every?;MAB;4| (|f| |c| $) - (PROG (|x| #0=#:G1431 #1=#:G1412 #2=#:G1410 #3=#:G1411) + (PROG (|x| #0=#:G1432 #1=#:G1413 #2=#:G1411 #3=#:G1412) (RETURN (SEQ (PROGN (LETT #3# NIL |CLAGG-;every?;MAB;4|) diff --git a/src/algebra/strap/CLAGG.lsp b/src/algebra/strap/CLAGG.lsp index a7cff743..0e38f978 100644 --- a/src/algebra/strap/CLAGG.lsp +++ b/src/algebra/strap/CLAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |Collection;AL| 'NIL) (DEFUN |Collection;| (|t#1|) - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -93,8 +93,8 @@ (|setShellEntry| #0# 0 (LIST '|Collection| (|devaluate| |t#1|))))))) -(DEFUN |Collection| (#0=#:G1398) - (LET (#1=#:G1399) +(DEFUN |Collection| (#0=#:G1399) + (LET (#1=#:G1400) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |Collection;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/COMRING.lsp b/src/algebra/strap/COMRING.lsp index 01ad8233..765ee131 100644 --- a/src/algebra/strap/COMRING.lsp +++ b/src/algebra/strap/COMRING.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |CommutativeRing;AL| 'NIL) (DEFUN |CommutativeRing;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|Ring|) (|BiModule| '$ '$) diff --git a/src/algebra/strap/DFLOAT.lsp b/src/algebra/strap/DFLOAT.lsp index 822d20da..7a5876ff 100644 --- a/src/algebra/strap/DFLOAT.lsp +++ b/src/algebra/strap/DFLOAT.lsp @@ -431,7 +431,7 @@ (FLOAT-DIGITS 0.0)) (DEFUN |DFLOAT;bits;Pi;10| ($) - (PROG (#0=#:G1422) + (PROG (#0=#:G1423) (RETURN (COND ((EQL (FLOAT-RADIX 0.0) 2) (FLOAT-DIGITS 0.0)) @@ -445,7 +445,9 @@ $) (|getShellEntry| $ 29))) |DFLOAT;bits;Pi;10|) - (|check-subtype| (> #0# 0) '(|PositiveInteger|) #0#))))))) + (|check-subtype| + (AND (COND ((< #0# 0) 'NIL) ('T 'T)) (< 0 #0#)) + '(|PositiveInteger|) #0#))))))) (DEFUN |DFLOAT;max;$;11| ($) (DECLARE (IGNORE $)) @@ -627,23 +629,24 @@ (EXIT |theta|)))))))) (DEFUN |DFLOAT;retract;$F;76| (|x| $) - (PROG (#0=#:G1497) + (PROG (#0=#:G1498) (RETURN (|DFLOAT;rationalApproximation;$2NniF;83| |x| (PROG1 (LETT #0# (- (FLOAT-DIGITS 0.0) 1) |DFLOAT;retract;$F;76|) - (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) #0#)) + (|check-subtype| (COND ((< #0# 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) #0#)) (FLOAT-RADIX 0.0) $)))) (DEFUN |DFLOAT;retractIfCan;$U;77| (|x| $) - (PROG (#0=#:G1502) + (PROG (#0=#:G1503) (RETURN (CONS 0 (|DFLOAT;rationalApproximation;$2NniF;83| |x| (PROG1 (LETT #0# (- (FLOAT-DIGITS 0.0) 1) |DFLOAT;retractIfCan;$U;77|) - (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) - #0#)) + (|check-subtype| (COND ((< #0# 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) #0#)) (FLOAT-RADIX 0.0) $))))) (DEFUN |DFLOAT;retract;$I;78| (|x| $) @@ -671,7 +674,7 @@ (FLOAT-SIGN 1.0 |x|)) (DEFUN |DFLOAT;manexp| (|x| $) - (PROG (|s| #0=#:G1523 |me| |two53|) + (PROG (|s| #0=#:G1524 |me| |two53|) (RETURN (SEQ (EXIT (COND ((ZEROP |x|) (CONS 0 0)) @@ -705,9 +708,9 @@ #0# (EXIT #0#))))) (DEFUN |DFLOAT;rationalApproximation;$2NniF;83| (|f| |d| |b| $) - (PROG (|#G102| |nu| |ex| BASE #0=#:G1526 |de| |tol| |#G103| |q| |r| - |p2| |q2| #1=#:G1544 |#G104| |#G105| |p0| |p1| |#G106| - |#G107| |q0| |q1| |#G108| |#G109| |s| |t| #2=#:G1542) + (PROG (|#G102| |nu| |ex| BASE #0=#:G1527 |de| |tol| |#G103| |q| |r| + |p2| |q2| #1=#:G1535 |#G104| |#G105| |p0| |p1| |#G106| + |#G107| |q0| |q1| |#G108| |#G109| |s| |t|) (RETURN (SEQ (EXIT (SEQ (PROGN (LETT |#G102| (|DFLOAT;manexp| |f| $) @@ -726,7 +729,10 @@ (PROG1 (LETT #0# (- |ex|) |DFLOAT;rationalApproximation;$2NniF;83|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND + ((< #0# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #0#))) |DFLOAT;rationalApproximation;$2NniF;83|) (EXIT @@ -819,16 +825,17 @@ (SPADCALL (* |nu| (EXPT BASE - (PROG1 - (LETT #2# |ex| - |DFLOAT;rationalApproximation;$2NniF;83|) - (|check-subtype| (>= #2# 0) - '(|NonNegativeInteger|) #2#)))) + (PROG1 |ex| + (|check-subtype| + (COND + ((< |ex| 0) 'NIL) + ('T 'T)) + '(|NonNegativeInteger|) |ex|)))) (|getShellEntry| $ 120))))))) #1# (EXIT #1#))))) (DEFUN |DFLOAT;**;$F$;84| (|x| |r| $) - (PROG (|n| |d| #0=#:G1553) + (PROG (|n| |d| #0=#:G1544) (RETURN (SEQ (EXIT (COND ((ZEROP |x|) @@ -892,7 +899,7 @@ (DEFUN |DoubleFloat| () (PROG () (RETURN - (PROG (#0=#:G1566) + (PROG (#0=#:G1557) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|DoubleFloat|) diff --git a/src/algebra/strap/DIFRING.lsp b/src/algebra/strap/DIFRING.lsp index 89e91f31..83564864 100644 --- a/src/algebra/strap/DIFRING.lsp +++ b/src/algebra/strap/DIFRING.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |DifferentialRing;AL| 'NIL) (DEFUN |DifferentialRing;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|Ring|) diff --git a/src/algebra/strap/DIVRING.lsp b/src/algebra/strap/DIVRING.lsp index ce6499f5..804f4abb 100644 --- a/src/algebra/strap/DIVRING.lsp +++ b/src/algebra/strap/DIVRING.lsp @@ -4,11 +4,11 @@ (DEFPARAMETER |DivisionRing;AL| 'NIL) (DEFUN |DivisionRing;| () - (PROG (#0=#:G1400) + (PROG (#0=#:G1401) (RETURN (PROG1 (LETT #0# (|sublisV| - (PAIR '(#1=#:G1399) + (PAIR '(#1=#:G1400) (LIST '(|Fraction| (|Integer|)))) (|Join| (|EntireRing|) (|Algebra| '#1#) (|mkCategory| '|domain| diff --git a/src/algebra/strap/ENTIRER.lsp b/src/algebra/strap/ENTIRER.lsp index d82918d3..76e417cd 100644 --- a/src/algebra/strap/ENTIRER.lsp +++ b/src/algebra/strap/ENTIRER.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |EntireRing;AL| 'NIL) (DEFUN |EntireRing;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|Ring|) (|BiModule| '$ '$) diff --git a/src/algebra/strap/ES-.lsp b/src/algebra/strap/ES-.lsp index fd867a6d..0d783c8e 100644 --- a/src/algebra/strap/ES-.lsp +++ b/src/algebra/strap/ES-.lsp @@ -159,7 +159,7 @@ (SPADCALL (|ES-;listk| |f| $) (|getShellEntry| $ 27))) (DEFUN |ES-;allk| (|l| $) - (PROG (#0=#:G1578 |f| #1=#:G1579) + (PROG (#0=#:G1579 |f| #1=#:G1580) (RETURN (SEQ (SPADCALL (ELT $ 32) (PROGN @@ -182,7 +182,7 @@ (|getShellEntry| $ 35)))))) (DEFUN |ES-;operators;SL;7| (|f| $) - (PROG (#0=#:G1580 |k| #1=#:G1581) + (PROG (#0=#:G1581 |k| #1=#:G1582) (RETURN (SEQ (PROGN (LETT #0# NIL |ES-;operators;SL;7|) @@ -205,7 +205,7 @@ G191 (EXIT (NREVERSE0 #0#)))))))) (DEFUN |ES-;height;SNni;8| (|f| $) - (PROG (#0=#:G1582 |k| #1=#:G1583) + (PROG (#0=#:G1583 |k| #1=#:G1584) (RETURN (SEQ (SPADCALL (ELT $ 42) (PROGN @@ -231,7 +231,7 @@ 0 (|getShellEntry| $ 45)))))) (DEFUN |ES-;freeOf?;SSB;9| (|x| |s| $) - (PROG (#0=#:G1584 |k| #1=#:G1585) + (PROG (#0=#:G1585 |k| #1=#:G1586) (RETURN (SEQ (NOT (SPADCALL |s| (PROGN @@ -258,7 +258,7 @@ (|getShellEntry| $ 49))))))) (DEFUN |ES-;distribute;2S;10| (|x| $) - (PROG (#0=#:G1586 |k| #1=#:G1587) + (PROG (#0=#:G1587 |k| #1=#:G1588) (RETURN (SEQ (|ES-;unwrap| (PROGN @@ -338,7 +338,7 @@ (SPADCALL |x| (LIST |e|) (|getShellEntry| $ 79))) (DEFUN |ES-;eval;SLLS;24| (|x| |ls| |lf| $) - (PROG (#0=#:G1588 |f| #1=#:G1589) + (PROG (#0=#:G1589 |f| #1=#:G1590) (RETURN (SEQ (SPADCALL |x| |ls| (PROGN @@ -366,7 +366,7 @@ (|getShellEntry| $$ 0))) (DEFUN |ES-;eval;SLLS;25| (|x| |ls| |lf| $) - (PROG (#0=#:G1590 |f| #1=#:G1591) + (PROG (#0=#:G1591 |f| #1=#:G1592) (RETURN (SEQ (SPADCALL |x| |ls| (PROGN @@ -394,7 +394,7 @@ (|getShellEntry| $$ 0))) (DEFUN |ES-;eval;SLLS;26| (|x| |ls| |lf| $) - (PROG (#0=#:G1592 |s| #1=#:G1593) + (PROG (#0=#:G1593 |s| #1=#:G1594) (RETURN (SEQ (SPADCALL |x| (PROGN @@ -418,7 +418,7 @@ |lf| (|getShellEntry| $ 67)))))) (DEFUN |ES-;map;MKS;27| (|fn| |k| $) - (PROG (#0=#:G1594 |x| #1=#:G1595 |l|) + (PROG (#0=#:G1595 |x| #1=#:G1596 |l|) (RETURN (SEQ (COND ((SPADCALL @@ -463,7 +463,7 @@ ('T (|error| "Unknown operator")))) (DEFUN |ES-;mainKernel;SU;29| (|x| $) - (PROG (|l| |kk| #0=#:G1596 |n| |k|) + (PROG (|l| |kk| #0=#:G1597 |n| |k|) (RETURN (SEQ (COND ((NULL (LETT |l| (SPADCALL |x| (|getShellEntry| $ 39)) @@ -503,7 +503,7 @@ (EXIT (CONS 0 |k|))))))))) (DEFUN |ES-;allKernels| (|f| $) - (PROG (|l| |k| #0=#:G1597 |u| |s0| |n| |arg| |t| |s|) + (PROG (|l| |k| #0=#:G1598 |u| |s0| |n| |arg| |t| |s|) (RETURN (SEQ (LETT |s| (SPADCALL @@ -577,7 +577,7 @@ ('T (|ES-;okkernel| |op| |args| $)))) (DEFUN |ES-;okkernel| (|op| |l| $) - (PROG (#0=#:G1598 |f| #1=#:G1599) + (PROG (#0=#:G1599 |f| #1=#:G1600) (RETURN (SEQ (SPADCALL (SPADCALL |op| |l| @@ -608,7 +608,7 @@ (|getShellEntry| $ 87)))))) (DEFUN |ES-;elt;BoLS;33| (|op| |args| $) - (PROG (|u| #0=#:G1521 |v|) + (PROG (|u| #0=#:G1522 |v|) (RETURN (SEQ (EXIT (COND ((NULL (SPADCALL |op| (|getShellEntry| $ 98))) @@ -688,7 +688,7 @@ (SPADCALL (QCDR |k|) |op| (|getShellEntry| $ 51))))))))) (DEFUN |ES-;unwrap| (|l| |x| $) - (PROG (|k| #0=#:G1600) + (PROG (|k| #0=#:G1601) (RETURN (SEQ (SEQ (LETT |k| NIL |ES-;unwrap|) (LETT #0# (NREVERSE |l|) |ES-;unwrap|) G190 @@ -708,7 +708,7 @@ (EXIT |x|))))) (DEFUN |ES-;distribute;3S;39| (|x| |y| $) - (PROG (|ky| #0=#:G1601 |k| #1=#:G1602) + (PROG (|ky| #0=#:G1602 |k| #1=#:G1603) (RETURN (SEQ (LETT |ky| (SPADCALL |y| (|getShellEntry| $ 56)) |ES-;distribute;3S;39|) @@ -760,7 +760,7 @@ (|getShellEntry| $ 121))))))) (DEFUN |ES-;mkKerLists| (|leq| $) - (PROG (|eq| #0=#:G1603 |k| |lk| |lv|) + (PROG (|eq| #0=#:G1604 |k| |lk| |lv|) (RETURN (SEQ (LETT |lk| NIL |ES-;mkKerLists|) (LETT |lv| NIL |ES-;mkKerLists|) diff --git a/src/algebra/strap/ES.lsp b/src/algebra/strap/ES.lsp index 5199b94c..9c9cb4bc 100644 --- a/src/algebra/strap/ES.lsp +++ b/src/algebra/strap/ES.lsp @@ -4,11 +4,11 @@ (DEFPARAMETER |ExpressionSpace;AL| 'NIL) (DEFUN |ExpressionSpace;| () - (PROG (#0=#:G1412) + (PROG (#0=#:G1413) (RETURN (PROG1 (LETT #0# (|sublisV| - (PAIR '(#1=#:G1410 #2=#:G1411) + (PAIR '(#1=#:G1411 #2=#:G1412) (LIST '(|Kernel| $) '(|Kernel| $))) (|Join| (|OrderedSet|) (|RetractableTo| '#1#) (|InnerEvalable| '#2# '$) diff --git a/src/algebra/strap/EUCDOM-.lsp b/src/algebra/strap/EUCDOM-.lsp index 7c83b999..aada28a4 100644 --- a/src/algebra/strap/EUCDOM-.lsp +++ b/src/algebra/strap/EUCDOM-.lsp @@ -230,7 +230,7 @@ (|getShellEntry| $ 29)))))))))))))))) (DEFUN |EUCDOM-;principalIdeal;LR;9| (|l| $) - (PROG (|uca| |v| |u| #0=#:G1515 |vv| #1=#:G1516) + (PROG (|uca| |v| |u| #0=#:G1516 |vv| #1=#:G1517) (RETURN (SEQ (COND ((SPADCALL |l| NIL (|getShellEntry| $ 38)) @@ -290,7 +290,7 @@ (QVELT |u| 2)))))))))) (DEFUN |EUCDOM-;expressIdealMember;LSU;10| (|l| |z| $) - (PROG (#0=#:G1517 #1=#:G1518 |pid| |q| #2=#:G1519 |v| #3=#:G1520) + (PROG (#0=#:G1518 #1=#:G1519 |pid| |q| #2=#:G1520 |v| #3=#:G1521) (RETURN (SEQ (COND ((SPADCALL |z| (|spadConstant| $ 26) @@ -358,9 +358,9 @@ (EXIT (NREVERSE0 #2#))))))))))))))) (DEFUN |EUCDOM-;multiEuclidean;LSU;11| (|l| |z| $) - (PROG (|n| |l1| |l2| #0=#:G1397 #1=#:G1521 #2=#:G1502 #3=#:G1500 - #4=#:G1501 #5=#:G1398 #6=#:G1522 #7=#:G1505 #8=#:G1503 - #9=#:G1504 |u| |v1| |v2|) + (PROG (|n| |l1| |l2| #0=#:G1398 #1=#:G1522 #2=#:G1503 #3=#:G1501 + #4=#:G1502 #5=#:G1399 #6=#:G1523 #7=#:G1506 #8=#:G1504 + #9=#:G1505 |u| |v1| |v2|) (RETURN (SEQ (LETT |n| (LENGTH |l|) |EUCDOM-;multiEuclidean;LSU;11|) (EXIT (COND diff --git a/src/algebra/strap/EUCDOM.lsp b/src/algebra/strap/EUCDOM.lsp index 3c060c32..b4b66503 100644 --- a/src/algebra/strap/EUCDOM.lsp +++ b/src/algebra/strap/EUCDOM.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |EuclideanDomain;AL| 'NIL) (DEFUN |EuclideanDomain;| () - (PROG (#0=#:G1412) + (PROG (#0=#:G1413) (RETURN (PROG1 (LETT #0# (|Join| (|PrincipalIdealDomain|) diff --git a/src/algebra/strap/FFIELDC-.lsp b/src/algebra/strap/FFIELDC-.lsp index 8baa9d6f..9e571320 100644 --- a/src/algebra/strap/FFIELDC-.lsp +++ b/src/algebra/strap/FFIELDC-.lsp @@ -88,7 +88,7 @@ (CONS 0 (SPADCALL |x| (|getShellEntry| $ 28)))) (DEFUN |FFIELDC-;createPrimitiveElement;S;8| ($) - (PROG (|sm1| |start| |i| #0=#:G1446 |e| |found|) + (PROG (|sm1| |start| |i| |e| |found|) (RETURN (SEQ (LETT |sm1| (- (SPADCALL (|getShellEntry| $ 39)) 1) |FFIELDC-;createPrimitiveElement;S;8|) @@ -105,10 +105,12 @@ G190 (COND ((NULL (NOT |found|)) (GO G191))) (SEQ (LETT |e| (SPADCALL - (PROG1 (LETT #0# |i| - |FFIELDC-;createPrimitiveElement;S;8|) - (|check-subtype| (> #0# 0) - '(|PositiveInteger|) #0#)) + (PROG1 |i| + (|check-subtype| + (AND + (COND ((< |i| 0) 'NIL) ('T 'T)) + (< 0 |i|)) + '(|PositiveInteger|) |i|)) (|getShellEntry| $ 12)) |FFIELDC-;createPrimitiveElement;S;8|) (EXIT (LETT |found| diff --git a/src/algebra/strap/FFIELDC.lsp b/src/algebra/strap/FFIELDC.lsp index 9f7cef9b..df1d9b1c 100644 --- a/src/algebra/strap/FFIELDC.lsp +++ b/src/algebra/strap/FFIELDC.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |FiniteFieldCategory;AL| 'NIL) (DEFUN |FiniteFieldCategory;| () - (PROG (#0=#:G1405) + (PROG (#0=#:G1406) (RETURN (PROG1 (LETT #0# (|Join| (|FieldOfPrimeCharacteristic|) (|Finite|) diff --git a/src/algebra/strap/FPS-.lsp b/src/algebra/strap/FPS-.lsp index 6cbb70df..d9a74d7e 100644 --- a/src/algebra/strap/FPS-.lsp +++ b/src/algebra/strap/FPS-.lsp @@ -12,7 +12,7 @@ (|getShellEntry| $ 10))) (DEFUN |FPS-;digits;Pi;2| ($) - (PROG (#0=#:G1401) + (PROG (#0=#:G1402) (RETURN (PROG1 (LETT #0# (MAX 1 @@ -22,7 +22,9 @@ (|getShellEntry| $ 14)) 13301)) |FPS-;digits;Pi;2|) - (|check-subtype| (> #0# 0) '(|PositiveInteger|) #0#))))) + (|check-subtype| + (AND (COND ((< #0# 0) 'NIL) ('T 'T)) (< 0 #0#)) + '(|PositiveInteger|) #0#))))) (DEFUN |FloatingPointSystem&| (|#1|) (PROG (|dv$1| |dv$| $ |pv$|) diff --git a/src/algebra/strap/FPS.lsp b/src/algebra/strap/FPS.lsp index 313baa93..f6d25aef 100644 --- a/src/algebra/strap/FPS.lsp +++ b/src/algebra/strap/FPS.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |FloatingPointSystem;AL| 'NIL) (DEFUN |FloatingPointSystem;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|RealNumberSystem|) diff --git a/src/algebra/strap/GCDDOM-.lsp b/src/algebra/strap/GCDDOM-.lsp index b3a3bbc5..e128bbb7 100644 --- a/src/algebra/strap/GCDDOM-.lsp +++ b/src/algebra/strap/GCDDOM-.lsp @@ -43,7 +43,7 @@ (|getShellEntry| $ 19))) (DEFUN |GCDDOM-;gcdPolynomial;3Sup;4| (|p1| |p2| $) - (PROG (|e2| |e1| |c1| |p| |c2| #0=#:G1418) + (PROG (|e2| |e1| |c1| |p| |c2| #0=#:G1419) (RETURN (SEQ (COND ((SPADCALL |p1| (|getShellEntry| $ 24)) diff --git a/src/algebra/strap/GCDDOM.lsp b/src/algebra/strap/GCDDOM.lsp index 8f4675a6..cfddb57a 100644 --- a/src/algebra/strap/GCDDOM.lsp +++ b/src/algebra/strap/GCDDOM.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |GcdDomain;AL| 'NIL) (DEFUN |GcdDomain;| () - (PROG (#0=#:G1403) + (PROG (#0=#:G1404) (RETURN (PROG1 (LETT #0# (|Join| (|IntegralDomain|) diff --git a/src/algebra/strap/HOAGG-.lsp b/src/algebra/strap/HOAGG-.lsp index b1b57cdc..5a895dee 100644 --- a/src/algebra/strap/HOAGG-.lsp +++ b/src/algebra/strap/HOAGG-.lsp @@ -45,7 +45,7 @@ (LENGTH (SPADCALL |c| (|getShellEntry| $ 15)))) (DEFUN |HOAGG-;any?;MAB;3| (|f| |c| $) - (PROG (|x| #0=#:G1428 #1=#:G1406 #2=#:G1404 #3=#:G1405) + (PROG (|x| #0=#:G1429 #1=#:G1407 #2=#:G1405 #3=#:G1406) (RETURN (SEQ (PROGN (LETT #3# NIL |HOAGG-;any?;MAB;3|) @@ -75,7 +75,7 @@ (COND (#3# #2#) ('T 'NIL))))))) (DEFUN |HOAGG-;every?;MAB;4| (|f| |c| $) - (PROG (|x| #0=#:G1429 #1=#:G1411 #2=#:G1409 #3=#:G1410) + (PROG (|x| #0=#:G1430 #1=#:G1412 #2=#:G1410 #3=#:G1411) (RETURN (SEQ (PROGN (LETT #3# NIL |HOAGG-;every?;MAB;4|) @@ -106,7 +106,7 @@ (COND (#3# #2#) ('T 'T))))))) (DEFUN |HOAGG-;count;MANni;5| (|f| |c| $) - (PROG (|x| #0=#:G1430 #1=#:G1415 #2=#:G1413 #3=#:G1414) + (PROG (|x| #0=#:G1431 #1=#:G1416 #2=#:G1414 #3=#:G1415) (RETURN (SEQ (PROGN (LETT #3# NIL |HOAGG-;count;MANni;5|) @@ -158,8 +158,8 @@ (|getShellEntry| (|getShellEntry| $$ 0) 24))) (DEFUN |HOAGG-;=;2AB;9| (|x| |y| $) - (PROG (|b| #0=#:G1432 |a| #1=#:G1431 #2=#:G1422 #3=#:G1420 - #4=#:G1421) + (PROG (|b| #0=#:G1433 |a| #1=#:G1432 #2=#:G1423 #3=#:G1421 + #4=#:G1422) (RETURN (SEQ (COND ((SPADCALL |x| (SPADCALL |y| (|getShellEntry| $ 29)) @@ -206,7 +206,7 @@ ('T 'NIL)))))) (DEFUN |HOAGG-;coerce;AOf;10| (|x| $) - (PROG (#0=#:G1433 |a| #1=#:G1434) + (PROG (#0=#:G1434 |a| #1=#:G1435) (RETURN (SEQ (SPADCALL (SPADCALL diff --git a/src/algebra/strap/HOAGG.lsp b/src/algebra/strap/HOAGG.lsp index 7e2bb119..ca81df7e 100644 --- a/src/algebra/strap/HOAGG.lsp +++ b/src/algebra/strap/HOAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |HomogeneousAggregate;AL| 'NIL) (DEFUN |HomogeneousAggregate;| (|t#1|) - (PROG (#0=#:G1398) + (PROG (#0=#:G1399) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -100,8 +100,8 @@ (|setShellEntry| #0# 0 (LIST '|HomogeneousAggregate| (|devaluate| |t#1|))))))) -(DEFUN |HomogeneousAggregate| (#0=#:G1399) - (LET (#1=#:G1400) +(DEFUN |HomogeneousAggregate| (#0=#:G1400) + (LET (#1=#:G1401) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |HomogeneousAggregate;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/ILIST.lsp b/src/algebra/strap/ILIST.lsp index 0af4f011..ee2b5370 100644 --- a/src/algebra/strap/ILIST.lsp +++ b/src/algebra/strap/ILIST.lsp @@ -1,126 +1,124 @@ (/VERSIONCHECK 2) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) (|%IntegerSection| 0)) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) (|%IntegerSection| 0)) |ILIST;#;$Nni;1|)) (PUT '|ILIST;#;$Nni;1| '|SPADreplace| 'LENGTH) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List| |%Shell|) |%List|) |ILIST;concat;S2$;2|)) (PUT '|ILIST;concat;S2$;2| '|SPADreplace| 'CONS) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Boolean|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%List| |%Shell|) |%Boolean|) |ILIST;eq?;2$B;3|)) (PUT '|ILIST;eq?;2$B;3| '|SPADreplace| 'EQ) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%Thing|) |ILIST;first;$S;4|)) (PUT '|ILIST;first;$S;4| '|SPADreplace| '|SPADfirst|) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing| |%Shell|) |%Thing|) |ILIST;elt;$firstS;5|)) (PUT '|ILIST;elt;$firstS;5| '|SPADreplace| '(XLAM (|x| "first") (|SPADfirst| |x|))) -(DECLAIM (FTYPE (FUNCTION (|%Shell|) |%Thing|) |ILIST;empty;$;6|)) +(DECLAIM (FTYPE (FUNCTION (|%Shell|) |%List|) |ILIST;empty;$;6|)) (PUT '|ILIST;empty;$;6| '|SPADreplace| '(XLAM NIL NIL)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Boolean|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%Boolean|) |ILIST;empty?;$B;7|)) (PUT '|ILIST;empty?;$B;7| '|SPADreplace| 'NULL) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;rest;2$;8|)) (PUT '|ILIST;rest;2$;8| '|SPADreplace| 'CDR) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing| |%Shell|) |%List|) |ILIST;elt;$rest$;9|)) (PUT '|ILIST;elt;$rest$;9| '|SPADreplace| '(XLAM (|x| "rest") (CDR |x|))) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing| |%Shell|) |%Thing|) |ILIST;setfirst!;$2S;10|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing| |%Shell|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing| |%Thing| |%Shell|) |%Thing|) |ILIST;setelt;$first2S;11|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%List| |%Shell|) |%List|) |ILIST;setrest!;3$;12|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing| |%Shell|) - |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Thing| |%List| |%Shell|) |%List|) |ILIST;setelt;$rest2$;13|)) -(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;construct;L$;14|)) (PUT '|ILIST;construct;L$;14| '|SPADreplace| '(XLAM (|l|) |l|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%List|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;parts;$L;15|)) (PUT '|ILIST;parts;$L;15| '|SPADreplace| '(XLAM (|s|) |s|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;reverse!;2$;16|)) (PUT '|ILIST;reverse!;2$;16| '|SPADreplace| 'NREVERSE) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;reverse;2$;17|)) (PUT '|ILIST;reverse;2$;17| '|SPADreplace| 'REVERSE) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Integer|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%Integer|) |ILIST;minIndex;$I;18|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%IntegerSection| 0) |%Shell|) - |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| (|%IntegerSection| 0) |%Shell|) + |%List|) |ILIST;rest;$Nni$;19|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;copy;2$;20|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%Thing|) |ILIST;coerce;$Of;21|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Boolean|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%List| |%Shell|) |%Boolean|) |ILIST;=;2$B;22|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%String|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%String|) |ILIST;latex;$S;23|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Boolean|) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List| |%Shell|) |%Boolean|) |ILIST;member?;S$B;24|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%List| |%Shell|) |%List|) |ILIST;concat!;3$;25|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%List|) |ILIST;removeDuplicates!;2$;26|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List| |%Shell|) |%List|) |ILIST;sort!;M2$;27|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing| |%Shell|) - |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List| |%List| |%Shell|) |%List|) |ILIST;merge!;M3$;28|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Integer| |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Integer| |%Shell|) |%List|) |ILIST;split!;$I$;29|)) -(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Integer| |%Shell|) - |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%List| |%Integer| |%Shell|) + |%List|) |ILIST;mergeSort|)) (DEFUN |ILIST;#;$Nni;1| (|x| $) (DECLARE (IGNORE $)) (LENGTH |x|)) @@ -260,7 +258,7 @@ (|getShellEntry| $ 39))))))))))) (DEFUN |ILIST;=;2$B;22| (|x| |y| $) - (PROG (#0=#:G1469) + (PROG (#0=#:G1470) (RETURN (SEQ (EXIT (COND ((EQ |x| |y|) 'T) @@ -311,7 +309,7 @@ (EXIT (STRCONC |s| " \\right]")))))) (DEFUN |ILIST;member?;S$B;24| (|s| |x| $) - (PROG (#0=#:G1477) + (PROG (#0=#:G1478) (RETURN (SEQ (EXIT (SEQ (SEQ G190 (COND ((NULL (NOT (NULL |x|))) (GO G191))) @@ -430,7 +428,7 @@ (EXIT |r|)))))))) (DEFUN |ILIST;split!;$I$;29| (|p| |n| $) - (PROG (#0=#:G1506 |q|) + (PROG (#0=#:G1507 |q|) (RETURN (SEQ (COND ((< |n| 1) (|error| "index out of range")) @@ -439,7 +437,8 @@ (|ILIST;rest;$Nni$;19| |p| (PROG1 (LETT #0# (- |n| 1) |ILIST;split!;$I$;29|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) $) |ILIST;split!;$I$;29|) @@ -447,7 +446,7 @@ (QRPLACD |p| NIL) (EXIT |q|)))))))) (DEFUN |ILIST;mergeSort| (|f| |p| |n| $) - (PROG (#0=#:G1510 |l| |q|) + (PROG (#0=#:G1511 |l| |q|) (RETURN (SEQ (COND ((EQL |n| 2) @@ -461,7 +460,8 @@ (SEQ (LETT |l| (PROG1 (LETT #0# (QUOTIENT2 |n| 2) |ILIST;mergeSort|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) |ILIST;mergeSort|) (LETT |q| (|ILIST;split!;$I$;29| |p| |l| $) @@ -474,11 +474,11 @@ |ILIST;mergeSort|) (EXIT (|ILIST;merge!;M3$;28| |f| |p| |q| $)))))))))) -(DEFUN |IndexedList| (&REST #0=#:G1522 &AUX #1=#:G1520) +(DEFUN |IndexedList| (&REST #0=#:G1523 &AUX #1=#:G1521) (DSETQ #1# #0#) (PROG () (RETURN - (PROG (#2=#:G1521) + (PROG (#2=#:G1522) (RETURN (COND ((LETT #2# diff --git a/src/algebra/strap/INS-.lsp b/src/algebra/strap/INS-.lsp index f2f8f5a4..d7e2223b 100644 --- a/src/algebra/strap/INS-.lsp +++ b/src/algebra/strap/INS-.lsp @@ -120,7 +120,7 @@ (DEFUN |INS-;rational?;SB;8| (|x| $) (DECLARE (IGNORE $)) 'T) (DEFUN |INS-;euclideanSize;SNni;9| (|x| $) - (PROG (#0=#:G1424 #1=#:G1425) + (PROG (#0=#:G1425 #1=#:G1426) (RETURN (COND ((SPADCALL |x| (|spadConstant| $ 9) (|getShellEntry| $ 24)) @@ -128,11 +128,13 @@ ((SPADCALL |x| (|spadConstant| $ 9) (|getShellEntry| $ 14)) (PROG1 (LETT #0# (- (SPADCALL |x| (|getShellEntry| $ 26))) |INS-;euclideanSize;SNni;9|) - (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) #0#))) + (|check-subtype| (COND ((< #0# 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) #0#))) ('T (PROG1 (LETT #1# (SPADCALL |x| (|getShellEntry| $ 26)) |INS-;euclideanSize;SNni;9|) - (|check-subtype| (>= #1# 0) '(|NonNegativeInteger|) #1#))))))) + (|check-subtype| (COND ((< #1# 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) #1#))))))) (DEFUN |INS-;convert;SF;10| (|x| $) (SPADCALL (SPADCALL |x| (|getShellEntry| $ 26)) @@ -279,7 +281,7 @@ ('T (|error| "inverse does not exist")))))))) (DEFUN |INS-;powmod;4S;29| (|x| |n| |p| $) - (PROG (|y| #0=#:G1482 |z|) + (PROG (|y| #0=#:G1483 |z|) (RETURN (SEQ (EXIT (SEQ (COND ((SPADCALL |x| (|getShellEntry| $ 79)) diff --git a/src/algebra/strap/INS.lsp b/src/algebra/strap/INS.lsp index ef6261ca..eb352380 100644 --- a/src/algebra/strap/INS.lsp +++ b/src/algebra/strap/INS.lsp @@ -4,12 +4,12 @@ (DEFPARAMETER |IntegerNumberSystem;AL| 'NIL) (DEFUN |IntegerNumberSystem;| () - (PROG (#0=#:G1413) + (PROG (#0=#:G1414) (RETURN (PROG1 (LETT #0# (|sublisV| - (PAIR '(#1=#:G1407 #2=#:G1408 #3=#:G1409 - #4=#:G1410 #5=#:G1411 #6=#:G1412) + (PAIR '(#1=#:G1408 #2=#:G1409 #3=#:G1410 + #4=#:G1411 #5=#:G1412 #6=#:G1413) (LIST '(|Integer|) '(|Integer|) '(|Integer|) '(|InputForm|) '(|Pattern| (|Integer|)) diff --git a/src/algebra/strap/INT.lsp b/src/algebra/strap/INT.lsp index 6548543c..a3bfd830 100644 --- a/src/algebra/strap/INT.lsp +++ b/src/algebra/strap/INT.lsp @@ -336,7 +336,7 @@ (INTEGER-LENGTH |a|)) (DEFUN |INT;addmod;4$;20| (|a| |b| |p| $) - (PROG (|c| #0=#:G1432) + (PROG (|c| #0=#:G1433) (RETURN (SEQ (EXIT (SEQ (SEQ (LETT |c| (+ |a| |b|) |INT;addmod;4$;20|) (EXIT (COND @@ -464,7 +464,7 @@ (SPADCALL |p| (|getShellEntry| $ 98))) (DEFUN |INT;factorPolynomial| (|p| $) - (PROG (|pp| #0=#:G1503) + (PROG (|pp| #0=#:G1504) (RETURN (SEQ (LETT |pp| (SPADCALL |p| (|getShellEntry| $ 99)) |INT;factorPolynomial|) @@ -507,7 +507,7 @@ (DEFUN |Integer| () (PROG () (RETURN - (PROG (#0=#:G1528) + (PROG (#0=#:G1529) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|Integer|) |Integer|) diff --git a/src/algebra/strap/INTDOM.lsp b/src/algebra/strap/INTDOM.lsp index a452bca6..1b0a0fcd 100644 --- a/src/algebra/strap/INTDOM.lsp +++ b/src/algebra/strap/INTDOM.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |IntegralDomain;AL| 'NIL) (DEFUN |IntegralDomain;| () - (PROG (#0=#:G1403) + (PROG (#0=#:G1404) (RETURN (PROG1 (LETT #0# (|Join| (|CommutativeRing|) (|Algebra| '$) diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp index a2c66301..44bdb482 100644 --- a/src/algebra/strap/ISTRING.lsp +++ b/src/algebra/strap/ISTRING.lsp @@ -181,8 +181,8 @@ (STRCONC "\\mbox{``" (STRCONC |s| "''}"))) (DEFUN |ISTRING;replace;$Us2$;15| (|s| |sg| |t| $) - (PROG (|l| |m| |n| |h| #0=#:G1437 |r| #1=#:G1534 #2=#:G1535 |i| - #3=#:G1536 |k|) + (PROG (|l| |m| |n| |h| #0=#:G1438 |r| #1=#:G1535 #2=#:G1536 |i| + #3=#:G1537 |k|) (RETURN (SEQ (LETT |l| (- (SPADCALL |sg| (|getShellEntry| $ 39)) @@ -206,7 +206,7 @@ (MAKE-FULL-CVEC (PROG1 (LETT #0# (+ (- |m| (+ (- |h| |l|) 1)) |n|) |ISTRING;replace;$Us2$;15|) - (|check-subtype| (>= #0# 0) + (|check-subtype| (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (SPADCALL (|getShellEntry| $ 43))) |ISTRING;replace;$Us2$;15|) @@ -254,7 +254,7 @@ (EXIT |c|)))))) (DEFUN |ISTRING;substring?;2$IB;17| (|part| |whole| |startpos| $) - (PROG (|np| |nw| |iw| |ip| #0=#:G1537 #1=#:G1451 #2=#:G1447) + (PROG (|np| |nw| |iw| |ip| #0=#:G1538 #1=#:G1452 #2=#:G1448) (RETURN (SEQ (EXIT (SEQ (LETT |np| (QCSIZE |part|) |ISTRING;substring?;2$IB;17|) @@ -323,7 +323,7 @@ ('T (+ |r| (|getShellEntry| $ 6))))))))))))) (DEFUN |ISTRING;position;C$2I;19| (|c| |t| |startpos| $) - (PROG (|r| #0=#:G1538 #1=#:G1461) + (PROG (|r| #0=#:G1539 #1=#:G1462) (RETURN (SEQ (EXIT (SEQ (LETT |startpos| (- |startpos| (|getShellEntry| $ 6)) @@ -359,7 +359,7 @@ #1# (EXIT #1#))))) (DEFUN |ISTRING;position;Cc$2I;20| (|cc| |t| |startpos| $) - (PROG (|r| #0=#:G1539 #1=#:G1467) + (PROG (|r| #0=#:G1540 #1=#:G1468) (RETURN (SEQ (EXIT (SEQ (LETT |startpos| (- |startpos| (|getShellEntry| $ 6)) @@ -570,7 +570,7 @@ (SPADCALL |i| |n| (|getShellEntry| $ 20)) $)))))) (DEFUN |ISTRING;rightTrim;$C$;26| (|s| |c| $) - (PROG (|j| #0=#:G1540) + (PROG (|j| #0=#:G1541) (RETURN (SEQ (SEQ (LETT |j| (SPADCALL |s| (|getShellEntry| $ 42)) |ISTRING;rightTrim;$C$;26|) @@ -591,7 +591,7 @@ $)))))) (DEFUN |ISTRING;rightTrim;$Cc$;27| (|s| |cc| $) - (PROG (|j| #0=#:G1541) + (PROG (|j| #0=#:G1542) (RETURN (SEQ (SEQ (LETT |j| (SPADCALL |s| (|getShellEntry| $ 42)) |ISTRING;rightTrim;$Cc$;27|) @@ -612,7 +612,7 @@ $)))))) (DEFUN |ISTRING;concat;L$;28| (|l| $) - (PROG (#0=#:G1542 #1=#:G1496 #2=#:G1494 #3=#:G1495 |t| |s| #4=#:G1543 + (PROG (#0=#:G1543 #1=#:G1497 #2=#:G1495 #3=#:G1496 |t| |s| #4=#:G1544 |i|) (RETURN (SEQ (LETT |t| @@ -734,8 +734,8 @@ (|stringMatch| |pattern| |target| (CHARACTER |wildcard|))) (DEFUN |ISTRING;match?;2$CB;34| (|pattern| |target| |dontcare| $) - (PROG (|n| |m| #0=#:G1514 #1=#:G1517 |s| #2=#:G1518 #3=#:G1527 |i| - |p| #4=#:G1519 |q|) + (PROG (|n| |m| #0=#:G1515 #1=#:G1518 |s| #2=#:G1519 #3=#:G1528 |i| + |p| #4=#:G1520 |q|) (RETURN (SEQ (EXIT (SEQ (LETT |n| (SPADCALL |pattern| (|getShellEntry| $ 42)) @@ -750,7 +750,8 @@ |ISTRING;match?;2$CB;34|) $) |ISTRING;match?;2$CB;34|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) |ISTRING;match?;2$CB;34|) (EXIT (COND @@ -780,7 +781,10 @@ |dontcare| |pattern| (+ |p| 1) $) |ISTRING;match?;2$CB;34|) - (|check-subtype| (>= #1# 0) + (|check-subtype| + (COND + ((< #1# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #1#)) |ISTRING;match?;2$CB;34|) (SEQ G190 @@ -802,7 +806,10 @@ (|ISTRING;position;2$2I;18| |s| |target| |i| $) |ISTRING;match?;2$CB;34|) - (|check-subtype| (>= #2# 0) + (|check-subtype| + (COND + ((< #2# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #2#)) |ISTRING;match?;2$CB;34|) (EXIT @@ -828,7 +835,9 @@ (+ |q| 1) $) |ISTRING;match?;2$CB;34|) (|check-subtype| - (>= #4# 0) + (COND + ((< #4# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #4#)) |ISTRING;match?;2$CB;34|))))))) @@ -849,10 +858,10 @@ (EXIT 'T))))))) #3# (EXIT #3#))))) -(DEFUN |IndexedString| (#0=#:G1544) +(DEFUN |IndexedString| (#0=#:G1545) (PROG () (RETURN - (PROG (#1=#:G1545) + (PROG (#1=#:G1546) (RETURN (COND ((LETT #1# diff --git a/src/algebra/strap/LNAGG-.lsp b/src/algebra/strap/LNAGG-.lsp index 258f83de..6f6d374f 100644 --- a/src/algebra/strap/LNAGG-.lsp +++ b/src/algebra/strap/LNAGG-.lsp @@ -21,7 +21,7 @@ |LNAGG-;maxIndex;AI;6|)) (DEFUN |LNAGG-;indices;AL;1| (|a| $) - (PROG (#0=#:G1410 |i| #1=#:G1411) + (PROG (#0=#:G1411 |i| #1=#:G1412) (RETURN (SEQ (PROGN (LETT #0# NIL |LNAGG-;indices;AL;1|) diff --git a/src/algebra/strap/LNAGG.lsp b/src/algebra/strap/LNAGG.lsp index 39b44e3c..a2b7f4cc 100644 --- a/src/algebra/strap/LNAGG.lsp +++ b/src/algebra/strap/LNAGG.lsp @@ -6,13 +6,13 @@ (DEFPARAMETER |LinearAggregate;AL| 'NIL) (DEFUN |LinearAggregate;| (|t#1|) - (PROG (#0=#:G1399) + (PROG (#0=#:G1400) (RETURN (PROG1 (LETT #0# (|sublisV| (PAIR '(|t#1|) (LIST (|devaluate| |t#1|))) (|sublisV| - (PAIR '(#1=#:G1398) (LIST '(|Integer|))) + (PAIR '(#1=#:G1399) (LIST '(|Integer|))) (COND (|LinearAggregate;CAT|) ('T @@ -70,8 +70,8 @@ (|setShellEntry| #0# 0 (LIST '|LinearAggregate| (|devaluate| |t#1|))))))) -(DEFUN |LinearAggregate| (#0=#:G1400) - (LET (#1=#:G1401) +(DEFUN |LinearAggregate| (#0=#:G1401) + (LET (#1=#:G1402) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |LinearAggregate;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/LSAGG-.lsp b/src/algebra/strap/LSAGG-.lsp index c33ce4f3..380c9292 100644 --- a/src/algebra/strap/LSAGG-.lsp +++ b/src/algebra/strap/LSAGG-.lsp @@ -238,7 +238,7 @@ (EXIT |r|)))))))) (DEFUN |LSAGG-;insert!;SAIA;7| (|s| |x| |i| $) - (PROG (|m| #0=#:G1464 |y| |z|) + (PROG (|m| #0=#:G1465 |y| |z|) (RETURN (SEQ (LETT |m| (SPADCALL |x| (|getShellEntry| $ 31)) |LSAGG-;insert!;SAIA;7|) @@ -252,7 +252,8 @@ (PROG1 (LETT #0# (- (- |i| 1) |m|) |LSAGG-;insert!;SAIA;7|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 32)) |LSAGG-;insert!;SAIA;7|) @@ -265,7 +266,7 @@ (EXIT |x|))))))))) (DEFUN |LSAGG-;insert!;2AIA;8| (|w| |x| |i| $) - (PROG (|m| #0=#:G1468 |y| |z|) + (PROG (|m| #0=#:G1469 |y| |z|) (RETURN (SEQ (LETT |m| (SPADCALL |x| (|getShellEntry| $ 31)) |LSAGG-;insert!;2AIA;8|) @@ -279,7 +280,8 @@ (PROG1 (LETT #0# (- (- |i| 1) |m|) |LSAGG-;insert!;2AIA;8|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 32)) |LSAGG-;insert!;2AIA;8|) @@ -344,7 +346,7 @@ (EXIT |x|))))))))) (DEFUN |LSAGG-;delete!;AIA;10| (|x| |i| $) - (PROG (|m| #0=#:G1480 |y|) + (PROG (|m| #0=#:G1481 |y|) (RETURN (SEQ (LETT |m| (SPADCALL |x| (|getShellEntry| $ 31)) |LSAGG-;delete!;AIA;10|) @@ -358,7 +360,8 @@ (PROG1 (LETT #0# (- (- |i| 1) |m|) |LSAGG-;delete!;AIA;10|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 32)) |LSAGG-;delete!;AIA;10|) @@ -368,7 +371,7 @@ (EXIT |x|))))))))) (DEFUN |LSAGG-;delete!;AUsA;11| (|x| |i| $) - (PROG (|l| |m| |h| #0=#:G1485 #1=#:G1486 |t| #2=#:G1487) + (PROG (|l| |m| |h| #0=#:G1486 #1=#:G1487 |t| #2=#:G1488) (RETURN (SEQ (LETT |l| (SPADCALL |i| (|getShellEntry| $ 39)) |LSAGG-;delete!;AUsA;11|) @@ -391,7 +394,10 @@ (PROG1 (LETT #0# (- (+ |h| 1) |m|) |LSAGG-;delete!;AUsA;11|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND + ((< #0# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 32))) ('T @@ -400,7 +406,10 @@ (PROG1 (LETT #1# (- (- |l| 1) |m|) |LSAGG-;delete!;AUsA;11|) - (|check-subtype| (>= #1# 0) + (|check-subtype| + (COND + ((< #1# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #1#)) (|getShellEntry| $ 32)) @@ -410,7 +419,10 @@ (PROG1 (LETT #2# (+ (- |h| |l|) 2) |LSAGG-;delete!;AUsA;11|) - (|check-subtype| (>= #2# 0) + (|check-subtype| + (COND + ((< #2# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #2#)) (|getShellEntry| $ 32)) @@ -461,7 +473,7 @@ ('T |k|))))))) (DEFUN |LSAGG-;mergeSort| (|f| |p| |n| $) - (PROG (#0=#:G1507 |l| |q|) + (PROG (#0=#:G1508 |l| |q|) (RETURN (SEQ (COND ((EQL |n| 2) @@ -478,7 +490,8 @@ (SEQ (LETT |l| (PROG1 (LETT #0# (QUOTIENT2 |n| 2) |LSAGG-;mergeSort|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) |LSAGG-;mergeSort|) (LETT |q| @@ -495,7 +508,7 @@ (|getShellEntry| $ 23))))))))))) (DEFUN |LSAGG-;sorted?;MAB;15| (|f| |l| $) - (PROG (#0=#:G1516 |p|) + (PROG (#0=#:G1517 |p|) (RETURN (SEQ (EXIT (COND ((SPADCALL |l| (|getShellEntry| $ 16)) 'T) @@ -675,7 +688,7 @@ (EXIT (SPADCALL |y| (|getShellEntry| $ 47))))))) (DEFUN |LSAGG-;copyInto!;2AIA;22| (|y| |x| |s| $) - (PROG (|m| #0=#:G1545 |z|) + (PROG (|m| #0=#:G1546 |z|) (RETURN (SEQ (LETT |m| (SPADCALL |y| (|getShellEntry| $ 31)) |LSAGG-;copyInto!;2AIA;22|) @@ -687,7 +700,8 @@ (PROG1 (LETT #0# (- |s| |m|) |LSAGG-;copyInto!;2AIA;22|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 32)) |LSAGG-;copyInto!;2AIA;22|) @@ -719,7 +733,7 @@ (EXIT |y|))))))))) (DEFUN |LSAGG-;position;SA2I;23| (|w| |x| |s| $) - (PROG (|m| #0=#:G1552 |k|) + (PROG (|m| #0=#:G1553 |k|) (RETURN (SEQ (LETT |m| (SPADCALL |x| (|getShellEntry| $ 31)) |LSAGG-;position;SA2I;23|) @@ -731,7 +745,8 @@ (PROG1 (LETT #0# (- |s| |m|) |LSAGG-;position;SA2I;23|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 32)) |LSAGG-;position;SA2I;23|) @@ -795,7 +810,7 @@ (|getShellEntry| $ 61)))))) (DEFUN |LSAGG-;<;2AB;25| (|x| |y| $) - (PROG (#0=#:G1566) + (PROG (#0=#:G1567) (RETURN (SEQ (EXIT (SEQ (SEQ G190 (COND diff --git a/src/algebra/strap/LSAGG.lsp b/src/algebra/strap/LSAGG.lsp index bfe188ac..b5b6f97d 100644 --- a/src/algebra/strap/LSAGG.lsp +++ b/src/algebra/strap/LSAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |ListAggregate;AL| 'NIL) (DEFUN |ListAggregate;| (|t#1|) - (PROG (#0=#:G1430) + (PROG (#0=#:G1431) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -27,8 +27,8 @@ (|setShellEntry| #0# 0 (LIST '|ListAggregate| (|devaluate| |t#1|))))))) -(DEFUN |ListAggregate| (#0=#:G1431) - (LET (#1=#:G1432) +(DEFUN |ListAggregate| (#0=#:G1432) + (LET (#1=#:G1433) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |ListAggregate;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/MONOID.lsp b/src/algebra/strap/MONOID.lsp index 538e9b0e..049c98b2 100644 --- a/src/algebra/strap/MONOID.lsp +++ b/src/algebra/strap/MONOID.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |Monoid;AL| 'NIL) (DEFUN |Monoid;| () - (PROG (#0=#:G1398) + (PROG (#0=#:G1399) (RETURN (PROG1 (LETT #0# (|Join| (|SemiGroup|) diff --git a/src/algebra/strap/MTSCAT.lsp b/src/algebra/strap/MTSCAT.lsp index 443b2d5f..da94918a 100644 --- a/src/algebra/strap/MTSCAT.lsp +++ b/src/algebra/strap/MTSCAT.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |MultivariateTaylorSeriesCategory;AL| 'NIL) (DEFUN |MultivariateTaylorSeriesCategory;| (|t#1| |t#2|) - (PROG (#0=#:G1399) + (PROG (#0=#:G1400) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -14,7 +14,7 @@ (LIST (|devaluate| |t#1|) (|devaluate| |t#2|))) (|sublisV| - (PAIR '(#1=#:G1398) + (PAIR '(#1=#:G1399) (LIST '(|IndexedExponents| |t#2|))) (COND (|MultivariateTaylorSeriesCategory;CAT|) @@ -89,9 +89,9 @@ (|devaluate| |t#1|) (|devaluate| |t#2|))))))) (DEFUN |MultivariateTaylorSeriesCategory| - (&REST #0=#:G1402 &AUX #1=#:G1400) + (&REST #0=#:G1403 &AUX #1=#:G1401) (DSETQ #1# #0#) - (LET (#2=#:G1401) + (LET (#2=#:G1402) (COND ((SETQ #2# (|assoc| (|devaluateList| #1#) diff --git a/src/algebra/strap/NNI.lsp b/src/algebra/strap/NNI.lsp index 9d034bca..34ec379e 100644 --- a/src/algebra/strap/NNI.lsp +++ b/src/algebra/strap/NNI.lsp @@ -36,7 +36,12 @@ (SEQ (LETT |c| (- |x| |y|) |NNI;subtractIfCan;2$U;3|) (EXIT (COND ((< |c| 0) (CONS 1 "failed")) - ('T (CONS 0 |c|)))))))) + ('T + (CONS 0 + (PROG1 |c| + (|check-subtype| + (COND ((< |c| 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) |c|)))))))))) (DEFUN |NonNegativeInteger| () (PROG () diff --git a/src/algebra/strap/OINTDOM.lsp b/src/algebra/strap/OINTDOM.lsp index e03dfea0..c7f20569 100644 --- a/src/algebra/strap/OINTDOM.lsp +++ b/src/algebra/strap/OINTDOM.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |OrderedIntegralDomain;AL| 'NIL) (DEFUN |OrderedIntegralDomain;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|IntegralDomain|) (|OrderedRing|)) |OrderedIntegralDomain|) diff --git a/src/algebra/strap/ORDRING.lsp b/src/algebra/strap/ORDRING.lsp index a4ded68e..8fccdd4c 100644 --- a/src/algebra/strap/ORDRING.lsp +++ b/src/algebra/strap/ORDRING.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |OrderedRing;AL| 'NIL) (DEFUN |OrderedRing;| () - (PROG (#0=#:G1403) + (PROG (#0=#:G1404) (RETURN (PROG1 (LETT #0# (|Join| (|OrderedAbelianGroup|) (|Ring|) (|Monoid|) diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp index e7f2bc5b..964b4b9a 100644 --- a/src/algebra/strap/OUTFORM.lsp +++ b/src/algebra/strap/OUTFORM.lsp @@ -708,7 +708,7 @@ (DEFUN |OUTFORM;empty;$;73| ($) (LIST 'NOTHING)) (DEFUN |OUTFORM;infix?;$B;74| (|a| $) - (PROG (#0=#:G1496 |e|) + (PROG (#0=#:G1497 |e|) (RETURN (SEQ (EXIT (SEQ (LETT |e| (COND @@ -808,7 +808,7 @@ (DEFUN |OUTFORM;rarrow;3$;96| (|a| |b| $) (LIST 'RARROW |a| |b|)) (DEFUN |OUTFORM;differentiate;$Nni$;97| (|a| |nn| $) - (PROG (#0=#:G1526 |r| |s|) + (PROG (|r| |s|) (RETURN (SEQ (COND ((ZEROP |nn|) |a|) @@ -816,10 +816,9 @@ ('T (SEQ (LETT |r| (SPADCALL - (PROG1 (LETT #0# |nn| - |OUTFORM;differentiate;$Nni$;97|) - (|check-subtype| (> #0# 0) - '(|PositiveInteger|) #0#)) + (PROG1 |nn| + (|check-subtype| (< 0 |nn|) + '(|PositiveInteger|) |nn|)) (|getShellEntry| $ 124)) |OUTFORM;differentiate;$Nni$;97|) (LETT |s| (SPADCALL |r| (|getShellEntry| $ 125)) diff --git a/src/algebra/strap/PI.lsp b/src/algebra/strap/PI.lsp index 72a7e508..6845dd67 100644 --- a/src/algebra/strap/PI.lsp +++ b/src/algebra/strap/PI.lsp @@ -7,7 +7,7 @@ (DEFUN |PositiveInteger| () (PROG () (RETURN - (PROG (#0=#:G1401) + (PROG (#0=#:G1402) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|PositiveInteger|) diff --git a/src/algebra/strap/POLYCAT-.lsp b/src/algebra/strap/POLYCAT-.lsp index b14697e2..9f42bd88 100644 --- a/src/algebra/strap/POLYCAT-.lsp +++ b/src/algebra/strap/POLYCAT-.lsp @@ -142,8 +142,8 @@ |POLYCAT-;convert;SIf;43|)) (DEFUN |POLYCAT-;eval;SLS;1| (|p| |l| $) - (PROG (#0=#:G1688 #1=#:G1426 #2=#:G1689 #3=#:G1690 |lvar| #4=#:G1691 - |e| #5=#:G1692) + (PROG (#0=#:G1689 #1=#:G1427 #2=#:G1690 #3=#:G1691 |lvar| #4=#:G1692 + |e| #5=#:G1693) (RETURN (SEQ (COND ((NULL |l|) |p|) @@ -261,7 +261,7 @@ ('T (CONS 0 |l|)))))) (DEFUN |POLYCAT-;isTimes;SU;4| (|p| $) - (PROG (|lv| #0=#:G1693 |v| #1=#:G1694 |l| |r|) + (PROG (|lv| #0=#:G1694 |v| #1=#:G1695 |l| |r|) (RETURN (SEQ (COND ((OR (NULL (LETT |lv| @@ -362,7 +362,7 @@ (CDR |lv|) (CDR |ln|) (|getShellEntry| $ 56))))) (DEFUN |POLYCAT-;retract;SVarSet;9| (|p| $) - (PROG (#0=#:G1477 |q|) + (PROG (#0=#:G1478 |q|) (RETURN (SEQ (LETT |q| (PROG2 (LETT #0# (SPADCALL |p| (|getShellEntry| $ 43)) @@ -378,7 +378,7 @@ ('T (|error| "Polynomial is not a single variable")))))))) (DEFUN |POLYCAT-;retractIfCan;SU;10| (|p| $) - (PROG (|q| #0=#:G1485) + (PROG (|q| #0=#:G1486) (RETURN (SEQ (EXIT (SEQ (SEQ (LETT |q| (SPADCALL |p| (|getShellEntry| $ 43)) @@ -402,7 +402,7 @@ (|getShellEntry| $ 62))) (DEFUN |POLYCAT-;primitiveMonomials;SL;12| (|p| $) - (PROG (#0=#:G1695 |q| #1=#:G1696) + (PROG (#0=#:G1696 |q| #1=#:G1697) (RETURN (SEQ (PROGN (LETT #0# NIL |POLYCAT-;primitiveMonomials;SL;12|) @@ -425,7 +425,7 @@ (GO G190) G191 (EXIT (NREVERSE0 #0#)))))))) (DEFUN |POLYCAT-;totalDegree;SNni;13| (|p| $) - (PROG (#0=#:G1491 |d| |u|) + (PROG (#0=#:G1492 |d| |u|) (RETURN (SEQ (COND ((SPADCALL |p| (|getShellEntry| $ 64)) 0) @@ -465,7 +465,7 @@ (EXIT |d|)))))))) (DEFUN |POLYCAT-;totalDegree;SLNni;14| (|p| |lv| $) - (PROG (#0=#:G1499 |v| |w| |d| |u|) + (PROG (#0=#:G1500 |v| |w| |d| |u|) (RETURN (SEQ (COND ((SPADCALL |p| (|getShellEntry| $ 64)) 0) @@ -522,7 +522,7 @@ (|getShellEntry| $ 77))) (DEFUN |POLYCAT-;allMonoms| (|l| $) - (PROG (#0=#:G1697 |p| #1=#:G1698) + (PROG (#0=#:G1698 |p| #1=#:G1699) (RETURN (SEQ (SPADCALL (SPADCALL @@ -549,7 +549,7 @@ (|getShellEntry| $ 82)))))) (DEFUN |POLYCAT-;P2R| (|p| |b| |n| $) - (PROG (|w| |bj| #0=#:G1700 |i| #1=#:G1699) + (PROG (|w| |bj| #0=#:G1701 |i| #1=#:G1700) (RETURN (SEQ (LETT |w| (SPADCALL |n| (|spadConstant| $ 23) @@ -578,7 +578,7 @@ (EXIT |w|))))) (DEFUN |POLYCAT-;eq2R| (|l| |b| $) - (PROG (#0=#:G1701 |bj| #1=#:G1702 #2=#:G1703 |p| #3=#:G1704) + (PROG (#0=#:G1702 |bj| #1=#:G1703 #2=#:G1704 |p| #3=#:G1705) (RETURN (SEQ (SPADCALL (PROGN @@ -628,7 +628,7 @@ (|getShellEntry| $ 92)))))) (DEFUN |POLYCAT-;reducedSystem;MM;20| (|m| $) - (PROG (#0=#:G1705 |r| #1=#:G1706 |b| #2=#:G1707 |bj| #3=#:G1708 |d| + (PROG (#0=#:G1706 |r| #1=#:G1707 |b| #2=#:G1708 |bj| #3=#:G1709 |d| |mm| |l|) (RETURN (SEQ (LETT |l| (SPADCALL |m| (|getShellEntry| $ 95)) @@ -702,7 +702,7 @@ (EXIT |mm|))))) (DEFUN |POLYCAT-;reducedSystem;MVR;21| (|m| |v| $) - (PROG (#0=#:G1709 |s| #1=#:G1710 |b| #2=#:G1711 |bj| #3=#:G1712 |d| + (PROG (#0=#:G1710 |s| #1=#:G1711 |b| #2=#:G1712 |bj| #3=#:G1713 |d| |n| |mm| |w| |l| |r|) (RETURN (SEQ (LETT |l| (SPADCALL |m| (|getShellEntry| $ 95)) @@ -806,8 +806,8 @@ (SPADCALL |pp| (|getShellEntry| $ 120))) (DEFUN |POLYCAT-;factor;SF;26| (|p| $) - (PROG (|v| |ansR| #0=#:G1713 |w| #1=#:G1714 |up| |ansSUP| #2=#:G1715 - |ww| #3=#:G1716) + (PROG (|v| |ansR| #0=#:G1714 |w| #1=#:G1715 |up| |ansSUP| #2=#:G1716 + |ww| #3=#:G1717) (RETURN (SEQ (LETT |v| (SPADCALL |p| (|getShellEntry| $ 43)) |POLYCAT-;factor;SF;26|) @@ -906,13 +906,13 @@ (|getShellEntry| $ 133))))))))))) (DEFUN |POLYCAT-;conditionP;MU;27| (|mat| $) - (PROG (|ll| #0=#:G1717 |z| #1=#:G1718 |ch| |l| #2=#:G1719 #3=#:G1720 - #4=#:G1582 #5=#:G1580 #6=#:G1581 #7=#:G1721 |vars| |degs| - #8=#:G1722 |d| #9=#:G1723 |nd| #10=#:G1609 #11=#:G1589 - |deg1| |redmons| #12=#:G1724 |v| #13=#:G1726 |u| - #14=#:G1725 |llR| |monslist| |ans| #15=#:G1727 - #16=#:G1728 |mons| #17=#:G1729 |m| #18=#:G1730 |i| - #19=#:G1605 #20=#:G1603 #21=#:G1604) + (PROG (|ll| #0=#:G1718 |z| #1=#:G1719 |ch| |l| #2=#:G1720 #3=#:G1721 + #4=#:G1583 #5=#:G1581 #6=#:G1582 #7=#:G1722 |vars| |degs| + #8=#:G1723 |d| #9=#:G1724 |nd| #10=#:G1610 #11=#:G1590 + |deg1| |redmons| #12=#:G1725 |v| #13=#:G1727 |u| + #14=#:G1726 |llR| |monslist| |ans| #15=#:G1728 + #16=#:G1729 |mons| #17=#:G1730 |m| #18=#:G1731 |i| + #19=#:G1606 #20=#:G1604 #21=#:G1605) (RETURN (SEQ (EXIT (SEQ (LETT |ll| (SPADCALL @@ -1068,7 +1068,10 @@ (QCDR |nd|) |POLYCAT-;conditionP;MU;27|) (|check-subtype| - (>= #11# 0) + (COND + ((< #11# 0) + 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #11#)))))) #8#) @@ -1275,7 +1278,7 @@ $)))))))))) (DEFUN |POLYCAT-;charthRootlv| (|p| |vars| |ch| $) - (PROG (|v| |dd| |cp| |d| #0=#:G1630 |ans| |ansx| #1=#:G1637) + (PROG (|v| |dd| |cp| |d| #0=#:G1631 |ans| |ansx| #1=#:G1638) (RETURN (SEQ (EXIT (COND ((NULL |vars|) @@ -1353,7 +1356,9 @@ (LETT #0# (QCDR |dd|) |POLYCAT-;charthRootlv|) (|check-subtype| - (>= #0# 0) + (COND + ((< #0# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 38)) @@ -1404,7 +1409,7 @@ (SPADCALL |p| (|getShellEntry| $ 166))) (DEFUN |POLYCAT-;squareFreePart;2S;34| (|p| $) - (PROG (|s| |f| #0=#:G1731 #1=#:G1651 #2=#:G1649 #3=#:G1650) + (PROG (|s| |f| #0=#:G1732 #1=#:G1652 #2=#:G1650 #3=#:G1651) (RETURN (SEQ (SPADCALL (SPADCALL @@ -1450,7 +1455,7 @@ (|getShellEntry| $ 173))) (DEFUN |POLYCAT-;primitivePart;2S;36| (|p| $) - (PROG (#0=#:G1655) + (PROG (#0=#:G1656) (RETURN (QVELT (SPADCALL (PROG2 (LETT #0# @@ -1466,7 +1471,7 @@ 1)))) (DEFUN |POLYCAT-;primitivePart;SVarSetS;37| (|p| |v| $) - (PROG (#0=#:G1661) + (PROG (#0=#:G1662) (RETURN (QVELT (SPADCALL (PROG2 (LETT #0# diff --git a/src/algebra/strap/POLYCAT.lsp b/src/algebra/strap/POLYCAT.lsp index f2e8f11b..6e47a7ab 100644 --- a/src/algebra/strap/POLYCAT.lsp +++ b/src/algebra/strap/POLYCAT.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |PolynomialCategory;AL| 'NIL) (DEFUN |PolynomialCategory;| (|t#1| |t#2| |t#3|) - (PROG (#0=#:G1415) + (PROG (#0=#:G1416) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -223,9 +223,9 @@ (LIST '|PolynomialCategory| (|devaluate| |t#1|) (|devaluate| |t#2|) (|devaluate| |t#3|))))))) -(DEFUN |PolynomialCategory| (&REST #0=#:G1418 &AUX #1=#:G1416) +(DEFUN |PolynomialCategory| (&REST #0=#:G1419 &AUX #1=#:G1417) (DSETQ #1# #0#) - (LET (#2=#:G1417) + (LET (#2=#:G1418) (COND ((SETQ #2# (|assoc| (|devaluateList| #1#) |PolynomialCategory;AL|)) diff --git a/src/algebra/strap/PRIMARR.lsp b/src/algebra/strap/PRIMARR.lsp index c2c29828..d27b7682 100644 --- a/src/algebra/strap/PRIMARR.lsp +++ b/src/algebra/strap/PRIMARR.lsp @@ -78,7 +78,7 @@ (|setSimpleArrayEntry| |x| |i| |s|)) (DEFUN |PRIMARR;fill!;$S$;9| (|x| |s| $) - (PROG (|i| #0=#:G1415) + (PROG (|i| #0=#:G1416) (RETURN (SEQ (SEQ (LETT |i| 0 |PRIMARR;fill!;$S$;9|) (LETT #0# (|maxIndexOfSimpleArray| |x|) @@ -89,10 +89,10 @@ G191 (EXIT NIL)) (EXIT |x|))))) -(DEFUN |PrimitiveArray| (#0=#:G1416) +(DEFUN |PrimitiveArray| (#0=#:G1417) (PROG () (RETURN - (PROG (#1=#:G1417) + (PROG (#1=#:G1418) (RETURN (COND ((LETT #1# diff --git a/src/algebra/strap/PSETCAT-.lsp b/src/algebra/strap/PSETCAT-.lsp index 56d45bc4..596c5712 100644 --- a/src/algebra/strap/PSETCAT-.lsp +++ b/src/algebra/strap/PSETCAT-.lsp @@ -86,7 +86,7 @@ |PSETCAT-;elements|)))) (DEFUN |PSETCAT-;variables1| (|lp| $) - (PROG (#0=#:G1558 |p| #1=#:G1559 |lvars|) + (PROG (#0=#:G1559 |p| #1=#:G1560 |lvars|) (RETURN (SEQ (LETT |lvars| (PROGN @@ -119,7 +119,7 @@ (SPADCALL |#2| |#1| (|getShellEntry| $ 16))) (DEFUN |PSETCAT-;variables2| (|lp| $) - (PROG (#0=#:G1560 |p| #1=#:G1561 |lvars|) + (PROG (#0=#:G1561 |p| #1=#:G1562 |lvars|) (RETURN (SEQ (LETT |lvars| (PROGN @@ -284,7 +284,7 @@ (SPADCALL |ws| (|getShellEntry| $ 30)))))))) (DEFUN |PSETCAT-;=;2SB;11| (|ps1| |ps2| $) - (PROG (#0=#:G1562 #1=#:G1563 #2=#:G1564 |p| #3=#:G1565) + (PROG (#0=#:G1563 #1=#:G1564 #2=#:G1565 |p| #3=#:G1566) (RETURN (SEQ (SPADCALL (SPADCALL @@ -463,7 +463,7 @@ ('T 'NIL))) (DEFUN |PSETCAT-;exactQuo| (|r| |s| $) - (PROG (#0=#:G1507) + (PROG (#0=#:G1508) (RETURN (COND ((|HasCategory| (|getShellEntry| $ 7) '(|EuclideanDomain|)) diff --git a/src/algebra/strap/PSETCAT.lsp b/src/algebra/strap/PSETCAT.lsp index 4db40c2c..84ee249a 100644 --- a/src/algebra/strap/PSETCAT.lsp +++ b/src/algebra/strap/PSETCAT.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |PolynomialSetCategory;AL| 'NIL) (DEFUN |PolynomialSetCategory;| (|t#1| |t#2| |t#3| |t#4|) - (PROG (#0=#:G1431) + (PROG (#0=#:G1432) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -16,7 +16,7 @@ (|devaluate| |t#3|) (|devaluate| |t#4|))) (|sublisV| - (PAIR '(#1=#:G1430) (LIST '(|List| |t#4|))) + (PAIR '(#1=#:G1431) (LIST '(|List| |t#4|))) (COND (|PolynomialSetCategory;CAT|) ('T @@ -107,9 +107,9 @@ (|devaluate| |t#2|) (|devaluate| |t#3|) (|devaluate| |t#4|))))))) -(DEFUN |PolynomialSetCategory| (&REST #0=#:G1434 &AUX #1=#:G1432) +(DEFUN |PolynomialSetCategory| (&REST #0=#:G1435 &AUX #1=#:G1433) (DSETQ #1# #0#) - (LET (#2=#:G1433) + (LET (#2=#:G1434) (COND ((SETQ #2# (|assoc| (|devaluateList| #1#) |PolynomialSetCategory;AL|)) diff --git a/src/algebra/strap/QFCAT.lsp b/src/algebra/strap/QFCAT.lsp index dd721698..d694d366 100644 --- a/src/algebra/strap/QFCAT.lsp +++ b/src/algebra/strap/QFCAT.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |QuotientFieldCategory;AL| 'NIL) (DEFUN |QuotientFieldCategory;| (|t#1|) - (PROG (#0=#:G1399) + (PROG (#0=#:G1400) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -92,8 +92,8 @@ (|setShellEntry| #0# 0 (LIST '|QuotientFieldCategory| (|devaluate| |t#1|))))))) -(DEFUN |QuotientFieldCategory| (#0=#:G1400) - (LET (#1=#:G1401) +(DEFUN |QuotientFieldCategory| (#0=#:G1401) + (LET (#1=#:G1402) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |QuotientFieldCategory;AL|)) diff --git a/src/algebra/strap/RCAGG.lsp b/src/algebra/strap/RCAGG.lsp index 46649f33..88af0575 100644 --- a/src/algebra/strap/RCAGG.lsp +++ b/src/algebra/strap/RCAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |RecursiveAggregate;AL| 'NIL) (DEFUN |RecursiveAggregate;| (|t#1|) - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -63,8 +63,8 @@ (|setShellEntry| #0# 0 (LIST '|RecursiveAggregate| (|devaluate| |t#1|))))))) -(DEFUN |RecursiveAggregate| (#0=#:G1398) - (LET (#1=#:G1399) +(DEFUN |RecursiveAggregate| (#0=#:G1399) + (LET (#1=#:G1400) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |RecursiveAggregate;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/REF.lsp b/src/algebra/strap/REF.lsp index 0142338b..2cdb9536 100644 --- a/src/algebra/strap/REF.lsp +++ b/src/algebra/strap/REF.lsp @@ -47,10 +47,10 @@ (LIST (SPADCALL (QCAR |p|) (|getShellEntry| $ 18))) (|getShellEntry| $ 20))) -(DEFUN |Reference| (#0=#:G1406) +(DEFUN |Reference| (#0=#:G1407) (PROG () (RETURN - (PROG (#1=#:G1407) + (PROG (#1=#:G1408) (RETURN (COND ((LETT #1# diff --git a/src/algebra/strap/RING.lsp b/src/algebra/strap/RING.lsp index cf341577..4aec92ab 100644 --- a/src/algebra/strap/RING.lsp +++ b/src/algebra/strap/RING.lsp @@ -4,10 +4,10 @@ (DEFPARAMETER |Ring;AL| 'NIL) (DEFUN |Ring;| () - (PROG (#0=#:G1398) + (PROG (#0=#:G1399) (RETURN (PROG1 (LETT #0# - (|sublisV| (PAIR '(#1=#:G1397) (LIST '(|Integer|))) + (|sublisV| (PAIR '(#1=#:G1398) (LIST '(|Integer|))) (|Join| (|Rng|) (|Monoid|) (|LeftModule| '$) (|CoercibleFrom| '#1#) (|mkCategory| '|package| diff --git a/src/algebra/strap/RNG.lsp b/src/algebra/strap/RNG.lsp index 7e7bf619..973189e7 100644 --- a/src/algebra/strap/RNG.lsp +++ b/src/algebra/strap/RNG.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |Rng;AL| 'NIL) (DEFUN |Rng;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|AbelianGroup|) (|SemiGroup|)) |Rng|) (|setShellEntry| #0# 0 '(|Rng|)))))) diff --git a/src/algebra/strap/RNS.lsp b/src/algebra/strap/RNS.lsp index f9641660..fd65a996 100644 --- a/src/algebra/strap/RNS.lsp +++ b/src/algebra/strap/RNS.lsp @@ -4,12 +4,12 @@ (DEFPARAMETER |RealNumberSystem;AL| 'NIL) (DEFUN |RealNumberSystem;| () - (PROG (#0=#:G1406) + (PROG (#0=#:G1407) (RETURN (PROG1 (LETT #0# (|sublisV| - (PAIR '(#1=#:G1402 #2=#:G1403 #3=#:G1404 - #4=#:G1405) + (PAIR '(#1=#:G1403 #2=#:G1404 #3=#:G1405 + #4=#:G1406) (LIST '(|Integer|) '(|Fraction| (|Integer|)) '(|Pattern| (|Float|)) '(|Float|))) diff --git a/src/algebra/strap/SETAGG.lsp b/src/algebra/strap/SETAGG.lsp index d40ba5ab..96c45f22 100644 --- a/src/algebra/strap/SETAGG.lsp +++ b/src/algebra/strap/SETAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |SetAggregate;AL| 'NIL) (DEFUN |SetAggregate;| (|t#1|) - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -47,8 +47,8 @@ (|setShellEntry| #0# 0 (LIST '|SetAggregate| (|devaluate| |t#1|))))))) -(DEFUN |SetAggregate| (#0=#:G1398) - (LET (#1=#:G1399) +(DEFUN |SetAggregate| (#0=#:G1399) + (LET (#1=#:G1400) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |SetAggregate;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/SETCAT.lsp b/src/algebra/strap/SETCAT.lsp index 22ad6fd5..9b1da323 100644 --- a/src/algebra/strap/SETCAT.lsp +++ b/src/algebra/strap/SETCAT.lsp @@ -4,11 +4,11 @@ (DEFPARAMETER |SetCategory;AL| 'NIL) (DEFUN |SetCategory;| () - (PROG (#0=#:G1398) + (PROG (#0=#:G1399) (RETURN (PROG1 (LETT #0# (|sublisV| - (PAIR '(#1=#:G1397) (LIST '(|OutputForm|))) + (PAIR '(#1=#:G1398) (LIST '(|OutputForm|))) (|Join| (|BasicType|) (|CoercibleTo| '#1#) (|mkCategory| '|domain| '(((|hash| ((|SingleInteger|) $)) T) diff --git a/src/algebra/strap/SINT.lsp b/src/algebra/strap/SINT.lsp index 90441a90..f656b3f8 100644 --- a/src/algebra/strap/SINT.lsp +++ b/src/algebra/strap/SINT.lsp @@ -440,11 +440,11 @@ (+ (- |$ShortMaximum| |$ShortMinimum|) 1)) (DEFUN |SINT;index;Pi$;50| (|i| $) - (COND - ((< (|SINT;size;Nni;49| $) |i|) - (|error| (LIST "index %1b out of range" - (SPADCALL |i| (|getShellEntry| $ 78))))) - ('T (- (+ |i| |$ShortMinimum|) 1)))) + (PROG (#0=#:G1456) + (RETURN + (PROG1 (LETT #0# (- (+ |i| |$ShortMinimum|) 1) + |SINT;index;Pi$;50|) + (|check-subtype| (SMINTP #0#) '(|SingleInteger|) #0#))))) (DEFUN |SINT;lookup;$Pi;51| (|x| $) (+ (- |x| |$ShortMinimum|) 1)) @@ -465,10 +465,7 @@ ('T |r|))))))) (DEFUN |SINT;coerce;I$;54| (|x| $) - (SEQ (COND - ((NULL (< 2147483647 |x|)) - (COND ((NULL (< |x| -2147483648)) (EXIT |x|))))) - (EXIT (|error| "integer too large to represent in a machine word")))) + (PROG1 |x| (|check-subtype| (SMINTP |x|) '(|SingleInteger|) |x|))) (DEFUN |SINT;random;$;55| ($) (SEQ (|setShellEntry| $ 6 @@ -486,7 +483,7 @@ (DEFUN |SingleInteger| () (PROG () (RETURN - (PROG (#0=#:G1495) + (PROG (#0=#:G1491) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|SingleInteger|) @@ -508,7 +505,7 @@ (RETURN (PROGN (LETT |dv$| '(|SingleInteger|) . #0=(|SingleInteger|)) - (LETT $ (|newShell| 109) . #0#) + (LETT $ (|newShell| 107) . #0#) (|setShellEntry| $ 0 |dv$|) (|setShellEntry| $ 3 (LETT |pv$| (|buildPredVector| 0 0 NIL) . #0#)) @@ -554,47 +551,46 @@ |SINT;hash;2$;42| |SINT;length;2$;43| |SINT;shift;3$;44| |SINT;mulmod;4$;45| |SINT;addmod;4$;46| |SINT;submod;4$;47| |SINT;negative?;$B;48| - |SINT;size;Nni;49| (|PositiveInteger|) (58 . |coerce|) - |SINT;index;Pi$;50| |SINT;lookup;$Pi;51| (|Vector| 5) - (|Record| (|:| |mat| 25) (|:| |vec| 81)) (|Vector| $) + |SINT;size;Nni;49| (|PositiveInteger|) |SINT;index;Pi$;50| + |SINT;lookup;$Pi;51| (|Vector| 5) + (|Record| (|:| |mat| 25) (|:| |vec| 80)) (|Vector| $) |SINT;reducedSystem;MVR;52| |SINT;positiveRemainder;3$;53| - (63 . |min|) |SINT;coerce;I$;54| |SINT;random;$;55| - |SINT;random;2$;56| + |SINT;coerce;I$;54| |SINT;random;$;55| |SINT;random;2$;56| (|Record| (|:| |unit| $) (|:| |canonical| $) (|:| |associate| $)) |SINT;unitNormal;$R;57| (|Fraction| 5) - (|Union| 92 '"failed") (|Union| $ '"failed") (|Float|) + (|Union| 90 '"failed") (|Union| $ '"failed") (|Float|) (|DoubleFloat|) (|Pattern| 5) (|PatternMatchResult| 5 $) (|InputForm|) (|Union| 5 '"failed") (|List| $) - (|Record| (|:| |coef| 101) (|:| |generator| $)) - (|Union| 101 '"failed") + (|Record| (|:| |coef| 99) (|:| |generator| $)) + (|Union| 99 '"failed") (|Record| (|:| |coef1| $) (|:| |coef2| $) (|:| |generator| $)) (|Record| (|:| |coef1| $) (|:| |coef2| $)) - (|Union| 105 '"failed") (|Factored| $) + (|Union| 103 '"failed") (|Factored| $) (|SparseUnivariatePolynomial| $)) - '#(~= 67 ~ 73 |zero?| 78 |xor| 83 |unitNormal| 89 - |unitCanonical| 94 |unit?| 99 |symmetricRemainder| 104 - |subtractIfCan| 110 |submod| 116 |squareFreePart| 123 - |squareFree| 128 |sizeLess?| 133 |size| 139 |sign| 143 - |shift| 148 |sample| 154 |retractIfCan| 158 |retract| 163 - |rem| 168 |reducedSystem| 174 |recip| 185 |rationalIfCan| - 190 |rational?| 195 |rational| 200 |random| 205 |quo| 214 - |principalIdeal| 220 |prime?| 225 |powmod| 230 - |positiveRemainder| 237 |positive?| 243 |permutation| 248 - |patternMatch| 254 |one?| 261 |odd?| 266 |not| 271 - |nextItem| 276 |negative?| 281 |multiEuclidean| 286 - |mulmod| 292 |min| 299 |max| 309 |mask| 319 |lookup| 324 - |length| 329 |lcm| 334 |latex| 345 |invmod| 350 |init| 356 - |index| 360 |inc| 365 |hash| 370 |gcdPolynomial| 375 |gcd| - 381 |factorial| 392 |factor| 397 |extendedEuclidean| 402 - |exquo| 415 |expressIdealMember| 421 |even?| 427 - |euclideanSize| 432 |divide| 437 |differentiate| 443 |dec| - 454 |copy| 459 |convert| 464 |coerce| 489 |characteristic| - 509 |bit?| 513 |binomial| 519 |base| 525 |associates?| 529 - |addmod| 535 |abs| 542 |\\/| 547 |Zero| 553 |Or| 557 |One| - 563 |OMwrite| 567 |Not| 591 D 596 |And| 607 >= 613 > 619 = - 625 <= 631 < 637 |/\\| 643 - 649 + 660 ** 666 * 678) + '#(~= 58 ~ 64 |zero?| 69 |xor| 74 |unitNormal| 80 + |unitCanonical| 85 |unit?| 90 |symmetricRemainder| 95 + |subtractIfCan| 101 |submod| 107 |squareFreePart| 114 + |squareFree| 119 |sizeLess?| 124 |size| 130 |sign| 134 + |shift| 139 |sample| 145 |retractIfCan| 149 |retract| 154 + |rem| 159 |reducedSystem| 165 |recip| 176 |rationalIfCan| + 181 |rational?| 186 |rational| 191 |random| 196 |quo| 205 + |principalIdeal| 211 |prime?| 216 |powmod| 221 + |positiveRemainder| 228 |positive?| 234 |permutation| 239 + |patternMatch| 245 |one?| 252 |odd?| 257 |not| 262 + |nextItem| 267 |negative?| 272 |multiEuclidean| 277 + |mulmod| 283 |min| 290 |max| 300 |mask| 310 |lookup| 315 + |length| 320 |lcm| 325 |latex| 336 |invmod| 341 |init| 347 + |index| 351 |inc| 356 |hash| 361 |gcdPolynomial| 366 |gcd| + 372 |factorial| 383 |factor| 388 |extendedEuclidean| 393 + |exquo| 406 |expressIdealMember| 412 |even?| 418 + |euclideanSize| 423 |divide| 428 |differentiate| 434 |dec| + 445 |copy| 450 |convert| 455 |coerce| 480 |characteristic| + 500 |bit?| 504 |binomial| 510 |base| 516 |associates?| 520 + |addmod| 526 |abs| 533 |\\/| 538 |Zero| 544 |Or| 548 |One| + 554 |OMwrite| 558 |Not| 582 D 587 |And| 598 >= 604 > 610 = + 616 <= 622 < 628 |/\\| 634 - 640 + 651 ** 657 * 669) '((|noetherian| . 0) (|canonicalsClosed| . 0) (|canonical| . 0) (|canonicalUnitNormal| . 0) (|multiplicativeValuation| . 0) (|noZeroDivisors| . 0) @@ -640,56 +636,56 @@ (|OrderedSet|) (|AbelianSemiGroup|) (|SemiGroup|) (|Logic|) (|RealConstant|) (|RetractableTo| 5) (|SetCategory|) - (|OpenMath|) (|ConvertibleTo| 95) - (|ConvertibleTo| 96) + (|OpenMath|) (|ConvertibleTo| 93) + (|ConvertibleTo| 94) (|CombinatorialFunctionCategory|) - (|ConvertibleTo| 97) - (|ConvertibleTo| 99) (|ConvertibleTo| 5) + (|ConvertibleTo| 95) + (|ConvertibleTo| 97) (|ConvertibleTo| 5) (|CoercibleFrom| $$) (|CoercibleFrom| 5) (|BasicType|) (|CoercibleTo| 28)) - (|makeByteWordVec2| 108 + (|makeByteWordVec2| 106 '(1 8 7 0 9 3 8 7 0 10 10 11 2 8 7 0 5 12 1 8 7 0 13 0 14 0 15 2 8 0 10 14 16 1 8 7 0 17 1 8 7 0 18 1 8 7 0 19 1 - 5 28 0 29 1 0 0 5 32 1 77 28 0 78 0 - 21 0 86 2 0 21 0 0 1 1 0 0 0 40 1 0 - 21 0 64 2 0 0 0 0 47 1 0 90 0 91 1 0 - 0 0 1 1 0 21 0 1 2 0 0 0 0 1 2 0 94 0 - 0 1 3 0 0 0 0 0 74 1 0 0 0 1 1 0 107 - 0 1 2 0 21 0 0 1 0 0 55 76 1 0 5 0 1 - 2 0 0 0 0 71 0 0 0 1 1 0 100 0 1 1 0 - 5 0 1 2 0 0 0 0 58 1 0 25 26 27 2 0 - 82 26 83 84 1 0 94 0 1 1 0 93 0 1 1 0 - 21 0 1 1 0 92 0 1 1 0 0 0 89 0 0 0 88 - 2 0 0 0 0 57 1 0 102 101 1 1 0 21 0 1 - 3 0 0 0 0 0 1 2 0 0 0 0 85 1 0 21 0 1 - 2 0 0 0 0 1 3 0 98 0 97 98 1 1 0 21 0 - 65 1 0 21 0 63 1 0 0 0 41 1 0 94 0 1 - 1 0 21 0 75 2 0 103 101 0 1 3 0 0 0 0 - 0 72 0 0 0 38 2 0 0 0 0 67 0 0 0 37 2 - 0 0 0 0 66 1 0 0 0 1 1 0 77 0 80 1 0 - 0 0 70 1 0 0 101 1 2 0 0 0 0 1 1 0 10 - 0 1 2 0 0 0 0 1 0 0 0 1 1 0 0 77 79 1 - 0 0 0 49 1 0 68 0 69 2 0 108 108 108 - 1 1 0 0 101 1 2 0 0 0 0 61 1 0 0 0 1 - 1 0 107 0 1 2 0 104 0 0 1 3 0 106 0 0 - 0 1 2 0 94 0 0 1 2 0 103 101 0 1 1 0 - 21 0 1 1 0 55 0 1 2 0 59 0 0 60 1 0 0 - 0 1 2 0 0 0 55 1 1 0 0 0 50 1 0 0 0 1 - 1 0 95 0 1 1 0 96 0 1 1 0 97 0 1 1 0 - 99 0 1 1 0 5 0 31 1 0 0 5 87 1 0 0 0 - 1 1 0 0 5 87 1 0 28 0 30 0 0 55 1 2 0 - 21 0 0 1 2 0 0 0 0 1 0 0 0 36 2 0 21 - 0 0 1 3 0 0 0 0 0 73 1 0 0 0 62 2 0 0 - 0 0 43 0 0 0 34 2 0 0 0 0 46 0 0 0 35 - 2 0 7 8 0 23 3 0 7 8 0 21 24 2 0 10 0 - 21 22 1 0 10 0 20 1 0 0 0 44 1 0 0 0 - 1 2 0 0 0 55 1 2 0 0 0 0 45 2 0 21 0 - 0 1 2 0 21 0 0 1 2 0 21 0 0 39 2 0 21 - 0 0 1 2 0 21 0 0 48 2 0 0 0 0 42 1 0 - 0 0 51 2 0 0 0 0 53 2 0 0 0 0 52 2 0 - 0 0 55 56 2 0 0 0 77 1 2 0 0 0 0 54 2 - 0 0 5 0 33 2 0 0 55 0 1 2 0 0 77 0 1))))) + 5 28 0 29 1 0 0 5 32 2 0 21 0 0 1 1 0 + 0 0 40 1 0 21 0 64 2 0 0 0 0 47 1 0 + 88 0 89 1 0 0 0 1 1 0 21 0 1 2 0 0 0 + 0 1 2 0 92 0 0 1 3 0 0 0 0 0 74 1 0 0 + 0 1 1 0 105 0 1 2 0 21 0 0 1 0 0 55 + 76 1 0 5 0 1 2 0 0 0 0 71 0 0 0 1 1 0 + 98 0 1 1 0 5 0 1 2 0 0 0 0 58 1 0 25 + 26 27 2 0 81 26 82 83 1 0 92 0 1 1 0 + 91 0 1 1 0 21 0 1 1 0 90 0 1 1 0 0 0 + 87 0 0 0 86 2 0 0 0 0 57 1 0 100 99 1 + 1 0 21 0 1 3 0 0 0 0 0 1 2 0 0 0 0 84 + 1 0 21 0 1 2 0 0 0 0 1 3 0 96 0 95 96 + 1 1 0 21 0 65 1 0 21 0 63 1 0 0 0 41 + 1 0 92 0 1 1 0 21 0 75 2 0 101 99 0 1 + 3 0 0 0 0 0 72 0 0 0 38 2 0 0 0 0 67 + 0 0 0 37 2 0 0 0 0 66 1 0 0 0 1 1 0 + 77 0 79 1 0 0 0 70 1 0 0 99 1 2 0 0 0 + 0 1 1 0 10 0 1 2 0 0 0 0 1 0 0 0 1 1 + 0 0 77 78 1 0 0 0 49 1 0 68 0 69 2 0 + 106 106 106 1 1 0 0 99 1 2 0 0 0 0 61 + 1 0 0 0 1 1 0 105 0 1 2 0 102 0 0 1 3 + 0 104 0 0 0 1 2 0 92 0 0 1 2 0 101 99 + 0 1 1 0 21 0 1 1 0 55 0 1 2 0 59 0 0 + 60 1 0 0 0 1 2 0 0 0 55 1 1 0 0 0 50 + 1 0 0 0 1 1 0 93 0 1 1 0 94 0 1 1 0 + 95 0 1 1 0 97 0 1 1 0 5 0 31 1 0 0 5 + 85 1 0 0 0 1 1 0 0 5 85 1 0 28 0 30 0 + 0 55 1 2 0 21 0 0 1 2 0 0 0 0 1 0 0 0 + 36 2 0 21 0 0 1 3 0 0 0 0 0 73 1 0 0 + 0 62 2 0 0 0 0 43 0 0 0 34 2 0 0 0 0 + 46 0 0 0 35 2 0 7 8 0 23 3 0 7 8 0 21 + 24 2 0 10 0 21 22 1 0 10 0 20 1 0 0 0 + 44 1 0 0 0 1 2 0 0 0 55 1 2 0 0 0 0 + 45 2 0 21 0 0 1 2 0 21 0 0 1 2 0 21 0 + 0 39 2 0 21 0 0 1 2 0 21 0 0 48 2 0 0 + 0 0 42 1 0 0 0 51 2 0 0 0 0 53 2 0 0 + 0 0 52 2 0 0 0 55 56 2 0 0 0 77 1 2 0 + 0 0 0 54 2 0 0 5 0 33 2 0 0 55 0 1 2 + 0 0 77 0 1))))) '|lookupComplete|)) (MAKEPROP '|SingleInteger| 'NILADIC T) diff --git a/src/algebra/strap/STAGG-.lsp b/src/algebra/strap/STAGG-.lsp index 1c815d62..ab9ad2bc 100644 --- a/src/algebra/strap/STAGG-.lsp +++ b/src/algebra/strap/STAGG-.lsp @@ -50,7 +50,7 @@ (SPADCALL |x| (|getShellEntry| $ 9))) (DEFUN |STAGG-;first;ANniA;3| (|x| |n| $) - (PROG (#0=#:G1452 |i|) + (PROG (#0=#:G1448 |i|) (RETURN (SEQ (SPADCALL (PROGN @@ -78,27 +78,25 @@ ('T (SPADCALL |x| (|getShellEntry| $ 18))))) (DEFUN |STAGG-;elt;AIS;5| (|x| |i| $) - (PROG (#0=#:G1413) - (RETURN - (SEQ (LETT |i| (- |i| (SPADCALL |x| (|getShellEntry| $ 20))) - |STAGG-;elt;AIS;5|) - (COND - ((OR (< |i| 0) - (SPADCALL - (LETT |x| - (SPADCALL |x| - (PROG1 (LETT #0# |i| - |STAGG-;elt;AIS;5|) - (|check-subtype| (>= #0# 0) - '(|NonNegativeInteger|) #0#)) - (|getShellEntry| $ 21)) - |STAGG-;elt;AIS;5|) - (|getShellEntry| $ 17))) - (EXIT (|error| "index out of range")))) - (EXIT (SPADCALL |x| (|getShellEntry| $ 18))))))) + (SEQ (LETT |i| (- |i| (SPADCALL |x| (|getShellEntry| $ 20))) + |STAGG-;elt;AIS;5|) + (COND + ((OR (< |i| 0) + (SPADCALL + (LETT |x| + (SPADCALL |x| + (PROG1 |i| + (|check-subtype| + (COND ((< |i| 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) |i|)) + (|getShellEntry| $ 21)) + |STAGG-;elt;AIS;5|) + (|getShellEntry| $ 17))) + (EXIT (|error| "index out of range")))) + (EXIT (SPADCALL |x| (|getShellEntry| $ 18))))) (DEFUN |STAGG-;elt;AUsA;6| (|x| |i| $) - (PROG (|l| #0=#:G1417 |h| #1=#:G1419 #2=#:G1420) + (PROG (|l| |h| #0=#:G1418) (RETURN (SEQ (LETT |l| (- (SPADCALL |i| (|getShellEntry| $ 24)) @@ -109,9 +107,10 @@ ((NULL (SPADCALL |i| (|getShellEntry| $ 25))) (SPADCALL (SPADCALL |x| - (PROG1 (LETT #0# |l| |STAGG-;elt;AUsA;6|) - (|check-subtype| (>= #0# 0) - '(|NonNegativeInteger|) #0#)) + (PROG1 |l| + (|check-subtype| + (COND ((< |l| 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) |l|)) (|getShellEntry| $ 21)) (|getShellEntry| $ 26))) ('T @@ -125,17 +124,21 @@ ('T (SPADCALL (SPADCALL |x| - (PROG1 - (LETT #1# |l| - |STAGG-;elt;AUsA;6|) - (|check-subtype| (>= #1# 0) - '(|NonNegativeInteger|) #1#)) + (PROG1 |l| + (|check-subtype| + (COND + ((< |l| 0) 'NIL) + ('T 'T)) + '(|NonNegativeInteger|) |l|)) (|getShellEntry| $ 21)) (PROG1 - (LETT #2# (+ (- |h| |l|) 1) + (LETT #0# (+ (- |h| |l|) 1) |STAGG-;elt;AUsA;6|) - (|check-subtype| (>= #2# 0) - '(|NonNegativeInteger|) #2#)) + (|check-subtype| + (COND + ((< #0# 0) 'NIL) + ('T 'T)) + '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 29))))))))))))) (DEFUN |STAGG-;concat;3A;7| (|x| |y| $) @@ -184,27 +187,25 @@ (EXIT |x|))))) (DEFUN |STAGG-;setelt;AI2S;11| (|x| |i| |s| $) - (PROG (#0=#:G1436) - (RETURN - (SEQ (LETT |i| (- |i| (SPADCALL |x| (|getShellEntry| $ 20))) - |STAGG-;setelt;AI2S;11|) - (COND - ((OR (< |i| 0) - (SPADCALL - (LETT |x| - (SPADCALL |x| - (PROG1 (LETT #0# |i| - |STAGG-;setelt;AI2S;11|) - (|check-subtype| (>= #0# 0) - '(|NonNegativeInteger|) #0#)) - (|getShellEntry| $ 21)) - |STAGG-;setelt;AI2S;11|) - (|getShellEntry| $ 17))) - (EXIT (|error| "index out of range")))) - (EXIT (SPADCALL |x| |s| (|getShellEntry| $ 36))))))) + (SEQ (LETT |i| (- |i| (SPADCALL |x| (|getShellEntry| $ 20))) + |STAGG-;setelt;AI2S;11|) + (COND + ((OR (< |i| 0) + (SPADCALL + (LETT |x| + (SPADCALL |x| + (PROG1 |i| + (|check-subtype| + (COND ((< |i| 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) |i|)) + (|getShellEntry| $ 21)) + |STAGG-;setelt;AI2S;11|) + (|getShellEntry| $ 17))) + (EXIT (|error| "index out of range")))) + (EXIT (SPADCALL |x| |s| (|getShellEntry| $ 36))))) (DEFUN |STAGG-;setelt;AUs2S;12| (|x| |i| |s| $) - (PROG (|l| |h| #0=#:G1441 #1=#:G1442 |z| |y|) + (PROG (|l| |h| #0=#:G1438 |z| |y|) (RETURN (SEQ (LETT |l| (- (SPADCALL |i| (|getShellEntry| $ 24)) @@ -228,22 +229,26 @@ ('T (SEQ (LETT |y| (SPADCALL |x| - (PROG1 - (LETT #0# |l| - |STAGG-;setelt;AUs2S;12|) - (|check-subtype| (>= #0# 0) + (PROG1 |l| + (|check-subtype| + (COND + ((< |l| 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) - #0#)) + |l|)) (|getShellEntry| $ 21)) |STAGG-;setelt;AUs2S;12|) (LETT |z| (SPADCALL |y| (PROG1 - (LETT #1# (+ (- |h| |l|) 1) + (LETT #0# (+ (- |h| |l|) 1) |STAGG-;setelt;AUs2S;12|) - (|check-subtype| (>= #1# 0) + (|check-subtype| + (COND + ((< #0# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) - #1#)) + #0#)) (|getShellEntry| $ 21)) |STAGG-;setelt;AUs2S;12|) (SEQ G190 diff --git a/src/algebra/strap/STAGG.lsp b/src/algebra/strap/STAGG.lsp index 03bb692d..0feed81e 100644 --- a/src/algebra/strap/STAGG.lsp +++ b/src/algebra/strap/STAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |StreamAggregate;AL| 'NIL) (DEFUN |StreamAggregate;| (|t#1|) - (PROG (#0=#:G1404) + (PROG (#0=#:G1405) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -30,8 +30,8 @@ (|setShellEntry| #0# 0 (LIST '|StreamAggregate| (|devaluate| |t#1|))))))) -(DEFUN |StreamAggregate| (#0=#:G1405) - (LET (#1=#:G1406) +(DEFUN |StreamAggregate| (#0=#:G1406) + (LET (#1=#:G1407) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |StreamAggregate;AL|)) (CDR #1#)) diff --git a/src/algebra/strap/SYMBOL.lsp b/src/algebra/strap/SYMBOL.lsp index abcff0c2..6529e944 100644 --- a/src/algebra/strap/SYMBOL.lsp +++ b/src/algebra/strap/SYMBOL.lsp @@ -207,7 +207,7 @@ (SPADCALL |x| (|getShellEntry| $ 76))) (DEFUN |SYMBOL;syprefix| (|sc| $) - (PROG (|ns| #0=#:G1548 |n| #1=#:G1549) + (PROG (|ns| #0=#:G1549 |n| #1=#:G1550) (RETURN (SEQ (LETT |ns| (LIST (LENGTH (QVELT |sc| 3)) (LENGTH (QVELT |sc| 2)) @@ -435,7 +435,7 @@ (EXIT |s|))))) (DEFUN |SYMBOL;anyRadix| (|n| |s| $) - (PROG (|qr| |ns| #0=#:G1503) + (PROG (|qr| |ns| #0=#:G1504) (RETURN (SEQ (EXIT (SEQ (LETT |ns| "" |SYMBOL;anyRadix|) (EXIT (SEQ G190 NIL @@ -528,7 +528,7 @@ (|SYMBOL;scripts;$R;32| |x| $) $)))))) (DEFUN |SYMBOL;resetNew;V;29| ($) - (PROG (|k| #0=#:G1550) + (PROG (|k| #0=#:G1551) (RETURN (SEQ (SPADCALL (|getShellEntry| $ 9) 0 (|getShellEntry| $ 93)) (SEQ (LETT |k| NIL |SYMBOL;resetNew;V;29|) @@ -552,7 +552,7 @@ (DEFUN |SYMBOL;scripted?;$B;30| (|sy| $) (NOT (ATOM |sy|))) (DEFUN |SYMBOL;name;2$;31| (|sy| $) - (PROG (|str| |i| #0=#:G1551 #1=#:G1531 #2=#:G1529) + (PROG (|str| |i| #0=#:G1552 #1=#:G1532 #2=#:G1530) (RETURN (SEQ (EXIT (COND ((NULL (|SYMBOL;scripted?;$B;30| |sy| $)) |sy|) @@ -605,8 +605,8 @@ #1# (EXIT #1#))))) (DEFUN |SYMBOL;scripts;$R;32| (|sy| $) - (PROG (|lscripts| |str| |nstr| |j| #0=#:G1534 |nscripts| |m| |n| - #1=#:G1552 |i| #2=#:G1553 |a| #3=#:G1554 |allscripts|) + (PROG (|lscripts| |str| |nstr| |j| #0=#:G1535 |nscripts| |m| |n| + #1=#:G1553 |i| #2=#:G1554 |a| #3=#:G1555 |allscripts|) (RETURN (SEQ (COND ((NULL (|SYMBOL;scripted?;$B;30| |sy| $)) @@ -646,7 +646,8 @@ (|getShellEntry| $ 42)) (|getShellEntry| $ 43)) |SYMBOL;scripts;$R;32|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 114)))) (LETT |i| @@ -756,7 +757,7 @@ (DEFUN |Symbol| () (PROG () (RETURN - (PROG (#0=#:G1556) + (PROG (#0=#:G1557) (RETURN (COND ((LETT #0# (HGET |$ConstructorCache| '|Symbol|) |Symbol|) diff --git a/src/algebra/strap/TSETCAT-.lsp b/src/algebra/strap/TSETCAT-.lsp index fe3f5d55..847746a2 100644 --- a/src/algebra/strap/TSETCAT-.lsp +++ b/src/algebra/strap/TSETCAT-.lsp @@ -123,7 +123,7 @@ |TSETCAT-;coHeight;SNni;39|)) (DEFUN |TSETCAT-;=;2SB;1| (|ts| |us| $) - (PROG (#0=#:G1456 #1=#:G1462) + (PROG (#0=#:G1457 #1=#:G1463) (RETURN (COND ((SPADCALL |ts| (|getShellEntry| $ 12)) @@ -159,7 +159,7 @@ (|getShellEntry| $ 18))))))) (DEFUN |TSETCAT-;infRittWu?;2SB;2| (|ts| |us| $) - (PROG (|p| #0=#:G1469 |q| |v|) + (PROG (|p| #0=#:G1470 |q| |v|) (RETURN (SEQ (COND ((SPADCALL |us| (|getShellEntry| $ 12)) @@ -484,7 +484,7 @@ (EXIT |red|))))) (DEFUN |TSETCAT-;reduce;PSMMP;13| (|p| |ts| |redOp| |redOp?| $) - (PROG (|ts0| #0=#:G1544 |reductor| #1=#:G1547) + (PROG (|ts0| #0=#:G1545 |reductor| #1=#:G1548) (RETURN (SEQ (COND ((OR (SPADCALL |ts| (|getShellEntry| $ 12)) @@ -607,7 +607,7 @@ (SPADCALL |p| |ts| (ELT $ 78) (ELT $ 79) (|getShellEntry| $ 71))) (DEFUN |TSETCAT-;removeZero;PSP;18| (|p| |ts| $) - (PROG (|v| |tsv-| #0=#:G1570 #1=#:G1579 |q|) + (PROG (|v| |tsv-| #0=#:G1571 #1=#:G1580 |q|) (RETURN (SEQ (EXIT (COND ((OR (SPADCALL |p| (|getShellEntry| $ 34)) @@ -741,7 +741,7 @@ (SPADCALL |ts| (ELT $ 105) (|getShellEntry| $ 100))) (DEFUN |TSETCAT-;mvar;SV;25| (|ts| $) - (PROG (#0=#:G1598) + (PROG (#0=#:G1599) (RETURN (COND ((SPADCALL |ts| (|getShellEntry| $ 12)) @@ -801,7 +801,7 @@ (|getShellEntry| $ 36))) (DEFUN |TSETCAT-;algebraicVariables;SL;30| (|ts| $) - (PROG (#0=#:G1666 |p| #1=#:G1667) + (PROG (#0=#:G1667 |p| #1=#:G1668) (RETURN (SEQ (PROGN (LETT #0# NIL |TSETCAT-;algebraicVariables;SL;30|) @@ -964,7 +964,7 @@ (|error| "in extend : ($,P) -> $ from TSETCAT : bad ars")))))))) (DEFUN |TSETCAT-;coHeight;SNni;39| (|ts| $) - (PROG (|n| |m| #0=#:G1662) + (PROG (|n| |m| #0=#:G1663) (RETURN (SEQ (LETT |n| (SPADCALL (|getShellEntry| $ 127)) |TSETCAT-;coHeight;SNni;39|) diff --git a/src/algebra/strap/TSETCAT.lsp b/src/algebra/strap/TSETCAT.lsp index acfb9eb0..0c008984 100644 --- a/src/algebra/strap/TSETCAT.lsp +++ b/src/algebra/strap/TSETCAT.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |TriangularSetCategory;AL| 'NIL) (DEFUN |TriangularSetCategory;| (|t#1| |t#2| |t#3| |t#4|) - (PROG (#0=#:G1448) + (PROG (#0=#:G1449) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -184,9 +184,9 @@ (|devaluate| |t#2|) (|devaluate| |t#3|) (|devaluate| |t#4|))))))) -(DEFUN |TriangularSetCategory| (&REST #0=#:G1451 &AUX #1=#:G1449) +(DEFUN |TriangularSetCategory| (&REST #0=#:G1452 &AUX #1=#:G1450) (DSETQ #1# #0#) - (LET (#2=#:G1450) + (LET (#2=#:G1451) (COND ((SETQ #2# (|assoc| (|devaluateList| #1#) |TriangularSetCategory;AL|)) diff --git a/src/algebra/strap/UFD-.lsp b/src/algebra/strap/UFD-.lsp index 9b2273b3..dee1d804 100644 --- a/src/algebra/strap/UFD-.lsp +++ b/src/algebra/strap/UFD-.lsp @@ -8,7 +8,7 @@ |UFD-;prime?;SB;2|)) (DEFUN |UFD-;squareFreePart;2S;1| (|x| $) - (PROG (|s| |f| #0=#:G1419 #1=#:G1406 #2=#:G1404 #3=#:G1405) + (PROG (|s| |f| #0=#:G1420 #1=#:G1407 #2=#:G1405 #3=#:G1406) (RETURN (SEQ (SPADCALL (SPADCALL diff --git a/src/algebra/strap/UFD.lsp b/src/algebra/strap/UFD.lsp index 1379c56d..0065ba95 100644 --- a/src/algebra/strap/UFD.lsp +++ b/src/algebra/strap/UFD.lsp @@ -4,7 +4,7 @@ (DEFPARAMETER |UniqueFactorizationDomain;AL| 'NIL) (DEFUN |UniqueFactorizationDomain;| () - (PROG (#0=#:G1397) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (|Join| (|GcdDomain|) diff --git a/src/algebra/strap/ULSCAT.lsp b/src/algebra/strap/ULSCAT.lsp index c3b72800..d82c1a35 100644 --- a/src/algebra/strap/ULSCAT.lsp +++ b/src/algebra/strap/ULSCAT.lsp @@ -6,13 +6,13 @@ (DEFPARAMETER |UnivariateLaurentSeriesCategory;AL| 'NIL) (DEFUN |UnivariateLaurentSeriesCategory;| (|t#1|) - (PROG (#0=#:G1399) + (PROG (#0=#:G1400) (RETURN (PROG1 (LETT #0# (|sublisV| (PAIR '(|t#1|) (LIST (|devaluate| |t#1|))) (|sublisV| - (PAIR '(#1=#:G1398) (LIST '(|Integer|))) + (PAIR '(#1=#:G1399) (LIST '(|Integer|))) (COND (|UnivariateLaurentSeriesCategory;CAT|) ('T @@ -97,8 +97,8 @@ (LIST '|UnivariateLaurentSeriesCategory| (|devaluate| |t#1|))))))) -(DEFUN |UnivariateLaurentSeriesCategory| (#0=#:G1400) - (LET (#1=#:G1401) +(DEFUN |UnivariateLaurentSeriesCategory| (#0=#:G1401) + (LET (#1=#:G1402) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) diff --git a/src/algebra/strap/UPOLYC-.lsp b/src/algebra/strap/UPOLYC-.lsp index ef47a068..87756379 100644 --- a/src/algebra/strap/UPOLYC-.lsp +++ b/src/algebra/strap/UPOLYC-.lsp @@ -308,7 +308,7 @@ (SPADCALL |pp| (|getShellEntry| $ 87))) (DEFUN |UPOLYC-;factor;SF;23| (|p| $) - (PROG (|ansR| #0=#:G1732 |w| #1=#:G1733) + (PROG (|ansR| #0=#:G1691 |w| #1=#:G1692) (RETURN (SEQ (COND ((ZEROP (SPADCALL |p| (|getShellEntry| $ 11))) @@ -360,7 +360,7 @@ (|getShellEntry| $ 106)))))))) (DEFUN |UPOLYC-;vectorise;SNniV;24| (|p| |n| $) - (PROG (|v| |m| |i| #0=#:G1734 #1=#:G1521) + (PROG (|v| |m| |i| #0=#:G1693 #1=#:G1522) (RETURN (SEQ (LETT |m| (SPADCALL @@ -379,7 +379,10 @@ (PROG1 (LETT #1# (- |i| |m|) |UPOLYC-;vectorise;SNniV;24|) - (|check-subtype| (>= #1# 0) + (|check-subtype| + (COND + ((< #1# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #1#)) (|getShellEntry| $ 112)) @@ -407,7 +410,7 @@ (SPADCALL (|spadConstant| $ 118) (|getShellEntry| $ 30))) (DEFUN |UPOLYC-;nextItemInner| (|n| $) - (PROG (|nn| |n1| |n2| #0=#:G1545 |n3|) + (PROG (|nn| |n1| |n2| #0=#:G1546 |n3|) (RETURN (SEQ (COND ((SPADCALL |n| (|getShellEntry| $ 9)) @@ -495,7 +498,7 @@ (|getShellEntry| $ 50))))))))))))))))) (DEFUN |UPOLYC-;nextItem;SU;29| (|n| $) - (PROG (|n1| #0=#:G1558) + (PROG (|n1| #0=#:G1559) (RETURN (SEQ (LETT |n1| (|UPOLYC-;nextItemInner| |n| $) |UPOLYC-;nextItem;SU;29|) @@ -520,7 +523,7 @@ (|getShellEntry| $ 30))) (DEFUN |UPOLYC-;primeFactor| (|p| |q| $) - (PROG (#0=#:G1564 |p1|) + (PROG (#0=#:G1565 |p1|) (RETURN (SEQ (LETT |p1| (PROG2 (LETT #0# @@ -538,7 +541,7 @@ ('T (|UPOLYC-;primeFactor| |p1| |q| $)))))))) (DEFUN |UPOLYC-;separate;2SR;32| (|p| |q| $) - (PROG (|a| #0=#:G1570) + (PROG (|a| #0=#:G1571) (RETURN (SEQ (LETT |a| (|UPOLYC-;primeFactor| |p| |q| $) |UPOLYC-;separate;2SR;32|) @@ -552,7 +555,7 @@ (|getShellEntry| $ 6) #0#)))))))) (DEFUN |UPOLYC-;differentiate;SM2S;33| (|x| |deriv| |x'| $) - (PROG (|dg| |lc| #0=#:G1575 |d|) + (PROG (|dg| |lc| #0=#:G1576 |d|) (RETURN (SEQ (LETT |d| (|spadConstant| $ 61) |UPOLYC-;differentiate;SM2S;33|) @@ -575,7 +578,10 @@ (PROG1 (LETT #0# (- |dg| 1) |UPOLYC-;differentiate;SM2S;33|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND + ((< #0# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 50)) (|getShellEntry| $ 72)) @@ -597,13 +603,14 @@ (|getShellEntry| $ 66))))))) (DEFUN |UPOLYC-;ncdiff| (|n| |x'| $) - (PROG (#0=#:G1593 |n1|) + (PROG (#0=#:G1594 |n1|) (RETURN (COND ((ZEROP |n|) (|spadConstant| $ 61)) ((ZEROP (LETT |n1| (PROG1 (LETT #0# (- |n| 1) |UPOLYC-;ncdiff|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) |UPOLYC-;ncdiff|)) |x'|) @@ -660,7 +667,7 @@ (SPADCALL |x| |deriv| (|spadConstant| $ 48) (|getShellEntry| $ 136))) (DEFUN |UPOLYC-;differentiate;2S;37| (|x| $) - (PROG (|dg| #0=#:G1602 |d|) + (PROG (|dg| #0=#:G1603 |d|) (RETURN (SEQ (LETT |d| (|spadConstant| $ 61) |UPOLYC-;differentiate;2S;37|) @@ -681,7 +688,8 @@ (PROG1 (LETT #0# (- |dg| 1) |UPOLYC-;differentiate;2S;37|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 50)) (|getShellEntry| $ 66)) @@ -704,7 +712,7 @@ (|getShellEntry| $ 146))) (DEFUN |UPOLYC-;pseudoQuotient;3S;40| (|p| |q| $) - (PROG (|n| #0=#:G1648 #1=#:G1650) + (PROG (|n| #0=#:G1611) (RETURN (SEQ (LETT |n| (+ (- (SPADCALL |p| (|getShellEntry| $ 11)) @@ -714,18 +722,19 @@ (EXIT (COND ((< |n| 1) (|spadConstant| $ 61)) ('T - (PROG2 (LETT #1# + (PROG2 (LETT #0# (SPADCALL (SPADCALL (SPADCALL (SPADCALL (SPADCALL |q| (|getShellEntry| $ 54)) - (PROG1 - (LETT #0# |n| - |UPOLYC-;pseudoQuotient;3S;40|) - (|check-subtype| (>= #0# 0) - '(|NonNegativeInteger|) #0#)) + (PROG1 |n| + (|check-subtype| + (COND + ((< |n| 0) 'NIL) + ('T 'T)) + '(|NonNegativeInteger|) |n|)) (|getShellEntry| $ 148)) |p| (|getShellEntry| $ 135)) (SPADCALL |p| |q| @@ -733,12 +742,12 @@ (|getShellEntry| $ 150)) |q| (|getShellEntry| $ 127)) |UPOLYC-;pseudoQuotient;3S;40|) - (QCDR #1#) - (|check-union| (QEQCAR #1# 0) - (|getShellEntry| $ 6) #1#))))))))) + (QCDR #0#) + (|check-union| (QEQCAR #0# 0) + (|getShellEntry| $ 6) #0#))))))))) (DEFUN |UPOLYC-;pseudoDivide;2SR;41| (|p| |q| $) - (PROG (|n| |prem| #0=#:G1656 |lc| #1=#:G1658) + (PROG (|n| |prem| |lc| #0=#:G1617) (RETURN (SEQ (LETT |n| (+ (- (SPADCALL |p| (|getShellEntry| $ 11)) @@ -758,16 +767,15 @@ (SPADCALL (SPADCALL |q| (|getShellEntry| $ 54)) - (PROG1 - (LETT #0# |n| - |UPOLYC-;pseudoDivide;2SR;41|) - (|check-subtype| (>= #0# 0) - '(|NonNegativeInteger|) #0#)) + (PROG1 |n| + (|check-subtype| + (COND ((< |n| 0) 'NIL) ('T 'T)) + '(|NonNegativeInteger|) |n|)) (|getShellEntry| $ 148)) |UPOLYC-;pseudoDivide;2SR;41|) (EXIT (VECTOR |lc| (PROG2 - (LETT #1# + (LETT #0# (SPADCALL (SPADCALL (SPADCALL |lc| |p| @@ -776,9 +784,9 @@ (|getShellEntry| $ 150)) |q| (|getShellEntry| $ 127)) |UPOLYC-;pseudoDivide;2SR;41|) - (QCDR #1#) - (|check-union| (QEQCAR #1# 0) - (|getShellEntry| $ 6) #1#)) + (QCDR #0#) + (|check-union| (QEQCAR #0# 0) + (|getShellEntry| $ 6) #0#)) |prem|)))))))))) (DEFUN |UPOLYC-;composite;FSU;42| (|f| |q| $) @@ -805,7 +813,7 @@ (|getShellEntry| $ 155)))))))))))))) (DEFUN |UPOLYC-;composite;2SU;43| (|p| |q| $) - (PROG (|cqr| |v| |u| |w| #0=#:G1684) + (PROG (|cqr| |v| |u| |w| #0=#:G1643) (RETURN (SEQ (COND ((SPADCALL |p| (|getShellEntry| $ 158)) (CONS 0 |p|)) @@ -867,7 +875,7 @@ #0# (EXIT #0#)))))))) (DEFUN |UPOLYC-;elt;S2F;44| (|p| |f| $) - (PROG (|n| #0=#:G1690 |ans|) + (PROG (|n| #0=#:G1649 |ans|) (RETURN (SEQ (COND ((SPADCALL |p| (|getShellEntry| $ 9)) @@ -903,7 +911,10 @@ (|getShellEntry| $ 11)) |UPOLYC-;elt;S2F;44|)) |UPOLYC-;elt;S2F;44|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND + ((< #0# 0) 'NIL) + ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 164)) (|getShellEntry| $ 165)) @@ -925,7 +936,7 @@ (|getShellEntry| $ 165)))))))))))) (DEFUN |UPOLYC-;order;2SNni;45| (|p| |q| $) - (PROG (|u| #0=#:G1704 |ans|) + (PROG (|u| #0=#:G1663 |ans|) (RETURN (SEQ (EXIT (COND ((SPADCALL |p| (|getShellEntry| $ 9)) @@ -1001,7 +1012,7 @@ ('T (SPADCALL |x| (|getShellEntry| $ 11))))) (DEFUN |UPOLYC-;divide;2SR;52| (|x| |y| $) - (PROG (|lc| |f| #0=#:G1716 |n| |quot|) + (PROG (|lc| |f| #0=#:G1675 |n| |quot|) (RETURN (SEQ (COND ((SPADCALL |y| (|getShellEntry| $ 9)) @@ -1043,7 +1054,8 @@ (SPADCALL |y| (|getShellEntry| $ 11))) |UPOLYC-;divide;2SR;52|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) |UPOLYC-;divide;2SR;52|) (LETT |quot| diff --git a/src/algebra/strap/UPOLYC.lsp b/src/algebra/strap/UPOLYC.lsp index 1a1726c7..1017ee1c 100644 --- a/src/algebra/strap/UPOLYC.lsp +++ b/src/algebra/strap/UPOLYC.lsp @@ -6,13 +6,13 @@ (DEFPARAMETER |UnivariatePolynomialCategory;AL| 'NIL) (DEFUN |UnivariatePolynomialCategory;| (|t#1|) - (PROG (#0=#:G1435) + (PROG (#0=#:G1436) (RETURN (PROG1 (LETT #0# (|sublisV| (PAIR '(|t#1|) (LIST (|devaluate| |t#1|))) (|sublisV| - (PAIR '(#1=#:G1433 #2=#:G1434) + (PAIR '(#1=#:G1434 #2=#:G1435) (LIST '(|NonNegativeInteger|) '(|SingletonAsOrderedSet|))) (COND @@ -141,8 +141,8 @@ (|setShellEntry| #0# 0 (LIST '|UnivariatePolynomialCategory| (|devaluate| |t#1|))))))) -(DEFUN |UnivariatePolynomialCategory| (#0=#:G1436) - (LET (#1=#:G1437) +(DEFUN |UnivariatePolynomialCategory| (#0=#:G1437) + (LET (#1=#:G1438) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) diff --git a/src/algebra/strap/URAGG-.lsp b/src/algebra/strap/URAGG-.lsp index 9db94f98..023dd8a0 100644 --- a/src/algebra/strap/URAGG-.lsp +++ b/src/algebra/strap/URAGG-.lsp @@ -274,7 +274,7 @@ (EXIT |x|)))))))) (DEFUN |URAGG-;findCycle| (|x| $) - (PROG (#0=#:G1475 |y|) + (PROG (#0=#:G1476 |y|) (RETURN (SEQ (EXIT (SEQ (LETT |y| (SPADCALL |x| (|getShellEntry| $ 14)) |URAGG-;findCycle|) @@ -441,7 +441,7 @@ (EXIT |x|))))) (DEFUN |URAGG-;last;ANniA;22| (|x| |n| $) - (PROG (|m| #0=#:G1498) + (PROG (|m| #0=#:G1499) (RETURN (SEQ (LETT |m| (SPADCALL |x| (|getShellEntry| $ 42)) |URAGG-;last;ANniA;22|) @@ -452,13 +452,14 @@ (SPADCALL |x| (PROG1 (LETT #0# (- |m| |n|) |URAGG-;last;ANniA;22|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 43)) (|getShellEntry| $ 44))))))))) (DEFUN |URAGG-;=;2AB;23| (|x| |y| $) - (PROG (|k| #0=#:G1508) + (PROG (|k| #0=#:G1509) (RETURN (SEQ (EXIT (COND ((SPADCALL |x| |y| (|getShellEntry| $ 36)) 'T) @@ -512,7 +513,7 @@ #0# (EXIT #0#))))) (DEFUN |URAGG-;node?;2AB;24| (|u| |v| $) - (PROG (|k| #0=#:G1513) + (PROG (|k| #0=#:G1514) (RETURN (SEQ (EXIT (SEQ (SEQ (LETT |k| 0 |URAGG-;node?;2AB;24|) G190 (COND @@ -580,7 +581,7 @@ (SPADCALL |u| |s| (|getShellEntry| $ 50))) (DEFUN |URAGG-;split!;AIA;32| (|p| |n| $) - (PROG (#0=#:G1524 |q|) + (PROG (#0=#:G1525 |q|) (RETURN (SEQ (COND ((< |n| 1) (|error| "index out of range")) @@ -589,7 +590,8 @@ (SPADCALL |p| (PROG1 (LETT #0# (- |n| 1) |URAGG-;split!;AIA;32|) - (|check-subtype| (>= #0# 0) + (|check-subtype| + (COND ((< #0# 0) 'NIL) ('T 'T)) '(|NonNegativeInteger|) #0#)) (|getShellEntry| $ 43)) |URAGG-;split!;AIA;32|) diff --git a/src/algebra/strap/URAGG.lsp b/src/algebra/strap/URAGG.lsp index acc123db..bd58193e 100644 --- a/src/algebra/strap/URAGG.lsp +++ b/src/algebra/strap/URAGG.lsp @@ -6,7 +6,7 @@ (DEFPARAMETER |UnaryRecursiveAggregate;AL| 'NIL) (DEFUN |UnaryRecursiveAggregate;| (|t#1|) - (PROG (#0=#:G1425) + (PROG (#0=#:G1426) (RETURN (PROG1 (LETT #0# (|sublisV| @@ -99,8 +99,8 @@ (|setShellEntry| #0# 0 (LIST '|UnaryRecursiveAggregate| (|devaluate| |t#1|))))))) -(DEFUN |UnaryRecursiveAggregate| (#0=#:G1426) - (LET (#1=#:G1427) +(DEFUN |UnaryRecursiveAggregate| (#0=#:G1427) + (LET (#1=#:G1428) (COND ((SETQ #1# (|assoc| (|devaluate| #0#) |UnaryRecursiveAggregate;AL|)) diff --git a/src/algebra/strap/VECTOR.lsp b/src/algebra/strap/VECTOR.lsp index 42b720c7..e7fae836 100644 --- a/src/algebra/strap/VECTOR.lsp +++ b/src/algebra/strap/VECTOR.lsp @@ -1,10 +1,10 @@ (/VERSIONCHECK 2) -(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) (|%Vector| *)) +(DECLAIM (FTYPE (FUNCTION (|%List| |%Shell|) |%Thing|) |VECTOR;vector;L$;1|)) -(DECLAIM (FTYPE (FUNCTION ((|%Vector| *) |%Shell|) |%Thing|) +(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Shell|) |%Thing|) |VECTOR;convert;$If;2|)) (DEFUN |VECTOR;vector;L$;1| (|l| $) diff --git a/src/algebra/stream.spad.pamphlet b/src/algebra/stream.spad.pamphlet index a691aab2..aa23b60c 100644 --- a/src/algebra/stream.spad.pamphlet +++ b/src/algebra/stream.spad.pamphlet @@ -553,7 +553,6 @@ CyclicStreamTools(S,ST): Exports == Implementation where -- As explained below, in the capsule, the Rep for STREAM is actually -- a half lie. So, the system should not be allowed to trust it. )boot $optProclaim := false -import Type import Void import Boolean import Integer @@ -1062,12 +1061,12 @@ Stream(S): Exports == Implementation where i := 0; while not eq?(x,tl) repeat (x := rst x; i := i + 1) i = n => [false, 0, 0] -- Find period. Now x=tl, so step over and find it again. - x := rst x; per := 1 - while not eq?(x,tl) repeat (x := rst x; per := per + 1) + x := rst x; periode := 1 + while not eq?(x,tl) repeat (x := rst x; periode := periode + 1) -- Find non-periodic part. - x := hd; xp := rest(hd, per); npp := 0 + x := hd; xp := rest(hd, periode); npp := 0 while not eq?(x,xp) repeat (x := rst x; xp := rst xp; npp := npp+1) - [true, npp, per] + [true, npp, periode] delay(fs:()->%) == [NonNullStream, fs pretend %] diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 7aba9153..5ccaaa26 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -87,6 +87,12 @@ substituteDollarIfRepHack m == $useRepresentationHack => substitute("$","Rep",m) m +++ Return the triple for the representation domain for the +++ current functor, if any. +getRepresentation: %Env -> %Maybe %Mode +getRepresentation e == + (get("Rep","value",e) or return nil).expr + ++ Returns true if the form `t' is an instance of the Tuple constructor. isTupleInstance: %Form -> %Boolean @@ -1103,13 +1109,19 @@ proclaimCapsuleFunction(op,sig) == ["FUNCTION",[:[vmType first d for d in tails rest sig],"%Shell"], vmType first sig],op]] where vmType d == - getVMType normalize(d,true) - normalize(d,top?) == + $subdomain and d = "$" => + -- We want accurate approximation for subdomains/superdomains + -- that are specialized and known to the VM. + (m := getVMType normalize $functorForm) = "%Thing" => + getVMType normalize $ + m + getVMType normalize d + normalize(d,top? == true) == d = "$" => not top? => "*" -- If the representation is explicitly stated, use it. That way -- we optimize abstractions just as well as builtins. - r := get("Rep","value",$e) => normalize(r.expr,top?) + r := getRepresentation $e => normalize(r,top?) -- Cope with old-style constructor definition atom $functorForm => [$functorForm] normalize($functorForm,top?) diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index b49a420c..ad1392fe 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -803,6 +803,7 @@ setqSetelt([v,:s],val,m,E) == comp(["setelt",v,:s,val],m,E) setqSingle(id,val,m,E) == + checkVariableName id $insideSetqSingleIfTrue: local:= true --used for comping domain forms within functions currentProplist:= getProplist(id,E) @@ -1451,17 +1452,39 @@ coerceEasy(T,m) == T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => [T.expr,m,T.env] +++ Return true if the VM constant form `val' is known to satisfy +++ the predicate `pred'. Note that this is a fairly conservatism +++ approximation in the sense that the retunred value maye be false +++ for some other reasons, such as the predicate not being closed +++ with respect to the parameter `#1'. satisfies(val,pred) == pred=false or pred=true => pred + vars := findVMFreeVars pred + vars ^= nil and vars isnt ["#1"] => false eval ["LET",[["#1",val]],pred] + +++ If the domain designated by the domain forms `m' and `m'' have +++ a common super domain, return least such super domaon (ordered +++ in terms of sub-domain relationship). Otherwise, return nil. +commonSuperType(m,m') == + lineage := [m'] + while (t := superType m') ^= nil repeat + lineage := [t,:lineage] + m' := t + while m ^= nil repeat + member(m,lineage) => return m + m := superType m + +++ Coerce value `x' of mode `m' to mode `m'', if m is a subset of +++ of m'. A special case is made for cross-subdomain conversion +++ for integral literals. coerceSubset: (%Triple,%Mode) -> %Maybe %Triple coerceSubset([x,m,e],m') == isSubset(m,m',e) => [x,m',e] - isDomainForm(m,e) and isSubDomain(m,m') => [x,m',e] - INTEGERP x => + INTEGERP x and (m'' := commonSuperType(m,m')) => -- obviously this is temporary - satisfies(x,isSubDomain(m',maximalSuperType m)) => [x,m',e] + satisfies(x,isSubDomain(m',m'')) => [x,m',e] nil nil @@ -1539,6 +1562,30 @@ compCoerce(["::",x,m'],m,e) == T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil coerce([T.expr,m',T.env],m) +++ Subroutine of compCoerce1. If `T' is a triple whose mode is +++ a super-domain of `sub', then return code that performs the +++ checked courtesy coercion to `sub'. +coerceSuperset: (%Triple, %Mode) -> %Maybe %Triple +coerceSuperset(T,sub) == + sub = "$" => + T' := coerceSuperset(T,$functorForm) or return nil + rplac(second T',"$") + T' + pred := isSubset(sub,T.mode,T.env) => + -- Don't bother introducing a temporary if we have an + -- atomic expression. + simple? := atom T.expr and not MEMQ(T.expr,$functorLocalParameters) + g := + simple? => T.expr + GENSYM() + result := + simple? => g + ["%LET",g,T.expr] + pred := substitute(g,"#1",pred) + code := ["PROG1",result, ["check-subtype",pred,MKQ sub,g]] + [code,sub,T.env] + nil + compCoerce1(x,m',e) == T:= comp(x,m',e) or comp(x,$EmptyMode,e) or return nil m1:= @@ -1548,11 +1595,8 @@ compCoerce1(x,m',e) == T:=[T.expr,m1,T.env] T':= coerce(T,m') => T' T':= coerceByModemap(T,m') => T' - pred := isSubset(m',T.mode,e) => - gg := GENSYM() - pred := substitute(gg,"#1",pred) - code := ['PROG1,["%LET",gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] - [code,m',T.env] + T' := coerceSuperset(T,m') => T' + nil coerceByModemap([x,m,e],m') == --+ modified 6/27 for new runtime system @@ -1994,7 +2038,9 @@ listOrVectorElementMode x == x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b compIterator(it,e) == + -- ??? Allow for declared iterator variable. it is ["IN",x,y] => + checkVariableName x --these two lines must be in this order, to get "for f in list f" --to give an error message if f is undefined [y',m,e]:= comp(y,$EmptyMode,e) or return nil @@ -2008,6 +2054,7 @@ compIterator(it,e) == [y'',m'',e] := coerce([y',m,e], mOver) or return nil [["IN",x,y''],e] it is ["ON",x,y] => + checkVariableName x $formalArgList:= [x,:$formalArgList] [y',m,e]:= comp(y,$EmptyMode,e) or return nil [mOver,mUnder]:= @@ -2019,6 +2066,7 @@ compIterator(it,e) == [y'',m'',e] := coerce([y',m,e], mOver) or return nil [["ON",x,y''],e] it is ["STEP",index,start,inc,:optFinal] => + checkVariableName index $formalArgList:= [index,:$formalArgList] --if all start/inc/end compile as small integers, then loop --is compiled as a small integer loop @@ -2148,7 +2196,34 @@ exprDifference(x,y) == y=0 => x FIXP x and FIXP y => DIFFERENCE(x,y) ["DIFFERENCE",x,y] - + + +--% rep/per morphisms + +++ Compile the form `per x' under the mode `m'. +++ The `per' operator is active only for new-style definition for +++ representation domain. +compPer(["per",x],m,e) == + $useRepresentationHack => nil + inType := getRepresentation e or return nil + T := comp(x,inType,e) or return nil + if $subdomain then + T := + INTEGERP T.expr and satisfies(T.expr,domainVMPredicate "$") => + [T.expr,"$",e] + coerceSuperset(T,"$") or return nil + else + rplac(second T,"$") + coerce(T,m) + +++ Compile the form `rep x' under the mode `m'. +++ Like `per', the `rep' operator is active only for new-style +++ definition for representation domain. +compRep(["rep",x],m,e) == + $useRepresentationHack => nil + T := comp(x,"$",e) or return nil + rplac(second T,getRepresentation e or return nil) + coerce(T,m) --% --% Entry point to the compiler @@ -2231,6 +2306,8 @@ for x in [["|", :"compSuchthat"],_ ["Mapping", :"compCat"],_ ["UnionCategory", :"compConstructorCategory"],_ ["where", :"compWhere"],_ + ["per",:"compPer"],_ + ["rep",:"compRep"],_ ["%Comma",:"compComma"],_ ["%Match",:"compMatch"],_ ["[||]", :"compileQuasiquote"]] repeat diff --git a/src/interp/define.boot b/src/interp/define.boot index a026ed33..e3dc8934 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -106,13 +106,27 @@ $sigList := [] $atList := [] +++ True if the current functor definition refines a domain. +$subdomain := false + --% compDefineAddSignature: (%Form,%Signature,%Env) -> %Env DomainSubstitutionFunction: (%List,%Form) -> %Form ---% +--% Subdomains + +++ We are defining a functor with head given by `form', as a subdomain +++ of the domain designated by the domain form `super', and predicate +++ `pred' (a VM instruction form). Emit appropriate info into the +++ databases. +emitSubdomainInfo(form,super,pred) == + pred := eqSubst($AtVariables,rest form,pred) + super := eqSubst($AtVariables,rest form,super) + evalAndRwriteLispForm("evalOnLoad2",["noteSubDomainInfo", + quoteForm first form,quoteForm super, quoteForm pred]) + ++ List of operations defined in a given capsule ++ Each item on this list is of the form @@ -161,21 +175,23 @@ makePredicate l == --% FUNCTIONS WHICH MUNCH ON == STATEMENTS +++ List of reserved identifiers for which the compiler has special +++ meanings and that shall not be redefined. +$reservedNames == '(per rep _$) + +++ Check that `var' (a variable of parameter name) is not a reversed name. +checkVariableName var == + MEMQ(var,$reservedNames) => + stackAndThrow('"You cannot reserved name %1b as variable",[var]) + +checkParameterNames parms == + for p in parms repeat + checkVariableName p + compDefine(form,m,e) == $macroIfTrue: local := false compDefine1(form,m,e) -++ Activate synthetized pair concretization and abstraction -++ view morphisms for domains. -insertViewMorphisms: (%Mode,$Env) -> %Env -insertViewMorphisms(t,e) == - $useRepresentationHack => e - g := GENSYM() - repType := ["Mapping",t,"$"] - perType := ["Mapping","$",t] - e := put("rep","value",[["XLAM",[g],g],repType,nil],e) - put("per","value",[["XLAM",[g],g],perType,nil],e) - ++ We are about to process the body of a capsule. Check the form of ++ `Rep' definition, and whether it is appropriate to activate the ++ implicitly generated morphisms @@ -238,13 +254,15 @@ checkRepresentation(addForm,body,env) == else if null domainRep and addForm ^= nil then if $functorKind = "domain" and addForm isnt ["%Comma",:.] then domainRep := - addForm is ["SubDomain",dom,.] => dom + addForm is ["SubDomain",dom,.] => + $subdomain := true + dom addForm base := compForMode(domainRep,$EmptyMode,env) or stackAndThrow('"1b is not a domain",[domainRep]) $useRepresentationHack := false - env := insertViewMorphisms(base.expr,env) - -- ??? Maybe we should also make Rep available as macro. + env := put("Rep","value",base,env) + -- ??? Maybe we should also make Rep available as macro? env @@ -254,7 +272,8 @@ compDefine1(form,m,e) == --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] + => [lhs,m,put(first lhs,"macro",rhs,e)] + checkParameterNames rest lhs null signature.target and not MEMQ(KAR rhs,$BuiltinConstructorNames) and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration @@ -339,7 +358,9 @@ macroExpandInPlace(x,e) == macroExpand: (%Form,%Env) -> %Form macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) + atom x => + u:= get(x,"macro",e) => macroExpand(u,e) + x x is ['DEF,lhs,sig,spCases,rhs] => ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), macroExpand(rhs,e)] @@ -348,7 +369,7 @@ macroExpand(x,e) == --not worked out yet macroExpandList(l,e) == -- macros should override niladic props (l is [name]) and IDENTP name and niladicConstructorFromDB name and - (u := get(name, 'macro, e)) => macroExpand(u,e) + (u := get(name,"macro", e)) => macroExpand(u,e) [macroExpand(x,e) for x in l] --% constructor evaluation @@ -580,6 +601,7 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], [lineNumber,:$functorSpecialCases] := $functorSpecialCases -- 1. bind global variables $addForm: local := nil + $subdomain: local := false $viewNames: local:= nil --This list is only used in genDomainViewName, for generating names @@ -666,6 +688,14 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], -- 4. compile body in environment of %type declarations for arguments op':= $op rettype:= signature'.target + -- If this functor is defined as instantiation of a functor + -- that is a subdomain of `D', then make this functor also a subdomain + -- of that super domain `D'. + if body is ["add",[rhsCtor,:rhsArgs],["CAPSULE"]] + and constructor? rhsCtor + and (u := getSuperDomainFromDB rhsCtor) then + u := sublisFormal(rhsArgs,u,$AtVariables) + emitSubdomainInfo($form,first u, second u) T:= compFunctorBody(body,rettype,$e,parForm) -- If only compiling certain items, then ignore the body shell. $compileOnlyCertainItems => @@ -1445,12 +1475,8 @@ compSubDomain1(domainForm,predicate,m,e) == -- For now, reject predicates that directly reference domains CONTAINED("$",pred) => stackAndThrow('"predicate %1pb is not simple enough",[predicate]) - -- Abstract over references to parameters of enclosing functor. - pred := eqSubst($AtVariables,rest $form, pred) - $lisplibSuperDomain:= - [domainForm,predicate] - evalAndRwriteLispForm('evalOnLoad2, ["noteSubDomainInfo", quoteForm $op, - quoteForm domainForm, quoteForm pred]) + emitSubdomainInfo($form,domainForm,pred) + $lisplibSuperDomain := [domainForm,predicate] [domainForm,m,e] compCapsuleInner(itemList,m,e) == @@ -1516,10 +1542,8 @@ doIt(item,$predl) == $functorLocalParameters:= [:$functorLocalParameters,lhs] if code is ["%LET",.,rhs',:.] and isDomainForm(rhs',$e) then if lhs="Rep" then - $Representation:= (get("Rep",'value,$e)).expr + $Representation:= getRepresentation $e --$Representation bound by compDefineFunctor, used in compNoStacking - -- Activate view morphisms if appropriate - $e := insertViewMorphisms($Representation,$e) code is ["%LET",:.] => RPLACA(item,"setShellEntry") rhsCode := rhs' @@ -1537,7 +1561,7 @@ doIt(item,$predl) == item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) item is ['DEF,[op,:.],:.] => - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) + body:= isMacro(item,$e) => $e:= put(op,"macro",body,$e) [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) RPLACA(item,"CodeDefine") --Note that DescendCode, in CodeDefine, is looking for this diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index 49c0229a..4a0a91af 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -374,8 +374,9 @@ optLESSP u == $simpleVMoperators == '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND - SPADfirst QVELT _+ _- _* _< _= - QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP) + SPADfirst QVELT _+ _- _* _< _= ASH INTEGER_-LENGTH + QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP + MINUSP GREATERP) isSimpleVMForm form == isAtomicForm form => true @@ -392,6 +393,27 @@ isFloatableVMForm form == "and"/[isFloatableVMForm arg for arg in rest form] +++ Return true if the VM form `form' is one that we certify to +++ evaluate to a (compile time) constant. Note that this is a +++ fairly conservative approximation of compile time constants. +isVMConstantForm: %Code -> %Boolean +isVMConstantForm form == + INTEGERP form or STRINGP form => true + form=nil or form=true => true + form isnt [op,:args] => false + op = "QUOTE" => true + MEMQ(op,$simpleVMoperators) and + "and"/[isVMConstantForm arg for arg in args] + +++ Return the set of free variables in the VM form `form'. +findVMFreeVars form == + IDENTP form => [form] + form isnt [op,:args] => nil + op = "QUOTE" => nil + vars := union/[findVMFreeVars arg for arg in args] + atom op => vars + union(findVMFreeVars op,vars) + ++ Implement simple-minded LET-inlining. It seems we can't count ++ on Lisp implementations to do this simple transformation. ++ This transformation will probably be more effective when all diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 7889e49f..8826bd95 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -74,6 +74,14 @@ superType dom == [super,.] := getSuperDomainFromDB ctor or return nil sublisFormal(args,super,$AtVariables) +++ If the domain designated by the domain form `dom' is a subdomain, +++ then return its defining predicate. Otherwise, return nil. +domainVMPredicate dom == + dom = "$" => domainVMPredicate $functorForm + dom isnt [ctor,:args] => false + [.,pred] := getSuperDomainFromDB ctor or return nil + sublisFormal(args,pred,$AtVariables) + ++ Return the root of the reflexive transitive closure of ++ the super-domain chain for the domain designated by the domain ++ form `d'. @@ -104,15 +112,16 @@ isSubDomain(d1,d2) == [sup,pred] := getSuperDomainFromDB first d1 or return false -- 3. We may be onto something. - -- `sup' and `pred' are in most general form. Instantiate. - first sup = first d2 => - -- sanity check. `d2' should be an instance of `sup'. - sublisFormal(rest d1,sup,$AtVariables) ^= d2 => - stackAndThrow('"unexpected instantiation mismatch",nil) - sublisFormal(rest d1,pred,$AtVariables) + -- `sup' and `pred' are in most general form. We cannot just + -- test for the functors, as different arguments may instantiate + -- to super-domains. + args := rest d1 + sublisFormal(args,sup,$AtVariables) = d2 => + sublisFormal(args,pred,$AtVariables) -- 4. Otherwise, lookup in the super-domain chain. - pred' := isSubDomain(sup,d2) => MKPF([pred',pred],"AND") + pred' := isSubDomain(sup,d2) => + MKPF([pred',sublisFormal(args,pred,$AtVariables)],"AND") -- 5. Lot of smoke, no fire. false diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index d0386605..a64c0d97 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -1033,7 +1033,7 @@ displaySpad2Cmd l == v option = 'operations => displayOperations vl - option = 'macros => displayMacros vl + option = "macros" => displayMacros vl option = 'names => displayWorkspaceNames() displayProperties(option,l) optList:= [:['%l,'" ",x] for x in $displayOptions] diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot index fa924cb9..d34cc4b8 100644 --- a/src/interp/sys-utility.boot +++ b/src/interp/sys-utility.boot @@ -1,4 +1,4 @@ --- Copyright (C) 2007-2008 Gabriel Dos Reis. +-- Copyright (C) 2007-2009 Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -71,6 +71,7 @@ getVMType d == Record => #rest d' > 2 => "%Shell" "%Pair" + IndexedList => "%List" otherwise => "%Thing" -- good enough, for now. --% diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot index 54f9f744..718b413c 100644 --- a/src/interp/wi1.boot +++ b/src/interp/wi1.boot @@ -1079,7 +1079,7 @@ compDefine1(form,m,e) == --1. decompose after macro-expanding form ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] + => [lhs,m,put(first lhs,"macro",rhs,e)] null signature.target and not MEMQ(KAR rhs,$BuiltinConstructorNames) and (sig:= getSignatureFromMode(lhs,e)) => -- here signature of lhs is determined by a previous declaration diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index a7c951ca..5b8a57cb 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -411,7 +411,7 @@ compMakeCategoryObject(c,$e) == nil macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) + atom x => (u:= get(x,"macro",e) => macroExpand(u,e); x) x is ['DEF,lhs,sig,spCases,rhs] => ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), macroExpand(rhs,e)] @@ -1140,7 +1140,7 @@ rhsOfLetIsDomainForm code == doItDef item == ['DEF,[op,:.],:.] := item - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) + body:= isMacro(item,$e) => $e:= put(op,"macro",body,$e) [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) chk(item,3) RPLACA(item,"CodeDefine") |