From 351022a3ec02f6e131d54f3a5bcb27a8dfffbcb0 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 7 Feb 2011 00:39:58 +0000 Subject: * interp/c-util.boot (matchingEXIT): New. (simplifySEQ): Use it. --- src/algebra/strap/DFLOAT.lsp | 130 ++++---- src/algebra/strap/EUCDOM-.lsp | 212 ++++++------- src/algebra/strap/FFIELDC-.lsp | 667 ++++++++++++++++++++--------------------- src/algebra/strap/GCDDOM-.lsp | 139 ++++----- src/algebra/strap/ILIST.lsp | 156 +++++----- src/algebra/strap/INT.lsp | 16 +- src/algebra/strap/ISTRING.lsp | 10 +- src/algebra/strap/LSAGG-.lsp | 177 +++++------ src/algebra/strap/OUTFORM.lsp | 25 +- src/algebra/strap/POLYCAT-.lsp | 420 +++++++++++++------------- src/algebra/strap/RNS-.lsp | 33 +- src/algebra/strap/SINT.lsp | 15 +- src/algebra/strap/STAGG-.lsp | 10 +- src/algebra/strap/SYMBOL.lsp | 234 +++++++-------- src/algebra/strap/URAGG-.lsp | 333 ++++++++++---------- 15 files changed, 1222 insertions(+), 1355 deletions(-) (limited to 'src/algebra/strap') diff --git a/src/algebra/strap/DFLOAT.lsp b/src/algebra/strap/DFLOAT.lsp index 3b21f1ba..f8825345 100644 --- a/src/algebra/strap/DFLOAT.lsp +++ b/src/algebra/strap/DFLOAT.lsp @@ -688,20 +688,20 @@ (DEFUN |DFLOAT;atan;3$;78| (|x| |y| $) (PROG (|theta|) (RETURN - (SEQ (COND - ((ZEROP |x|) - (COND - ((PLUSP |y|) (/ (COERCE PI '|%DoubleFloat|) 2)) - ((MINUSP |y|) (- (/ (COERCE PI '|%DoubleFloat|) 2))) - (T 0.0))) - (T (SEQ (LETT |theta| (ATAN (ABS (/ |y| |x|))) - |DFLOAT;atan;3$;78|) - (COND - ((MINUSP |x|) - (SETQ |theta| - (- (COERCE PI '|%DoubleFloat|) |theta|)))) - (COND ((MINUSP |y|) (SETQ |theta| (- |theta|)))) - (EXIT |theta|)))))))) + (COND + ((ZEROP |x|) + (COND + ((PLUSP |y|) (/ (COERCE PI '|%DoubleFloat|) 2)) + ((MINUSP |y|) (- (/ (COERCE PI '|%DoubleFloat|) 2))) + (T 0.0))) + (T (SEQ (LETT |theta| (ATAN (ABS (/ |y| |x|))) + |DFLOAT;atan;3$;78|) + (COND + ((MINUSP |x|) + (SETQ |theta| + (- (COERCE PI '|%DoubleFloat|) |theta|)))) + (COND ((MINUSP |y|) (SETQ |theta| (- |theta|)))) + (EXIT |theta|))))))) (DEFUN |DFLOAT;retract;$F;79| (|x| $) (|DFLOAT;rationalApproximation;$2NniF;86| |x| @@ -747,25 +747,23 @@ (DEFUN |DFLOAT;manexp| (|x| $) (PROG (|s| |me| |two53|) (RETURN - (SEQ (COND - ((ZEROP |x|) (CONS 0 0)) - (T (SEQ (LETT |s| (|DFLOAT;sign;$I;83| |x| $) - |DFLOAT;manexp|) - (SETQ |x| (ABS |x|)) - (COND - ((< |$DoubleFloatMaximum| |x|) - (RETURN-FROM |DFLOAT;manexp| - (CONS (+ (* |s| - (|DFLOAT;mantissa;$I;6| + (COND + ((ZEROP |x|) (CONS 0 0)) + (T (SEQ (LETT |s| (|DFLOAT;sign;$I;83| |x| $) |DFLOAT;manexp|) + (SETQ |x| (ABS |x|)) + (COND + ((< |$DoubleFloatMaximum| |x|) + (RETURN-FROM |DFLOAT;manexp| + (CONS (+ (* |s| + (|DFLOAT;mantissa;$I;6| |$DoubleFloatMaximum| $)) - 1) - (|DFLOAT;exponent;$I;7| - |$DoubleFloatMaximum| $))))) - (LETT |me| (MANEXP |x|) |DFLOAT;manexp|) - (LETT |two53| (EXPT 2 53) |DFLOAT;manexp|) - (EXIT (CONS (* |s| - (TRUNCATE (* |two53| (CAR |me|)))) - (- (CDR |me|) 53)))))))))) + 1) + (|DFLOAT;exponent;$I;7| + |$DoubleFloatMaximum| $))))) + (LETT |me| (MANEXP |x|) |DFLOAT;manexp|) + (LETT |two53| (EXPT 2 53) |DFLOAT;manexp|) + (EXIT (CONS (* |s| (TRUNCATE (* |two53| (CAR |me|)))) + (- (CDR |me|) 53))))))))) (DEFUN |DFLOAT;rationalApproximation;$2NniF;86| (|f| |d| |b| $) (PROG (BASE |de| |tol| |s| |t| |p0| |p1| |q0| |q1| |#G106| |q| |r| @@ -871,44 +869,36 @@ (DEFUN |DFLOAT;**;$F$;87| (|x| |r| $) (PROG (|n| |d|) (RETURN - (SEQ (COND - ((ZEROP |x|) - (COND - ((SPADCALL |r| (|getShellEntry| $ 145)) - (|error| "0**0 is undefined")) - ((SPADCALL |r| (|getShellEntry| $ 146)) - (|error| "division by 0")) - (T 0.0))) - ((OR (SPADCALL |r| (|getShellEntry| $ 145)) (= |x| 1.0)) - 1.0) - ((SPADCALL |r| (|getShellEntry| $ 147)) |x|) - (T (SEQ (LETT |n| (SPADCALL |r| (|getShellEntry| $ 148)) - |DFLOAT;**;$F$;87|) - (LETT |d| (SPADCALL |r| (|getShellEntry| $ 149)) - |DFLOAT;**;$F$;87|) - (EXIT (COND - ((MINUSP |x|) - (COND - ((ODDP |d|) - (COND - ((ODDP |n|) - (RETURN-FROM |DFLOAT;**;$F$;87| - (- - (|DFLOAT;**;$F$;87| (- |x|) |r| - $)))) - (T - (RETURN-FROM |DFLOAT;**;$F$;87| - (|DFLOAT;**;$F$;87| (- |x|) |r| - $))))) - (T (|error| "negative root")))) - ((EQL |d| 2) - (EXPT (C-TO-R (SQRT |x|)) |n|)) - (T (C-TO-R (EXPT |x| - (/ - (FLOAT |n| - |$DoubleFloatMaximum|) - (FLOAT |d| - |$DoubleFloatMaximum|)))))))))))))) + (COND + ((ZEROP |x|) + (COND + ((SPADCALL |r| (|getShellEntry| $ 145)) + (|error| "0**0 is undefined")) + ((SPADCALL |r| (|getShellEntry| $ 146)) + (|error| "division by 0")) + (T 0.0))) + ((OR (SPADCALL |r| (|getShellEntry| $ 145)) (= |x| 1.0)) 1.0) + ((SPADCALL |r| (|getShellEntry| $ 147)) |x|) + (T (SEQ (LETT |n| (SPADCALL |r| (|getShellEntry| $ 148)) + |DFLOAT;**;$F$;87|) + (LETT |d| (SPADCALL |r| (|getShellEntry| $ 149)) + |DFLOAT;**;$F$;87|) + (EXIT (COND + ((MINUSP |x|) + (COND + ((ODDP |d|) + (COND + ((ODDP |n|) + (RETURN-FROM |DFLOAT;**;$F$;87| + (- (|DFLOAT;**;$F$;87| (- |x|) |r| $)))) + (T (RETURN-FROM |DFLOAT;**;$F$;87| + (|DFLOAT;**;$F$;87| (- |x|) |r| $))))) + (T (|error| "negative root")))) + ((EQL |d| 2) (EXPT (C-TO-R (SQRT |x|)) |n|)) + (T (C-TO-R (EXPT |x| + (/ + (FLOAT |n| |$DoubleFloatMaximum|) + (FLOAT |d| |$DoubleFloatMaximum|))))))))))))) (DEFUN |DoubleFloat| () (DECLARE (SPECIAL |$ConstructorCache|)) diff --git a/src/algebra/strap/EUCDOM-.lsp b/src/algebra/strap/EUCDOM-.lsp index d9375a0c..f391c801 100644 --- a/src/algebra/strap/EUCDOM-.lsp +++ b/src/algebra/strap/EUCDOM-.lsp @@ -51,18 +51,16 @@ (DEFUN |EUCDOM-;exquo;2SU;4| (|x| |y| $) (PROG (|qr|) (RETURN - (SEQ (COND - ((SPADCALL |x| (|getShellEntry| $ 8)) - (CONS 0 (|spadConstant| $ 19))) - ((SPADCALL |y| (|getShellEntry| $ 8)) (CONS 1 "failed")) - (T (SEQ (LETT |qr| - (SPADCALL |x| |y| (|getShellEntry| $ 16)) - |EUCDOM-;exquo;2SU;4|) - (EXIT (COND - ((SPADCALL (CDR |qr|) - (|getShellEntry| $ 8)) - (CONS 0 (CAR |qr|))) - (T (CONS 1 "failed"))))))))))) + (COND + ((SPADCALL |x| (|getShellEntry| $ 8)) + (CONS 0 (|spadConstant| $ 19))) + ((SPADCALL |y| (|getShellEntry| $ 8)) (CONS 1 "failed")) + (T (SEQ (LETT |qr| (SPADCALL |x| |y| (|getShellEntry| $ 16)) + |EUCDOM-;exquo;2SU;4|) + (EXIT (COND + ((SPADCALL (CDR |qr|) (|getShellEntry| $ 8)) + (CONS 0 (CAR |qr|))) + (T (CONS 1 "failed")))))))))) (DEFUN |EUCDOM-;gcd;3S;5| (|x| |y| $) (PROG (|#G13| |#G14|) @@ -162,35 +160,31 @@ (DEFUN |EUCDOM-;extendedEuclidean;3SU;8| (|x| |y| |z| $) (PROG (|s| |w| |qr|) (RETURN - (SEQ (COND - ((SPADCALL |z| (|getShellEntry| $ 8)) - (CONS 0 - (CONS (|spadConstant| $ 19) (|spadConstant| $ 19)))) - (T (SEQ (LETT |s| - (SPADCALL |x| |y| (|getShellEntry| $ 36)) - |EUCDOM-;extendedEuclidean;3SU;8|) - (LETT |w| - (SPADCALL |z| (SVREF |s| 2) - (|getShellEntry| $ 37)) - |EUCDOM-;extendedEuclidean;3SU;8|) - (EXIT (COND - ((EQL (CAR |w|) 1) (CONS 1 "failed")) - ((SPADCALL |y| (|getShellEntry| $ 8)) - (CONS 0 - (CONS - (SPADCALL (SVREF |s| 0) (CDR |w|) + (COND + ((SPADCALL |z| (|getShellEntry| $ 8)) + (CONS 0 (CONS (|spadConstant| $ 19) (|spadConstant| $ 19)))) + (T (SEQ (LETT |s| (SPADCALL |x| |y| (|getShellEntry| $ 36)) + |EUCDOM-;extendedEuclidean;3SU;8|) + (LETT |w| + (SPADCALL |z| (SVREF |s| 2) + (|getShellEntry| $ 37)) + |EUCDOM-;extendedEuclidean;3SU;8|) + (EXIT (COND + ((EQL (CAR |w|) 1) (CONS 1 "failed")) + ((SPADCALL |y| (|getShellEntry| $ 8)) + (CONS 0 + (CONS (SPADCALL (SVREF |s| 0) (CDR |w|) (|getShellEntry| $ 29)) (SPADCALL (SVREF |s| 1) (CDR |w|) (|getShellEntry| $ 29))))) - (T (SEQ (LETT |qr| + (T (SEQ (LETT |qr| (SPADCALL (SPADCALL (SVREF |s| 0) (CDR |w|) (|getShellEntry| $ 29)) |y| (|getShellEntry| $ 16)) |EUCDOM-;extendedEuclidean;3SU;8|) - (EXIT - (CONS 0 + (EXIT (CONS 0 (CONS (CDR |qr|) (SPADCALL (SPADCALL (SVREF |s| 1) @@ -198,96 +192,86 @@ (|getShellEntry| $ 29)) (SPADCALL (CAR |qr|) |x| (|getShellEntry| $ 29)) - (|getShellEntry| $ 33)))))))))))))))) + (|getShellEntry| $ 33))))))))))))))) (DEFUN |EUCDOM-;principalIdeal;LR;9| (|l| $) (PROG (|uca| |v| |u|) (RETURN - (SEQ (COND - ((SPADCALL |l| NIL (|getShellEntry| $ 42)) - (|error| "empty list passed to principalIdeal")) - ((SPADCALL (CDR |l|) NIL (|getShellEntry| $ 42)) - (SEQ (LETT |uca| - (SPADCALL (|SPADfirst| |l|) - (|getShellEntry| $ 27)) - |EUCDOM-;principalIdeal;LR;9|) - (EXIT (CONS (LIST (SVREF |uca| 0)) (SVREF |uca| 1))))) - ((SPADCALL (CDR (CDR |l|)) NIL (|getShellEntry| $ 42)) - (SEQ (LETT |u| - (SPADCALL (|SPADfirst| |l|) - (SPADCALL |l| (|getShellEntry| $ 45)) - (|getShellEntry| $ 36)) - |EUCDOM-;principalIdeal;LR;9|) - (EXIT (CONS (LIST (SVREF |u| 0) (SVREF |u| 1)) - (SVREF |u| 2))))) - (T (SEQ (LETT |v| - (SPADCALL (CDR |l|) (|getShellEntry| $ 48)) - |EUCDOM-;principalIdeal;LR;9|) - (LETT |u| - (SPADCALL (|SPADfirst| |l|) (CDR |v|) - (|getShellEntry| $ 36)) - |EUCDOM-;principalIdeal;LR;9|) - (EXIT (CONS (CONS (SVREF |u| 0) - (LET - ((#0=#:G1494 (CAR |v|)) - (#1=#:G1493 NIL)) - (LOOP - (COND - ((ATOM #0#) - (RETURN (NREVERSE #1#))) - (T - (LET ((|vv| (CAR #0#))) - (SETQ #1# - (CONS - (SPADCALL - (SVREF |u| 1) |vv| - (|getShellEntry| $ - 29)) - #1#))))) - (SETQ #0# (CDR #0#))))) - (SVREF |u| 2)))))))))) + (COND + ((SPADCALL |l| NIL (|getShellEntry| $ 42)) + (|error| "empty list passed to principalIdeal")) + ((SPADCALL (CDR |l|) NIL (|getShellEntry| $ 42)) + (SEQ (LETT |uca| + (SPADCALL (|SPADfirst| |l|) (|getShellEntry| $ 27)) + |EUCDOM-;principalIdeal;LR;9|) + (EXIT (CONS (LIST (SVREF |uca| 0)) (SVREF |uca| 1))))) + ((SPADCALL (CDR (CDR |l|)) NIL (|getShellEntry| $ 42)) + (SEQ (LETT |u| + (SPADCALL (|SPADfirst| |l|) + (SPADCALL |l| (|getShellEntry| $ 45)) + (|getShellEntry| $ 36)) + |EUCDOM-;principalIdeal;LR;9|) + (EXIT (CONS (LIST (SVREF |u| 0) (SVREF |u| 1)) + (SVREF |u| 2))))) + (T (SEQ (LETT |v| (SPADCALL (CDR |l|) (|getShellEntry| $ 48)) + |EUCDOM-;principalIdeal;LR;9|) + (LETT |u| + (SPADCALL (|SPADfirst| |l|) (CDR |v|) + (|getShellEntry| $ 36)) + |EUCDOM-;principalIdeal;LR;9|) + (EXIT (CONS (CONS (SVREF |u| 0) + (LET ((#0=#:G1494 (CAR |v|)) + (#1=#:G1493 NIL)) + (LOOP + (COND + ((ATOM #0#) + (RETURN (NREVERSE #1#))) + (T + (LET ((|vv| (CAR #0#))) + (SETQ #1# + (CONS + (SPADCALL (SVREF |u| 1) + |vv| + (|getShellEntry| $ 29)) + #1#))))) + (SETQ #0# (CDR #0#))))) + (SVREF |u| 2))))))))) (DEFUN |EUCDOM-;expressIdealMember;LSU;10| (|l| |z| $) (PROG (|pid| |q|) (RETURN - (SEQ (COND - ((SPADCALL |z| (|spadConstant| $ 19) - (|getShellEntry| $ 51)) - (CONS 0 - (LET ((#0=#:G1496 |l|) (#1=#:G1495 NIL)) - (LOOP - (COND - ((ATOM #0#) (RETURN (NREVERSE #1#))) - (T (LET ((|v| (CAR #0#))) - (SETQ #1# - (CONS (|spadConstant| $ 19) #1#))))) - (SETQ #0# (CDR #0#)))))) - (T (SEQ (LETT |pid| (SPADCALL |l| (|getShellEntry| $ 48)) - |EUCDOM-;expressIdealMember;LSU;10|) - (LETT |q| - (SPADCALL |z| (CDR |pid|) - (|getShellEntry| $ 37)) - |EUCDOM-;expressIdealMember;LSU;10|) - (EXIT (COND - ((EQL (CAR |q|) 1) (CONS 1 "failed")) - (T (CONS 0 - (LET - ((#2=#:G1498 (CAR |pid|)) - (#3=#:G1497 NIL)) - (LOOP - (COND - ((ATOM #2#) - (RETURN (NREVERSE #3#))) - (T - (LET ((|v| (CAR #2#))) - (SETQ #3# - (CONS - (SPADCALL (CDR |q|) - |v| - (|getShellEntry| $ - 29)) - #3#))))) - (SETQ #2# (CDR #2#))))))))))))))) + (COND + ((SPADCALL |z| (|spadConstant| $ 19) (|getShellEntry| $ 51)) + (CONS 0 + (LET ((#0=#:G1496 |l|) (#1=#:G1495 NIL)) + (LOOP + (COND + ((ATOM #0#) (RETURN (NREVERSE #1#))) + (T (LET ((|v| (CAR #0#))) + (SETQ #1# (CONS (|spadConstant| $ 19) #1#))))) + (SETQ #0# (CDR #0#)))))) + (T (SEQ (LETT |pid| (SPADCALL |l| (|getShellEntry| $ 48)) + |EUCDOM-;expressIdealMember;LSU;10|) + (LETT |q| + (SPADCALL |z| (CDR |pid|) (|getShellEntry| $ 37)) + |EUCDOM-;expressIdealMember;LSU;10|) + (EXIT (COND + ((EQL (CAR |q|) 1) (CONS 1 "failed")) + (T (CONS 0 + (LET ((#2=#:G1498 (CAR |pid|)) + (#3=#:G1497 NIL)) + (LOOP + (COND + ((ATOM #2#) + (RETURN (NREVERSE #3#))) + (T + (LET ((|v| (CAR #2#))) + (SETQ #3# + (CONS + (SPADCALL (CDR |q|) |v| + (|getShellEntry| $ 29)) + #3#))))) + (SETQ #2# (CDR #2#)))))))))))))) (DEFUN |EUCDOM-;multiEuclidean;LSU;11| (|l| |z| $) (PROG (|l1| |l2| |u| |v1| |v2|) diff --git a/src/algebra/strap/FFIELDC-.lsp b/src/algebra/strap/FFIELDC-.lsp index ff4359c7..c4fb644f 100644 --- a/src/algebra/strap/FFIELDC-.lsp +++ b/src/algebra/strap/FFIELDC-.lsp @@ -120,363 +120,334 @@ (DEFUN |FFIELDC-;primitive?;SB;9| (|a| $) (PROG (|explist| |q| |equalone|) (RETURN - (SEQ (COND - ((SPADCALL |a| (|getShellEntry| $ 16)) NIL) - (T (SEQ (LETT |explist| (SPADCALL (|getShellEntry| $ 56)) - |FFIELDC-;primitive?;SB;9|) - (LETT |q| (- (SPADCALL (|getShellEntry| $ 40)) 1) - |FFIELDC-;primitive?;SB;9|) - (LETT |equalone| NIL |FFIELDC-;primitive?;SB;9|) - (LET ((#0=#:G1488 |explist|) (|exp| NIL)) - (LOOP - (COND - ((OR (ATOM #0#) - (PROGN (SETQ |exp| (CAR #0#)) NIL) - (NOT (NOT |equalone|))) - (RETURN NIL)) - (T (SETQ |equalone| - (SPADCALL - (SPADCALL |a| - (TRUNCATE |q| (CAR |exp|)) - (|getShellEntry| $ 58)) - (|getShellEntry| $ 59))))) - (SETQ #0# (CDR #0#)))) - (EXIT (NOT |equalone|))))))))) + (COND + ((SPADCALL |a| (|getShellEntry| $ 16)) NIL) + (T (SEQ (LETT |explist| (SPADCALL (|getShellEntry| $ 56)) + |FFIELDC-;primitive?;SB;9|) + (LETT |q| (- (SPADCALL (|getShellEntry| $ 40)) 1) + |FFIELDC-;primitive?;SB;9|) + (LETT |equalone| NIL |FFIELDC-;primitive?;SB;9|) + (LET ((#0=#:G1488 |explist|) (|exp| NIL)) + (LOOP + (COND + ((OR (ATOM #0#) + (PROGN (SETQ |exp| (CAR #0#)) NIL) + (NOT (NOT |equalone|))) + (RETURN NIL)) + (T (SETQ |equalone| + (SPADCALL + (SPADCALL |a| + (TRUNCATE |q| (CAR |exp|)) + (|getShellEntry| $ 58)) + (|getShellEntry| $ 59))))) + (SETQ #0# (CDR #0#)))) + (EXIT (NOT |equalone|)))))))) (DEFUN |FFIELDC-;order;SPi;10| (|e| $) (PROG (|primeDivisor| |a| |goon| |ord| |lof|) (RETURN - (SEQ (COND - ((SPADCALL |e| (|spadConstant| $ 7) - (|getShellEntry| $ 63)) - (|error| "order(0) is not defined ")) - (T (SEQ (LETT |ord| - (- (SPADCALL (|getShellEntry| $ 40)) 1) - |FFIELDC-;order;SPi;10|) - (LETT |lof| (SPADCALL (|getShellEntry| $ 56)) - |FFIELDC-;order;SPi;10|) - (LET ((#0=#:G1489 |lof|)) - (LOOP - (COND - ((ATOM #0#) (RETURN NIL)) - (T (LET ((|rec| (CAR #0#))) - (SEQ (LETT |a| + (COND + ((SPADCALL |e| (|spadConstant| $ 7) (|getShellEntry| $ 63)) + (|error| "order(0) is not defined ")) + (T (SEQ (LETT |ord| (- (SPADCALL (|getShellEntry| $ 40)) 1) + |FFIELDC-;order;SPi;10|) + (LETT |lof| (SPADCALL (|getShellEntry| $ 56)) + |FFIELDC-;order;SPi;10|) + (LET ((#0=#:G1489 |lof|)) + (LOOP + (COND + ((ATOM #0#) (RETURN NIL)) + (T (LET ((|rec| (CAR #0#))) + (SEQ (LETT |a| (TRUNCATE |ord| (LETT |primeDivisor| (CAR |rec|) |FFIELDC-;order;SPi;10|)) |FFIELDC-;order;SPi;10|) - (LETT |goon| + (LETT |goon| (SPADCALL (SPADCALL |e| |a| (|getShellEntry| $ 58)) (|getShellEntry| $ 59)) |FFIELDC-;order;SPi;10|) - (LET - ((|j| 0) - (#1=#:G1490 (- (CDR |rec|) 2))) - (LOOP - (COND - ((OR (> |j| #1#) - (NOT |goon|)) - (RETURN NIL)) - (T - (SEQ (SETQ |ord| |a|) - (SETQ |a| - (TRUNCATE |ord| - |primeDivisor|)) - (EXIT - (SETQ |goon| - (SPADCALL - (SPADCALL |e| |a| - (|getShellEntry| $ 58)) - (|getShellEntry| $ 59))))))) - (SETQ |j| (+ |j| 1)))) - (EXIT - (COND (|goon| (SETQ |ord| |a|)))))))) - (SETQ #0# (CDR #0#)))) - (EXIT |ord|)))))))) + (LET ((|j| 0) + (#1=#:G1490 (- (CDR |rec|) 2))) + (LOOP + (COND + ((OR (> |j| #1#) (NOT |goon|)) + (RETURN NIL)) + (T + (SEQ (SETQ |ord| |a|) + (SETQ |a| + (TRUNCATE |ord| + |primeDivisor|)) + (EXIT + (SETQ |goon| + (SPADCALL + (SPADCALL |e| |a| + (|getShellEntry| $ 58)) + (|getShellEntry| $ 59))))))) + (SETQ |j| (+ |j| 1)))) + (EXIT (COND (|goon| (SETQ |ord| |a|)))))))) + (SETQ #0# (CDR #0#)))) + (EXIT |ord|))))))) (DEFUN |FFIELDC-;discreteLog;SNni;11| (|b| $) (PROG (|rho| |exptable| |n| |c| |end| |found| |disc1| |fac| |faclist| |a| |gen| |disclog| |mult| |groupord| |exp|) (RETURN - (SEQ (COND - ((SPADCALL |b| (|getShellEntry| $ 16)) - (|error| "discreteLog: logarithm of zero")) - (T (SEQ (LETT |faclist| (SPADCALL (|getShellEntry| $ 56)) - |FFIELDC-;discreteLog;SNni;11|) - (LETT |a| |b| |FFIELDC-;discreteLog;SNni;11|) - (LETT |gen| (SPADCALL (|getShellEntry| $ 65)) - |FFIELDC-;discreteLog;SNni;11|) - (EXIT (COND - ((SPADCALL |b| |gen| - (|getShellEntry| $ 63)) - 1) - (T (SEQ (LETT |disclog| 0 + (COND + ((SPADCALL |b| (|getShellEntry| $ 16)) + (|error| "discreteLog: logarithm of zero")) + (T (SEQ (LETT |faclist| (SPADCALL (|getShellEntry| $ 56)) + |FFIELDC-;discreteLog;SNni;11|) + (LETT |a| |b| |FFIELDC-;discreteLog;SNni;11|) + (LETT |gen| (SPADCALL (|getShellEntry| $ 65)) + |FFIELDC-;discreteLog;SNni;11|) + (EXIT (COND + ((SPADCALL |b| |gen| (|getShellEntry| $ 63)) 1) + (T (SEQ (LETT |disclog| 0 |FFIELDC-;discreteLog;SNni;11|) - (LETT |mult| 1 + (LETT |mult| 1 |FFIELDC-;discreteLog;SNni;11|) - (LETT |groupord| + (LETT |groupord| (- (SPADCALL (|getShellEntry| $ 40)) 1) |FFIELDC-;discreteLog;SNni;11|) - (LETT |exp| |groupord| + (LETT |exp| |groupord| |FFIELDC-;discreteLog;SNni;11|) - (LET ((#0=#:G1491 |faclist|)) - (LOOP - (COND - ((ATOM #0#) (RETURN NIL)) - (T - (LET ((|f| (CAR #0#))) - (SEQ - (LETT |fac| (CAR |f|) - |FFIELDC-;discreteLog;SNni;11|) - (EXIT - (LET - ((|t| 0) - (#1=#:G1492 - (- (CDR |f|) 1))) - (LOOP - (COND - ((> |t| #1#) - (RETURN NIL)) - (T - (SEQ - (SETQ |exp| - (TRUNCATE - |exp| |fac|)) - (LETT - |exptable| - (SPADCALL - |fac| - (|getShellEntry| - $ 67)) - |FFIELDC-;discreteLog;SNni;11|) - (LETT |n| - (SPADCALL - |exptable| - (|getShellEntry| - $ 68)) - |FFIELDC-;discreteLog;SNni;11|) - (LETT |c| - (SPADCALL |a| - |exp| - (|getShellEntry| - $ 58)) - |FFIELDC-;discreteLog;SNni;11|) - (LETT |end| - (TRUNCATE - (- |fac| 1) - |n|) - |FFIELDC-;discreteLog;SNni;11|) - (LETT |found| - NIL - |FFIELDC-;discreteLog;SNni;11|) - (LETT |disc1| 0 - |FFIELDC-;discreteLog;SNni;11|) - (LET ((|i| 0)) - (LOOP + (LET ((#0=#:G1491 |faclist|)) + (LOOP + (COND + ((ATOM #0#) (RETURN NIL)) + (T + (LET ((|f| (CAR #0#))) + (SEQ + (LETT |fac| (CAR |f|) + |FFIELDC-;discreteLog;SNni;11|) + (EXIT + (LET + ((|t| 0) + (#1=#:G1492 + (- (CDR |f|) 1))) + (LOOP + (COND + ((> |t| #1#) + (RETURN NIL)) + (T + (SEQ + (SETQ |exp| + (TRUNCATE |exp| + |fac|)) + (LETT |exptable| + (SPADCALL |fac| + (|getShellEntry| $ + 67)) + |FFIELDC-;discreteLog;SNni;11|) + (LETT |n| + (SPADCALL + |exptable| + (|getShellEntry| $ + 68)) + |FFIELDC-;discreteLog;SNni;11|) + (LETT |c| + (SPADCALL |a| |exp| + (|getShellEntry| $ + 58)) + |FFIELDC-;discreteLog;SNni;11|) + (LETT |end| + (TRUNCATE + (- |fac| 1) |n|) + |FFIELDC-;discreteLog;SNni;11|) + (LETT |found| NIL + |FFIELDC-;discreteLog;SNni;11|) + (LETT |disc1| 0 + |FFIELDC-;discreteLog;SNni;11|) + (LET ((|i| 0)) + (LOOP + (COND + ((OR + (> |i| + |end|) + (NOT + (NOT + |found|))) + (RETURN NIL)) + (T + (SEQ + (LETT |rho| + (SPADCALL + (SPADCALL + |c| + (|getShellEntry| + $ 11)) + |exptable| + (|getShellEntry| + $ 71)) + |FFIELDC-;discreteLog;SNni;11|) + (EXIT (COND - ((OR - (> |i| - |end|) - (NOT - (NOT - |found|))) - (RETURN - NIL)) - (T + ((ZEROP + (CAR + |rho|)) (SEQ - (LETT - |rho| + (SETQ + |found| + T) + (EXIT + (SETQ + |disc1| + (* + (+ + (* + |n| + |i|) + (CDR + |rho|)) + |mult|))))) + (T + (SETQ + |c| + (SPADCALL + |c| (SPADCALL - (SPADCALL - |c| - (|getShellEntry| - $ - 11)) - |exptable| + |gen| + (* + (TRUNCATE + |groupord| + |fac|) + (- + |n|)) (|getShellEntry| $ - 71)) - |FFIELDC-;discreteLog;SNni;11|) - (EXIT - (COND - ((ZEROP - (CAR - |rho|)) - (SEQ - (SETQ - |found| - T) - (EXIT - (SETQ - |disc1| - (* - (+ - (* - |n| - |i|) - (CDR - |rho|)) - |mult|))))) - (T - (SETQ - |c| - (SPADCALL - |c| - (SPADCALL - |gen| - (* - (TRUNCATE - |groupord| - |fac|) - (- - |n|)) - (|getShellEntry| - $ - 58)) - (|getShellEntry| - $ - 77))))))))) - (SETQ |i| - (+ |i| 1)))) - (EXIT - (COND - (|found| - (SEQ - (SETQ - |mult| - (* |mult| - |fac|)) - (SETQ - |disclog| - (+ - |disclog| - |disc1|)) - (EXIT - (SETQ |a| - (SPADCALL - |a| - (SPADCALL - |gen| - (- - |disc1|) + 58)) (|getShellEntry| - $ 58)) - (|getShellEntry| - $ 77)))))) - (T - (|error| - "discreteLog: ?? discrete logarithm"))))))) - (SETQ |t| - (+ |t| 1))))))))) - (SETQ #0# (CDR #0#)))) - (EXIT |disclog|)))))))))))) + $ 77))))))))) + (SETQ |i| + (+ |i| 1)))) + (EXIT + (COND + (|found| + (SEQ + (SETQ |mult| + (* |mult| + |fac|)) + (SETQ |disclog| + (+ |disclog| + |disc1|)) + (EXIT + (SETQ |a| + (SPADCALL |a| + (SPADCALL + |gen| + (- |disc1|) + (|getShellEntry| + $ 58)) + (|getShellEntry| + $ 77)))))) + (T + (|error| + "discreteLog: ?? discrete logarithm"))))))) + (SETQ |t| (+ |t| 1))))))))) + (SETQ #0# (CDR #0#)))) + (EXIT |disclog|))))))))))) (DEFUN |FFIELDC-;discreteLog;2SU;12| (|logbase| |b| $) (PROG (|rhoHelp| |rho| |fac| |primroot| |groupord| |faclist| |a| |disclog| |mult| |exp|) (RETURN - (SEQ (COND - ((SPADCALL |b| (|getShellEntry| $ 16)) - (SEQ (SPADCALL "discreteLog: logarithm of zero" - (|getShellEntry| $ 83)) - (EXIT (CONS 1 "failed")))) - ((SPADCALL |logbase| (|getShellEntry| $ 16)) - (SEQ (SPADCALL "discreteLog: logarithm to base zero" - (|getShellEntry| $ 83)) - (EXIT (CONS 1 "failed")))) - ((SPADCALL |b| |logbase| (|getShellEntry| $ 63)) - (CONS 0 1)) - (T (COND - ((NOT (ZEROP (REM (LETT |groupord| + (COND + ((SPADCALL |b| (|getShellEntry| $ 16)) + (SEQ (SPADCALL "discreteLog: logarithm of zero" + (|getShellEntry| $ 83)) + (EXIT (CONS 1 "failed")))) + ((SPADCALL |logbase| (|getShellEntry| $ 16)) + (SEQ (SPADCALL "discreteLog: logarithm to base zero" + (|getShellEntry| $ 83)) + (EXIT (CONS 1 "failed")))) + ((SPADCALL |b| |logbase| (|getShellEntry| $ 63)) (CONS 0 1)) + (T (COND + ((NOT (ZEROP (REM (LETT |groupord| (SPADCALL |logbase| (|getShellEntry| $ 19)) |FFIELDC-;discreteLog;2SU;12|) - (SPADCALL |b| - (|getShellEntry| $ 19))))) - (SEQ (SPADCALL - "discreteLog: second argument not in cyclic group generated by first argument" - (|getShellEntry| $ 83)) - (EXIT (CONS 1 "failed")))) - (T (SEQ (LETT |faclist| - (SPADCALL - (SPADCALL |groupord| - (|getShellEntry| $ 87)) - (|getShellEntry| $ 89)) - |FFIELDC-;discreteLog;2SU;12|) - (LETT |a| |b| |FFIELDC-;discreteLog;2SU;12|) - (LETT |disclog| 0 - |FFIELDC-;discreteLog;2SU;12|) - (LETT |mult| 1 |FFIELDC-;discreteLog;2SU;12|) - (LETT |exp| |groupord| - |FFIELDC-;discreteLog;2SU;12|) - (LET ((#0=#:G1493 |faclist|)) - (LOOP - (COND - ((ATOM #0#) (RETURN NIL)) - (T (LET ((|f| (CAR #0#))) - (SEQ - (LETT |fac| (CAR |f|) - |FFIELDC-;discreteLog;2SU;12|) - (LETT |primroot| - (SPADCALL |logbase| - (TRUNCATE |groupord| |fac|) - (|getShellEntry| $ 58)) - |FFIELDC-;discreteLog;2SU;12|) - (EXIT - (LET - ((|t| 0) - (#1=#:G1494 (- (CDR |f|) 1))) - (LOOP - (COND - ((> |t| #1#) (RETURN NIL)) - (T - (SEQ - (SETQ |exp| - (TRUNCATE |exp| |fac|)) - (LETT |rhoHelp| - (SPADCALL |primroot| - (SPADCALL |a| |exp| - (|getShellEntry| $ - 58)) - |fac| - (|getShellEntry| $ 91)) - |FFIELDC-;discreteLog;2SU;12|) - (EXIT - (COND - ((EQL (CAR |rhoHelp|) - 1) - (RETURN-FROM - |FFIELDC-;discreteLog;2SU;12| - (CONS 1 "failed"))) - (T - (SEQ - (LETT |rho| - (* (CDR |rhoHelp|) - |mult|) - |FFIELDC-;discreteLog;2SU;12|) - (SETQ |disclog| - (+ |disclog| - |rho|)) - (SETQ |mult| - (* |mult| |fac|)) - (EXIT - (SETQ |a| - (SPADCALL |a| - (SPADCALL - |logbase| - (- |rho|) - (|getShellEntry| - $ 58)) + (SPADCALL |b| (|getShellEntry| $ 19))))) + (SEQ (SPADCALL + "discreteLog: second argument not in cyclic group generated by first argument" + (|getShellEntry| $ 83)) + (EXIT (CONS 1 "failed")))) + (T (SEQ (LETT |faclist| + (SPADCALL + (SPADCALL |groupord| + (|getShellEntry| $ 87)) + (|getShellEntry| $ 89)) + |FFIELDC-;discreteLog;2SU;12|) + (LETT |a| |b| |FFIELDC-;discreteLog;2SU;12|) + (LETT |disclog| 0 |FFIELDC-;discreteLog;2SU;12|) + (LETT |mult| 1 |FFIELDC-;discreteLog;2SU;12|) + (LETT |exp| |groupord| + |FFIELDC-;discreteLog;2SU;12|) + (LET ((#0=#:G1493 |faclist|)) + (LOOP + (COND + ((ATOM #0#) (RETURN NIL)) + (T (LET ((|f| (CAR #0#))) + (SEQ (LETT |fac| (CAR |f|) + |FFIELDC-;discreteLog;2SU;12|) + (LETT |primroot| + (SPADCALL |logbase| + (TRUNCATE |groupord| |fac|) + (|getShellEntry| $ 58)) + |FFIELDC-;discreteLog;2SU;12|) + (EXIT + (LET + ((|t| 0) + (#1=#:G1494 (- (CDR |f|) 1))) + (LOOP + (COND + ((> |t| #1#) (RETURN NIL)) + (T + (SEQ + (SETQ |exp| + (TRUNCATE |exp| |fac|)) + (LETT |rhoHelp| + (SPADCALL |primroot| + (SPADCALL |a| |exp| + (|getShellEntry| $ 58)) + |fac| + (|getShellEntry| $ 91)) + |FFIELDC-;discreteLog;2SU;12|) + (EXIT + (COND + ((EQL (CAR |rhoHelp|) + 1) + (RETURN-FROM + |FFIELDC-;discreteLog;2SU;12| + (CONS 1 "failed"))) + (T + (SEQ + (LETT |rho| + (* (CDR |rhoHelp|) + |mult|) + |FFIELDC-;discreteLog;2SU;12|) + (SETQ |disclog| + (+ |disclog| |rho|)) + (SETQ |mult| + (* |mult| |fac|)) + (EXIT + (SETQ |a| + (SPADCALL |a| + (SPADCALL + |logbase| + (- |rho|) (|getShellEntry| - $ 77))))))))))) - (SETQ |t| (+ |t| 1))))))))) - (SETQ #0# (CDR #0#)))) - (EXIT (CONS 0 |disclog|))))))))))) + $ 58)) + (|getShellEntry| + $ 77))))))))))) + (SETQ |t| (+ |t| 1))))))))) + (SETQ #0# (CDR #0#)))) + (EXIT (CONS 0 |disclog|)))))))))) (DEFUN |FFIELDC-;squareFreePolynomial| (|f| $) (SPADCALL |f| (|getShellEntry| $ 96))) @@ -487,41 +458,37 @@ (DEFUN |FFIELDC-;factorSquareFreePolynomial| (|f| $) (PROG (|flist|) (RETURN - (SEQ (COND - ((SPADCALL |f| (|spadConstant| $ 99) - (|getShellEntry| $ 100)) - (|spadConstant| $ 101)) - (T (SEQ (LETT |flist| - (SPADCALL |f| T (|getShellEntry| $ 105)) - |FFIELDC-;factorSquareFreePolynomial|) - (EXIT (SPADCALL - (SPADCALL (CAR |flist|) - (|getShellEntry| $ 106)) - (LET ((#0=#:G1483 NIL) (#1=#:G1484 T) - (#2=#:G1495 (CDR |flist|))) - (LOOP + (COND + ((SPADCALL |f| (|spadConstant| $ 99) (|getShellEntry| $ 100)) + (|spadConstant| $ 101)) + (T (SEQ (LETT |flist| (SPADCALL |f| T (|getShellEntry| $ 105)) + |FFIELDC-;factorSquareFreePolynomial|) + (EXIT (SPADCALL + (SPADCALL (CAR |flist|) + (|getShellEntry| $ 106)) + (LET ((#0=#:G1483 NIL) (#1=#:G1484 T) + (#2=#:G1495 (CDR |flist|))) + (LOOP + (COND + ((ATOM #2#) + (RETURN (COND - ((ATOM #2#) - (RETURN - (COND - (#1# (|spadConstant| $ 109)) - (T #0#)))) - (T - (LET ((|u| (CAR #2#))) - (LET - ((#3=#:G1482 - (SPADCALL (CAR |u|) - (CDR |u|) - (|getShellEntry| $ 107)))) - (COND - (#1# (SETQ #0# #3#)) - (T - (SETQ #0# - (SPADCALL #0# #3# - (|getShellEntry| $ 108))))) - (SETQ #1# NIL))))) - (SETQ #2# (CDR #2#)))) - (|getShellEntry| $ 110)))))))))) + (#1# (|spadConstant| $ 109)) + (T #0#)))) + (T (LET ((|u| (CAR #2#))) + (LET + ((#3=#:G1482 + (SPADCALL (CAR |u|) (CDR |u|) + (|getShellEntry| $ 107)))) + (COND + (#1# (SETQ #0# #3#)) + (T + (SETQ #0# + (SPADCALL #0# #3# + (|getShellEntry| $ 108))))) + (SETQ #1# NIL))))) + (SETQ #2# (CDR #2#)))) + (|getShellEntry| $ 110))))))))) (DEFUN |FFIELDC-;gcdPolynomial;3Sup;16| (|f| |g| $) (SPADCALL |f| |g| (|getShellEntry| $ 112))) diff --git a/src/algebra/strap/GCDDOM-.lsp b/src/algebra/strap/GCDDOM-.lsp index b8e1a81d..46927a01 100644 --- a/src/algebra/strap/GCDDOM-.lsp +++ b/src/algebra/strap/GCDDOM-.lsp @@ -16,23 +16,20 @@ (DEFUN |GCDDOM-;lcm;3S;1| (|x| |y| $) (PROG (LCM) (RETURN - (SEQ (COND - ((OR (SPADCALL |y| (|spadConstant| $ 7) - (|getShellEntry| $ 9)) - (SPADCALL |x| (|spadConstant| $ 7) - (|getShellEntry| $ 9))) - (|spadConstant| $ 7)) - (T (SEQ (LETT LCM - (SPADCALL |y| - (SPADCALL |x| |y| - (|getShellEntry| $ 10)) - (|getShellEntry| $ 12)) - |GCDDOM-;lcm;3S;1|) - (EXIT (COND - ((ZEROP (CAR LCM)) - (SPADCALL |x| (CDR LCM) - (|getShellEntry| $ 13))) - (T (|error| "bad gcd in lcm computation"))))))))))) + (COND + ((OR (SPADCALL |y| (|spadConstant| $ 7) (|getShellEntry| $ 9)) + (SPADCALL |x| (|spadConstant| $ 7) (|getShellEntry| $ 9))) + (|spadConstant| $ 7)) + (T (SEQ (LETT LCM + (SPADCALL |y| + (SPADCALL |x| |y| (|getShellEntry| $ 10)) + (|getShellEntry| $ 12)) + |GCDDOM-;lcm;3S;1|) + (EXIT (COND + ((ZEROP (CAR LCM)) + (SPADCALL |x| (CDR LCM) + (|getShellEntry| $ 13))) + (T (|error| "bad gcd in lcm computation")))))))))) (DEFUN |GCDDOM-;lcm;LS;2| (|l| $) (SPADCALL (ELT $ 15) |l| (|spadConstant| $ 16) (|spadConstant| $ 7) @@ -45,38 +42,35 @@ (DEFUN |GCDDOM-;gcdPolynomial;3Sup;4| (|p1| |p2| $) (PROG (|c1| |c2| |e2| |e1| |p|) (RETURN - (SEQ (COND - ((SPADCALL |p1| (|getShellEntry| $ 24)) - (SPADCALL |p2| (|getShellEntry| $ 25))) - ((SPADCALL |p2| (|getShellEntry| $ 24)) - (SPADCALL |p1| (|getShellEntry| $ 25))) - (T (SEQ (LETT |c1| (SPADCALL |p1| (|getShellEntry| $ 26)) - |GCDDOM-;gcdPolynomial;3Sup;4|) - (LETT |c2| (SPADCALL |p2| (|getShellEntry| $ 26)) + (COND + ((SPADCALL |p1| (|getShellEntry| $ 24)) + (SPADCALL |p2| (|getShellEntry| $ 25))) + ((SPADCALL |p2| (|getShellEntry| $ 24)) + (SPADCALL |p1| (|getShellEntry| $ 25))) + (T (SEQ (LETT |c1| (SPADCALL |p1| (|getShellEntry| $ 26)) + |GCDDOM-;gcdPolynomial;3Sup;4|) + (LETT |c2| (SPADCALL |p2| (|getShellEntry| $ 26)) + |GCDDOM-;gcdPolynomial;3Sup;4|) + (SETQ |p1| + (LET ((#0=#:G1393 + (SPADCALL |p1| |c1| + (|getShellEntry| $ 27)))) + (|check-union| (ZEROP (CAR #0#)) + (|SparseUnivariatePolynomial| (SVREF $ 6)) + #0#) + (CDR #0#))) + (SETQ |p2| + (LET ((#0# (SPADCALL |p2| |c2| + (|getShellEntry| $ 27)))) + (|check-union| (ZEROP (CAR #0#)) + (|SparseUnivariatePolynomial| (SVREF $ 6)) + #0#) + (CDR #0#))) + (SEQ (LETT |e1| (SPADCALL |p1| (|getShellEntry| $ 29)) |GCDDOM-;gcdPolynomial;3Sup;4|) - (SETQ |p1| - (LET ((#0=#:G1393 - (SPADCALL |p1| |c1| - (|getShellEntry| $ 27)))) - (|check-union| (ZEROP (CAR #0#)) - (|SparseUnivariatePolynomial| - (SVREF $ 6)) - #0#) - (CDR #0#))) - (SETQ |p2| - (LET ((#0# (SPADCALL |p2| |c2| - (|getShellEntry| $ 27)))) - (|check-union| (ZEROP (CAR #0#)) - (|SparseUnivariatePolynomial| - (SVREF $ 6)) - #0#) - (CDR #0#))) - (SEQ (LETT |e1| - (SPADCALL |p1| (|getShellEntry| $ 29)) - |GCDDOM-;gcdPolynomial;3Sup;4|) - (EXIT (COND - ((PLUSP |e1|) - (SETQ |p1| + (EXIT (COND + ((PLUSP |e1|) + (SETQ |p1| (LET ((#0# (SPADCALL |p1| @@ -88,12 +82,11 @@ (SVREF $ 6)) #0#) (CDR #0#))))))) - (SEQ (LETT |e2| - (SPADCALL |p2| (|getShellEntry| $ 29)) - |GCDDOM-;gcdPolynomial;3Sup;4|) - (EXIT (COND - ((PLUSP |e2|) - (SETQ |p2| + (SEQ (LETT |e2| (SPADCALL |p2| (|getShellEntry| $ 29)) + |GCDDOM-;gcdPolynomial;3Sup;4|) + (EXIT (COND + ((PLUSP |e2|) + (SETQ |p2| (LET ((#0# (SPADCALL |p2| @@ -105,23 +98,21 @@ (SVREF $ 6)) #0#) (CDR #0#))))))) - (LETT |e1| (MIN |e1| |e2|) - |GCDDOM-;gcdPolynomial;3Sup;4|) - (SETQ |c1| - (SPADCALL |c1| |c2| (|getShellEntry| $ 10))) - (SETQ |p1| - (COND - ((OR (ZEROP (SPADCALL |p1| - (|getShellEntry| $ 37))) - (ZEROP (SPADCALL |p2| - (|getShellEntry| $ 37)))) - (SPADCALL |c1| 0 (|getShellEntry| $ 34))) - (T (SEQ (LETT |p| + (LETT |e1| (MIN |e1| |e2|) + |GCDDOM-;gcdPolynomial;3Sup;4|) + (SETQ |c1| (SPADCALL |c1| |c2| (|getShellEntry| $ 10))) + (SETQ |p1| + (COND + ((OR (ZEROP (SPADCALL |p1| + (|getShellEntry| $ 37))) + (ZEROP (SPADCALL |p2| + (|getShellEntry| $ 37)))) + (SPADCALL |c1| 0 (|getShellEntry| $ 34))) + (T (SEQ (LETT |p| (SPADCALL |p1| |p2| (|getShellEntry| $ 39)) |GCDDOM-;gcdPolynomial;3Sup;4|) - (EXIT - (COND + (EXIT (COND ((ZEROP (SPADCALL |p| (|getShellEntry| $ 37))) @@ -160,12 +151,12 @@ (|getShellEntry| $ 42)) (|getShellEntry| $ 41)) (|getShellEntry| $ 25))))))))))) - (EXIT (COND - ((ZEROP |e1|) |p1|) - (T (SPADCALL - (SPADCALL (|spadConstant| $ 16) - |e1| (|getShellEntry| $ 34)) - |p1| (|getShellEntry| $ 44)))))))))))) + (EXIT (COND + ((ZEROP |e1|) |p1|) + (T (SPADCALL + (SPADCALL (|spadConstant| $ 16) |e1| + (|getShellEntry| $ 34)) + |p1| (|getShellEntry| $ 44))))))))))) (DEFUN |GcdDomain&| (|#1|) (LET* ((|dv$1| (|devaluate| |#1|)) diff --git a/src/algebra/strap/ILIST.lsp b/src/algebra/strap/ILIST.lsp index 27411076..f374f71d 100644 --- a/src/algebra/strap/ILIST.lsp +++ b/src/algebra/strap/ILIST.lsp @@ -150,24 +150,24 @@ (DEFUN |ILIST;elt;$rest$;9| (|x| T1 $) (DECLARE (IGNORE $)) (CDR |x|)) (DEFUN |ILIST;setfirst!;$2S;10| (|x| |s| $) - (SEQ (COND - ((NULL |x|) (|error| "Cannot update an empty list")) - (T (SEQ (RPLACA |x| |s|) (EXIT |s|)))))) + (COND + ((NULL |x|) (|error| "Cannot update an empty list")) + (T (SEQ (RPLACA |x| |s|) (EXIT |s|))))) (DEFUN |ILIST;setelt;$first2S;11| (|x| T2 |s| $) - (SEQ (COND - ((NULL |x|) (|error| "Cannot update an empty list")) - (T (SEQ (RPLACA |x| |s|) (EXIT |s|)))))) + (COND + ((NULL |x|) (|error| "Cannot update an empty list")) + (T (SEQ (RPLACA |x| |s|) (EXIT |s|))))) (DEFUN |ILIST;setrest!;3$;12| (|x| |y| $) - (SEQ (COND - ((NULL |x|) (|error| "Cannot update an empty list")) - (T (SEQ (RPLACD |x| |y|) (EXIT (CDR |x|))))))) + (COND + ((NULL |x|) (|error| "Cannot update an empty list")) + (T (SEQ (RPLACD |x| |y|) (EXIT (CDR |x|)))))) (DEFUN |ILIST;setelt;$rest2$;13| (|x| T3 |y| $) - (SEQ (COND - ((NULL |x|) (|error| "Cannot update an empty list")) - (T (SEQ (RPLACD |x| |y|) (EXIT (CDR |x|))))))) + (COND + ((NULL |x|) (|error| "Cannot update an empty list")) + (T (SEQ (RPLACD |x| |y|) (EXIT (CDR |x|)))))) (DEFUN |ILIST;construct;L$;14| (|l| $) (DECLARE (IGNORE $)) |l|) @@ -252,21 +252,19 @@ (|getShellEntry| $ 45)))))))))))) (DEFUN |ILIST;=;2$B;22| (|x| |y| $) - (SEQ (COND - ((EQ |x| |y|) T) - (T (SEQ (LOOP - (COND - ((NOT (COND - ((NULL |x|) NIL) - (T (NOT (NULL |y|))))) - (RETURN NIL)) - (T (COND - ((SPADCALL (CAR |x|) (CAR |y|) - (|getShellEntry| $ 53)) - (RETURN-FROM |ILIST;=;2$B;22| NIL)) - (T (SEQ (SETQ |x| (CDR |x|)) - (EXIT (SETQ |y| (CDR |y|))))))))) - (EXIT (COND ((NULL |x|) (NULL |y|)) (T NIL)))))))) + (COND + ((EQ |x| |y|) T) + (T (SEQ (LOOP + (COND + ((NOT (COND ((NULL |x|) NIL) (T (NOT (NULL |y|))))) + (RETURN NIL)) + (T (COND + ((SPADCALL (CAR |x|) (CAR |y|) + (|getShellEntry| $ 53)) + (RETURN-FROM |ILIST;=;2$B;22| NIL)) + (T (SEQ (SETQ |x| (CDR |x|)) + (EXIT (SETQ |y| (CDR |y|))))))))) + (EXIT (COND ((NULL |x|) (NULL |y|)) (T NIL))))))) (DEFUN |ILIST;latex;$S;23| (|x| $) (LET ((|s| "\\left[")) @@ -296,18 +294,18 @@ (DEFUN |ILIST;concat!;3$;25| (|x| |y| $) (PROG (|z|) (RETURN - (SEQ (COND - ((NULL |x|) - (COND - ((NULL |y|) |x|) - (T (SEQ (PUSH (|SPADfirst| |y|) |x|) - (RPLACD |x| (CDR |y|)) (EXIT |x|))))) - (T (SEQ (LETT |z| |x| |ILIST;concat!;3$;25|) - (LOOP - (COND - ((NOT (NOT (NULL (CDR |z|)))) (RETURN NIL)) - (T (SETQ |z| (CDR |z|))))) - (RPLACD |z| |y|) (EXIT |x|)))))))) + (COND + ((NULL |x|) + (COND + ((NULL |y|) |x|) + (T (SEQ (PUSH (|SPADfirst| |y|) |x|) (RPLACD |x| (CDR |y|)) + (EXIT |x|))))) + (T (SEQ (LETT |z| |x| |ILIST;concat!;3$;25|) + (LOOP + (COND + ((NOT (NOT (NULL (CDR |z|)))) (RETURN NIL)) + (T (SETQ |z| (CDR |z|))))) + (RPLACD |z| |y|) (EXIT |x|))))))) (DEFUN |ILIST;removeDuplicates!;2$;26| (|l| $) (PROG (|pp| |f| |pr|) @@ -343,53 +341,47 @@ (DEFUN |ILIST;merge!;M3$;28| (|f| |p| |q| $) (PROG (|r| |t|) (RETURN - (SEQ (COND - ((NULL |p|) |q|) - ((NULL |q|) |p|) - ((EQ |p| |q|) (|error| "cannot merge a list into itself")) - (T (SEQ (COND - ((SPADCALL (CAR |p|) (CAR |q|) |f|) - (SEQ (LETT |r| - (LETT |t| |p| |ILIST;merge!;M3$;28|) - |ILIST;merge!;M3$;28|) - (EXIT (SETQ |p| (CDR |p|))))) - (T (SEQ (LETT |r| - (LETT |t| |q| - |ILIST;merge!;M3$;28|) - |ILIST;merge!;M3$;28|) - (EXIT (SETQ |q| (CDR |q|)))))) - (LOOP - (COND - ((NOT (COND - ((NULL |p|) NIL) - (T (NOT (NULL |q|))))) - (RETURN NIL)) - (T (COND - ((SPADCALL (CAR |p|) (CAR |q|) |f|) - (SEQ (RPLACD |t| |p|) - (LETT |t| |p| - |ILIST;merge!;M3$;28|) - (EXIT (SETQ |p| (CDR |p|))))) - (T (SEQ (RPLACD |t| |q|) - (LETT |t| |q| - |ILIST;merge!;M3$;28|) - (EXIT (SETQ |q| (CDR |q|))))))))) - (RPLACD |t| (COND ((NULL |p|) |q|) (T |p|))) - (EXIT |r|)))))))) + (COND + ((NULL |p|) |q|) + ((NULL |q|) |p|) + ((EQ |p| |q|) (|error| "cannot merge a list into itself")) + (T (SEQ (COND + ((SPADCALL (CAR |p|) (CAR |q|) |f|) + (SEQ (LETT |r| (LETT |t| |p| |ILIST;merge!;M3$;28|) + |ILIST;merge!;M3$;28|) + (EXIT (SETQ |p| (CDR |p|))))) + (T (SEQ (LETT |r| + (LETT |t| |q| |ILIST;merge!;M3$;28|) + |ILIST;merge!;M3$;28|) + (EXIT (SETQ |q| (CDR |q|)))))) + (LOOP + (COND + ((NOT (COND ((NULL |p|) NIL) (T (NOT (NULL |q|))))) + (RETURN NIL)) + (T (COND + ((SPADCALL (CAR |p|) (CAR |q|) |f|) + (SEQ (RPLACD |t| |p|) + (LETT |t| |p| |ILIST;merge!;M3$;28|) + (EXIT (SETQ |p| (CDR |p|))))) + (T (SEQ (RPLACD |t| |q|) + (LETT |t| |q| |ILIST;merge!;M3$;28|) + (EXIT (SETQ |q| (CDR |q|))))))))) + (RPLACD |t| (COND ((NULL |p|) |q|) (T |p|))) + (EXIT |r|))))))) (DEFUN |ILIST;split!;$I$;29| (|p| |n| $) (PROG (|q|) (RETURN - (SEQ (COND - ((< |n| 1) (|error| "index out of range")) - (T (SEQ (SETQ |p| - (|ILIST;rest;$Nni$;19| |p| - (LET ((#0=#:G1485 (- |n| 1))) - (|check-subtype| (NOT (MINUSP #0#)) - '(|NonNegativeInteger|) #0#)) - $)) - (LETT |q| (CDR |p|) |ILIST;split!;$I$;29|) - (RPLACD |p| NIL) (EXIT |q|)))))))) + (COND + ((< |n| 1) (|error| "index out of range")) + (T (SEQ (SETQ |p| + (|ILIST;rest;$Nni$;19| |p| + (LET ((#0=#:G1485 (- |n| 1))) + (|check-subtype| (NOT (MINUSP #0#)) + '(|NonNegativeInteger|) #0#)) + $)) + (LETT |q| (CDR |p|) |ILIST;split!;$I$;29|) + (RPLACD |p| NIL) (EXIT |q|))))))) (DEFUN |ILIST;mergeSort| (|f| |p| |n| $) (PROG (|l| |q|) diff --git a/src/algebra/strap/INT.lsp b/src/algebra/strap/INT.lsp index 8e681337..eac82f8a 100644 --- a/src/algebra/strap/INT.lsp +++ b/src/algebra/strap/INT.lsp @@ -270,14 +270,14 @@ (PUT '|INT;unitCanonical;2$;55| '|SPADreplace| '|%iabs|) (DEFUN |INT;writeOMInt| (|dev| |x| $) - (SEQ (COND - ((MINUSP |x|) - (SEQ (SPADCALL |dev| (|getShellEntry| $ 10)) - (SPADCALL |dev| "arith1" "unary_minus" - (|getShellEntry| $ 12)) - (SPADCALL |dev| (- |x|) (|getShellEntry| $ 15)) - (EXIT (SPADCALL |dev| (|getShellEntry| $ 16))))) - (T (SPADCALL |dev| |x| (|getShellEntry| $ 15)))))) + (COND + ((MINUSP |x|) + (SEQ (SPADCALL |dev| (|getShellEntry| $ 10)) + (SPADCALL |dev| "arith1" "unary_minus" + (|getShellEntry| $ 12)) + (SPADCALL |dev| (- |x|) (|getShellEntry| $ 15)) + (EXIT (SPADCALL |dev| (|getShellEntry| $ 16))))) + (T (SPADCALL |dev| |x| (|getShellEntry| $ 15))))) (DEFUN |INT;OMwrite;$S;2| (|x| $) (LET* ((|s| "") (|sp| (OM-STRINGTOSTRINGPTR |s|)) diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp index 852c3da2..692f7a04 100644 --- a/src/algebra/strap/ISTRING.lsp +++ b/src/algebra/strap/ISTRING.lsp @@ -233,11 +233,11 @@ (EXIT |r|)))))) (DEFUN |ISTRING;setelt;$I2C;16| (|s| |i| |c| $) - (SEQ (COND - ((OR (< |i| (SVREF $ 6)) - (< (SPADCALL |s| (|getShellEntry| $ 47)) |i|)) - (|error| "index out of range")) - (T (SEQ (SETF (CHAR |s| (- |i| (SVREF $ 6))) |c|) (EXIT |c|)))))) + (COND + ((OR (< |i| (SVREF $ 6)) + (< (SPADCALL |s| (|getShellEntry| $ 47)) |i|)) + (|error| "index out of range")) + (T (SEQ (SETF (CHAR |s| (- |i| (SVREF $ 6))) |c|) (EXIT |c|))))) (DEFUN |ISTRING;substring?;2$IB;17| (|part| |whole| |startpos| $) (LET ((|np| (LENGTH |part|)) (|nw| (LENGTH |whole|))) diff --git a/src/algebra/strap/LSAGG-.lsp b/src/algebra/strap/LSAGG-.lsp index f0fa12ff..51633f6e 100644 --- a/src/algebra/strap/LSAGG-.lsp +++ b/src/algebra/strap/LSAGG-.lsp @@ -155,66 +155,55 @@ (DEFUN |LSAGG-;merge!;M3A;6| (|f| |p| |q| $) (PROG (|r| |t|) (RETURN - (SEQ (COND - ((SPADCALL |p| (|getShellEntry| $ 16)) |q|) - ((SPADCALL |q| (|getShellEntry| $ 16)) |p|) - ((SPADCALL |p| |q| (|getShellEntry| $ 30)) - (|error| "cannot merge a list into itself")) - (T (SEQ (COND - ((SPADCALL (SPADCALL |p| (|getShellEntry| $ 18)) - (SPADCALL |q| (|getShellEntry| $ 18)) - |f|) - (SEQ (LETT |r| - (LETT |t| |p| |LSAGG-;merge!;M3A;6|) - |LSAGG-;merge!;M3A;6|) - (EXIT (SETQ |p| + (COND + ((SPADCALL |p| (|getShellEntry| $ 16)) |q|) + ((SPADCALL |q| (|getShellEntry| $ 16)) |p|) + ((SPADCALL |p| |q| (|getShellEntry| $ 30)) + (|error| "cannot merge a list into itself")) + (T (SEQ (COND + ((SPADCALL (SPADCALL |p| (|getShellEntry| $ 18)) + (SPADCALL |q| (|getShellEntry| $ 18)) |f|) + (SEQ (LETT |r| (LETT |t| |p| |LSAGG-;merge!;M3A;6|) + |LSAGG-;merge!;M3A;6|) + (EXIT (SETQ |p| (SPADCALL |p| (|getShellEntry| $ 17)))))) - (T (SEQ (LETT |r| - (LETT |t| |q| - |LSAGG-;merge!;M3A;6|) - |LSAGG-;merge!;M3A;6|) - (EXIT (SETQ |q| + (T (SEQ (LETT |r| + (LETT |t| |q| |LSAGG-;merge!;M3A;6|) + |LSAGG-;merge!;M3A;6|) + (EXIT (SETQ |q| (SPADCALL |q| (|getShellEntry| $ 17))))))) - (LOOP - (COND - ((NOT (COND - ((SPADCALL |p| (|getShellEntry| $ 16)) - NIL) - (T (NOT - (SPADCALL |q| - (|getShellEntry| $ 16)))))) - (RETURN NIL)) - (T (COND - ((SPADCALL - (SPADCALL |p| - (|getShellEntry| $ 18)) - (SPADCALL |q| - (|getShellEntry| $ 18)) - |f|) - (SEQ (SPADCALL |t| |p| - (|getShellEntry| $ 27)) - (LETT |t| |p| - |LSAGG-;merge!;M3A;6|) - (EXIT - (SETQ |p| + (LOOP + (COND + ((NOT (COND + ((SPADCALL |p| (|getShellEntry| $ 16)) NIL) + (T (NOT (SPADCALL |q| + (|getShellEntry| $ 16)))))) + (RETURN NIL)) + (T (COND + ((SPADCALL + (SPADCALL |p| (|getShellEntry| $ 18)) + (SPADCALL |q| (|getShellEntry| $ 18)) + |f|) + (SEQ (SPADCALL |t| |p| + (|getShellEntry| $ 27)) + (LETT |t| |p| |LSAGG-;merge!;M3A;6|) + (EXIT (SETQ |p| (SPADCALL |p| (|getShellEntry| $ 17)))))) - (T (SEQ (SPADCALL |t| |q| - (|getShellEntry| $ 27)) - (LETT |t| |q| - |LSAGG-;merge!;M3A;6|) - (EXIT - (SETQ |q| + (T (SEQ (SPADCALL |t| |q| + (|getShellEntry| $ 27)) + (LETT |t| |q| |LSAGG-;merge!;M3A;6|) + (EXIT (SETQ |q| (SPADCALL |q| (|getShellEntry| $ 17)))))))))) - (SPADCALL |t| - (COND - ((SPADCALL |p| (|getShellEntry| $ 16)) |q|) - (T |p|)) - (|getShellEntry| $ 27)) - (EXIT |r|)))))))) + (SPADCALL |t| + (COND + ((SPADCALL |p| (|getShellEntry| $ 16)) |q|) + (T |p|)) + (|getShellEntry| $ 27)) + (EXIT |r|))))))) (DEFUN |LSAGG-;insert!;SAIA;7| (|s| |x| |i| $) (PROG (|y| |z|) @@ -424,30 +413,27 @@ (DEFUN |LSAGG-;sorted?;MAB;15| (|f| |l| $) (PROG (|p|) (RETURN - (SEQ (COND - ((SPADCALL |l| (|getShellEntry| $ 16)) T) - (T (SEQ (LETT |p| (SPADCALL |l| (|getShellEntry| $ 17)) - |LSAGG-;sorted?;MAB;15|) - (LOOP - (COND - ((NOT (NOT (SPADCALL |p| - (|getShellEntry| $ 16)))) - (RETURN NIL)) - (T (SEQ (COND - ((NOT - (SPADCALL - (SPADCALL |l| - (|getShellEntry| $ 18)) - (SPADCALL |p| - (|getShellEntry| $ 18)) - |f|)) - (RETURN-FROM - |LSAGG-;sorted?;MAB;15| - NIL))) - (EXIT (SETQ |p| + (COND + ((SPADCALL |l| (|getShellEntry| $ 16)) T) + (T (SEQ (LETT |p| (SPADCALL |l| (|getShellEntry| $ 17)) + |LSAGG-;sorted?;MAB;15|) + (LOOP + (COND + ((NOT (NOT (SPADCALL |p| (|getShellEntry| $ 16)))) + (RETURN NIL)) + (T (SEQ (COND + ((NOT (SPADCALL + (SPADCALL |l| + (|getShellEntry| $ 18)) + (SPADCALL |p| + (|getShellEntry| $ 18)) + |f|)) + (RETURN-FROM |LSAGG-;sorted?;MAB;15| + NIL))) + (EXIT (SETQ |p| (SPADCALL (SETQ |l| |p|) (|getShellEntry| $ 17)))))))) - (EXIT T)))))))) + (EXIT T))))))) (DEFUN |LSAGG-;reduce;MA2S;16| (|f| |x| |i| $) (LET ((|r| |i|)) @@ -514,30 +500,27 @@ (DEFUN |LSAGG-;reverse!;2A;20| (|x| $) (PROG (|z| |y|) (RETURN - (SEQ (COND - ((OR (SPADCALL |x| (|getShellEntry| $ 16)) - (SPADCALL - (LETT |y| (SPADCALL |x| (|getShellEntry| $ 17)) - |LSAGG-;reverse!;2A;20|) - (|getShellEntry| $ 16))) - |x|) - (T (SEQ (SPADCALL |x| (SPADCALL (|getShellEntry| $ 13)) - (|getShellEntry| $ 27)) - (LOOP - (COND - ((NOT (NOT (SPADCALL |y| - (|getShellEntry| $ 16)))) - (RETURN NIL)) - (T (SEQ (LETT |z| - (SPADCALL |y| - (|getShellEntry| $ 17)) - |LSAGG-;reverse!;2A;20|) - (SPADCALL |y| |x| - (|getShellEntry| $ 27)) - (SETQ |x| |y|) - (EXIT (LETT |y| |z| + (COND + ((OR (SPADCALL |x| (|getShellEntry| $ 16)) + (SPADCALL + (LETT |y| (SPADCALL |x| (|getShellEntry| $ 17)) + |LSAGG-;reverse!;2A;20|) + (|getShellEntry| $ 16))) + |x|) + (T (SEQ (SPADCALL |x| (SPADCALL (|getShellEntry| $ 13)) + (|getShellEntry| $ 27)) + (LOOP + (COND + ((NOT (NOT (SPADCALL |y| (|getShellEntry| $ 16)))) + (RETURN NIL)) + (T (SEQ (LETT |z| + (SPADCALL |y| (|getShellEntry| $ 17)) + |LSAGG-;reverse!;2A;20|) + (SPADCALL |y| |x| (|getShellEntry| $ 27)) + (SETQ |x| |y|) + (EXIT (LETT |y| |z| |LSAGG-;reverse!;2A;20|)))))) - (EXIT |x|)))))))) + (EXIT |x|))))))) (DEFUN |LSAGG-;copy;2A;21| (|x| $) (LET ((|y| (SPADCALL (|getShellEntry| $ 13)))) diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp index af6c2e66..e1e58863 100644 --- a/src/algebra/strap/OUTFORM.lsp +++ b/src/algebra/strap/OUTFORM.lsp @@ -944,19 +944,18 @@ (DEFUN |OUTFORM;differentiate;$Nni$;97| (|a| |nn| $) (PROG (|r| |s|) (RETURN - (SEQ (COND - ((ZEROP |nn|) |a|) - ((< |nn| 4) (|OUTFORM;prime;$Nni$;86| |a| |nn| $)) - (T (SEQ (LETT |r| - (SPADCALL - (|check-subtype| (PLUSP |nn|) - '(|PositiveInteger|) |nn|) - (|getShellEntry| $ 137)) - |OUTFORM;differentiate;$Nni$;97|) - (LETT |s| (SPADCALL |r| (|getShellEntry| $ 138)) - |OUTFORM;differentiate;$Nni$;97|) - (EXIT (|OUTFORM;super;3$;43| |a| (LIST 'PAREN |s|) - $))))))))) + (COND + ((ZEROP |nn|) |a|) + ((< |nn| 4) (|OUTFORM;prime;$Nni$;86| |a| |nn| $)) + (T (SEQ (LETT |r| + (SPADCALL + (|check-subtype| (PLUSP |nn|) + '(|PositiveInteger|) |nn|) + (|getShellEntry| $ 137)) + |OUTFORM;differentiate;$Nni$;97|) + (LETT |s| (SPADCALL |r| (|getShellEntry| $ 138)) + |OUTFORM;differentiate;$Nni$;97|) + (EXIT (|OUTFORM;super;3$;43| |a| (LIST 'PAREN |s|) $)))))))) (DEFUN |OUTFORM;sum;2$;98| (|a| $) (DECLARE (IGNORE $)) diff --git a/src/algebra/strap/POLYCAT-.lsp b/src/algebra/strap/POLYCAT-.lsp index a02ca0c4..0025e21f 100644 --- a/src/algebra/strap/POLYCAT-.lsp +++ b/src/algebra/strap/POLYCAT-.lsp @@ -144,55 +144,51 @@ (DEFUN |POLYCAT-;eval;SLS;1| (|p| |l| $) (PROG (|lvar|) (RETURN - (SEQ (COND - ((NULL |l|) |p|) - (T (SEQ (LET ((#0=#:G1666 |l|)) - (LOOP - (COND - ((ATOM #0#) (RETURN NIL)) - (T (LET ((|e| (CAR #0#))) - (COND - ((EQL - (CAR - (SPADCALL - (SPADCALL |e| - (|getShellEntry| $ 14)) - (|getShellEntry| $ 16))) - 1) - (RETURN - (|error| - "cannot find a variable to evaluate"))))))) - (SETQ #0# (CDR #0#)))) - (LETT |lvar| - (LET ((#1=#:G1668 |l|) (#2=#:G1667 NIL)) - (LOOP - (COND - ((ATOM #1#) (RETURN (NREVERSE #2#))) - (T (LET ((|e| (CAR #1#))) - (SETQ #2# + (COND + ((NULL |l|) |p|) + (T (SEQ (LET ((#0=#:G1666 |l|)) + (LOOP + (COND + ((ATOM #0#) (RETURN NIL)) + (T (LET ((|e| (CAR #0#))) + (COND + ((EQL (CAR + (SPADCALL + (SPADCALL |e| + (|getShellEntry| $ 14)) + (|getShellEntry| $ 16))) + 1) + (RETURN + (|error| "cannot find a variable to evaluate"))))))) + (SETQ #0# (CDR #0#)))) + (LETT |lvar| + (LET ((#1=#:G1668 |l|) (#2=#:G1667 NIL)) + (LOOP + (COND + ((ATOM #1#) (RETURN (NREVERSE #2#))) + (T (LET ((|e| (CAR #1#))) + (SETQ #2# (CONS (SPADCALL (SPADCALL |e| (|getShellEntry| $ 14)) (|getShellEntry| $ 17)) #2#))))) - (SETQ #1# (CDR #1#)))) - |POLYCAT-;eval;SLS;1|) - (EXIT (SPADCALL |p| |lvar| - (LET ((#3=#:G1670 |l|) (#4=#:G1669 NIL)) - (LOOP - (COND - ((ATOM #3#) - (RETURN (NREVERSE #4#))) - (T - (LET ((|e| (CAR #3#))) - (SETQ #4# - (CONS - (SPADCALL |e| - (|getShellEntry| $ 18)) - #4#))))) - (SETQ #3# (CDR #3#)))) - (|getShellEntry| $ 21)))))))))) + (SETQ #1# (CDR #1#)))) + |POLYCAT-;eval;SLS;1|) + (EXIT (SPADCALL |p| |lvar| + (LET ((#3=#:G1670 |l|) (#4=#:G1669 NIL)) + (LOOP + (COND + ((ATOM #3#) (RETURN (NREVERSE #4#))) + (T (LET ((|e| (CAR #3#))) + (SETQ #4# + (CONS + (SPADCALL |e| + (|getShellEntry| $ 18)) + #4#))))) + (SETQ #3# (CDR #3#)))) + (|getShellEntry| $ 21))))))))) (DEFUN |POLYCAT-;monomials;SL;2| (|p| $) (LET ((|ml| NIL)) @@ -220,19 +216,18 @@ (DEFUN |POLYCAT-;isTimes;SU;4| (|p| $) (PROG (|lv| |l| |r|) (RETURN - (SEQ (COND - ((OR (NULL (LETT |lv| - (SPADCALL |p| (|getShellEntry| $ 40)) - |POLYCAT-;isTimes;SU;4|)) - (NOT (SPADCALL |p| (|getShellEntry| $ 42)))) - (CONS 1 "failed")) - (T (SEQ (LETT |l| - (LET ((#0=#:G1672 |lv|) (#1=#:G1671 NIL)) - (LOOP - (COND - ((ATOM #0#) (RETURN (NREVERSE #1#))) - (T (LET ((|v| (CAR #0#))) - (SETQ #1# + (COND + ((OR (NULL (LETT |lv| (SPADCALL |p| (|getShellEntry| $ 40)) + |POLYCAT-;isTimes;SU;4|)) + (NOT (SPADCALL |p| (|getShellEntry| $ 42)))) + (CONS 1 "failed")) + (T (SEQ (LETT |l| + (LET ((#0=#:G1672 |lv|) (#1=#:G1671 NIL)) + (LOOP + (COND + ((ATOM #0#) (RETURN (NREVERSE #1#))) + (T (LET ((|v| (CAR #0#))) + (SETQ #1# (CONS (SPADCALL (|spadConstant| $ 43) |v| @@ -240,23 +235,22 @@ (|getShellEntry| $ 46)) (|getShellEntry| $ 47)) #1#))))) - (SETQ #0# (CDR #0#)))) - |POLYCAT-;isTimes;SU;4|) - (EXIT (COND - ((SPADCALL - (LETT |r| - (SPADCALL |p| - (|getShellEntry| $ 48)) - |POLYCAT-;isTimes;SU;4|) - (|getShellEntry| $ 49)) - (COND - ((NULL (CDR |lv|)) (CONS 1 "failed")) - (T (CONS 0 |l|)))) - (T (CONS 0 - (CONS - (SPADCALL |r| + (SETQ #0# (CDR #0#)))) + |POLYCAT-;isTimes;SU;4|) + (EXIT (COND + ((SPADCALL + (LETT |r| + (SPADCALL |p| + (|getShellEntry| $ 48)) + |POLYCAT-;isTimes;SU;4|) + (|getShellEntry| $ 49)) + (COND + ((NULL (CDR |lv|)) (CONS 1 "failed")) + (T (CONS 0 |l|)))) + (T (CONS 0 + (CONS (SPADCALL |r| (|getShellEntry| $ 51)) - |l|)))))))))))) + |l|))))))))))) (DEFUN |POLYCAT-;isExpt;SU;5| (|p| $) (PROG (|d|) @@ -351,80 +345,79 @@ (DEFUN |POLYCAT-;totalDegree;SNni;13| (|p| $) (PROG (|u| |d|) (RETURN - (SEQ (COND - ((SPADCALL |p| (|getShellEntry| $ 78)) 0) - (T (SEQ (LETT |u| - (SPADCALL |p| - (LET ((#0=#:G1467 - (SPADCALL |p| - (|getShellEntry| $ 53)))) - (|check-union| (ZEROP (CAR #0#)) - (SVREF $ 9) #0#) - (CDR #0#)) - (|getShellEntry| $ 59)) - |POLYCAT-;totalDegree;SNni;13|) - (LETT |d| 0 |POLYCAT-;totalDegree;SNni;13|) - (LOOP - (COND - ((NOT (SPADCALL |u| (|spadConstant| $ 80) - (|getShellEntry| $ 81))) - (RETURN NIL)) - (T (SEQ (SETQ |d| - (MAX |d| - (+ + (COND + ((SPADCALL |p| (|getShellEntry| $ 78)) 0) + (T (SEQ (LETT |u| + (SPADCALL |p| + (LET ((#0=#:G1467 + (SPADCALL |p| + (|getShellEntry| $ 53)))) + (|check-union| (ZEROP (CAR #0#)) + (SVREF $ 9) #0#) + (CDR #0#)) + (|getShellEntry| $ 59)) + |POLYCAT-;totalDegree;SNni;13|) + (LETT |d| 0 |POLYCAT-;totalDegree;SNni;13|) + (LOOP + (COND + ((NOT (SPADCALL |u| (|spadConstant| $ 80) + (|getShellEntry| $ 81))) + (RETURN NIL)) + (T (SEQ (SETQ |d| + (MAX |d| + (+ + (SPADCALL |u| + (|getShellEntry| $ 82)) + (SPADCALL (SPADCALL |u| - (|getShellEntry| $ 82)) - (SPADCALL - (SPADCALL |u| - (|getShellEntry| $ 83)) - (|getShellEntry| $ 84))))) - (EXIT (SETQ |u| + (|getShellEntry| $ 83)) + (|getShellEntry| $ 84))))) + (EXIT (SETQ |u| (SPADCALL |u| (|getShellEntry| $ 87)))))))) - (EXIT |d|)))))))) + (EXIT |d|))))))) (DEFUN |POLYCAT-;totalDegree;SLNni;14| (|p| |lv| $) (PROG (|v| |u| |d| |w|) (RETURN - (SEQ (COND - ((SPADCALL |p| (|getShellEntry| $ 78)) 0) - (T (SEQ (LETT |u| - (SPADCALL |p| - (LETT |v| - (LET - ((#0=#:G1475 - (SPADCALL |p| - (|getShellEntry| $ 53)))) - (|check-union| (ZEROP (CAR #0#)) - (SVREF $ 9) #0#) - (CDR #0#)) - |POLYCAT-;totalDegree;SLNni;14|) - (|getShellEntry| $ 59)) - |POLYCAT-;totalDegree;SLNni;14|) - (LETT |d| 0 |POLYCAT-;totalDegree;SLNni;14|) - (LETT |w| 0 |POLYCAT-;totalDegree;SLNni;14|) - (COND - ((SPADCALL |v| |lv| (|getShellEntry| $ 89)) - (SETQ |w| 1))) - (LOOP - (COND - ((NOT (SPADCALL |u| (|spadConstant| $ 80) - (|getShellEntry| $ 81))) - (RETURN NIL)) - (T (SEQ (SETQ |d| - (MAX |d| - (+ - (* |w| - (SPADCALL |u| - (|getShellEntry| $ 82))) - (SPADCALL - (SPADCALL |u| - (|getShellEntry| $ 83)) - |lv| (|getShellEntry| $ 92))))) - (EXIT (SETQ |u| + (COND + ((SPADCALL |p| (|getShellEntry| $ 78)) 0) + (T (SEQ (LETT |u| + (SPADCALL |p| + (LETT |v| + (LET ((#0=#:G1475 + (SPADCALL |p| + (|getShellEntry| $ 53)))) + (|check-union| (ZEROP (CAR #0#)) + (SVREF $ 9) #0#) + (CDR #0#)) + |POLYCAT-;totalDegree;SLNni;14|) + (|getShellEntry| $ 59)) + |POLYCAT-;totalDegree;SLNni;14|) + (LETT |d| 0 |POLYCAT-;totalDegree;SLNni;14|) + (LETT |w| 0 |POLYCAT-;totalDegree;SLNni;14|) + (COND + ((SPADCALL |v| |lv| (|getShellEntry| $ 89)) + (SETQ |w| 1))) + (LOOP + (COND + ((NOT (SPADCALL |u| (|spadConstant| $ 80) + (|getShellEntry| $ 81))) + (RETURN NIL)) + (T (SEQ (SETQ |d| + (MAX |d| + (+ + (* |w| + (SPADCALL |u| + (|getShellEntry| $ 82))) + (SPADCALL + (SPADCALL |u| + (|getShellEntry| $ 83)) + |lv| (|getShellEntry| $ 92))))) + (EXIT (SETQ |u| (SPADCALL |u| (|getShellEntry| $ 87)))))))) - (EXIT |d|)))))))) + (EXIT |d|))))))) (DEFUN |POLYCAT-;resultant;2SVarSetS;15| (|p1| |p2| |mvar| $) (SPADCALL (SPADCALL |p1| |mvar| (|getShellEntry| $ 59)) @@ -900,93 +893,86 @@ (DEFUN |POLYCAT-;charthRootlv| (|p| |vars| |ch| $) (PROG (|v| |d| |ans| |dd| |cp| |ansx|) (RETURN - (SEQ (COND - ((NULL |vars|) - (SEQ (LETT |ans| - (SPADCALL - (SPADCALL |p| (|getShellEntry| $ 175)) - (|getShellEntry| $ 185)) - |POLYCAT-;charthRootlv|) - (EXIT (COND - ((EQL (CAR |ans|) 1) (CONS 1 "failed")) - (T (CONS 0 - (SPADCALL (CDR |ans|) - (|getShellEntry| $ 51)))))))) - (T (SEQ (LETT |v| (|SPADfirst| |vars|) - |POLYCAT-;charthRootlv|) - (SETQ |vars| (CDR |vars|)) - (LETT |d| - (SPADCALL |p| |v| (|getShellEntry| $ 46)) - |POLYCAT-;charthRootlv|) - (LETT |ans| (|spadConstant| $ 27) - |POLYCAT-;charthRootlv|) - (LOOP - (COND - ((NOT (PLUSP |d|)) (RETURN NIL)) - (T (SEQ (LETT |dd| - (SPADCALL |d| |ch| - (|getShellEntry| $ 173)) + (COND + ((NULL |vars|) + (SEQ (LETT |ans| + (SPADCALL (SPADCALL |p| (|getShellEntry| $ 175)) + (|getShellEntry| $ 185)) + |POLYCAT-;charthRootlv|) + (EXIT (COND + ((EQL (CAR |ans|) 1) (CONS 1 "failed")) + (T (CONS 0 + (SPADCALL (CDR |ans|) + (|getShellEntry| $ 51)))))))) + (T (SEQ (LETT |v| (|SPADfirst| |vars|) |POLYCAT-;charthRootlv|) + (SETQ |vars| (CDR |vars|)) + (LETT |d| (SPADCALL |p| |v| (|getShellEntry| $ 46)) + |POLYCAT-;charthRootlv|) + (LETT |ans| (|spadConstant| $ 27) + |POLYCAT-;charthRootlv|) + (LOOP + (COND + ((NOT (PLUSP |d|)) (RETURN NIL)) + (T (SEQ (LETT |dd| + (SPADCALL |d| |ch| + (|getShellEntry| $ 173)) + |POLYCAT-;charthRootlv|) + (EXIT (COND + ((EQL (CAR |dd|) 1) + (RETURN-FROM + |POLYCAT-;charthRootlv| + (CONS 1 "failed"))) + (T + (SEQ + (LETT |cp| + (SPADCALL |p| |v| |d| + (|getShellEntry| $ 188)) + |POLYCAT-;charthRootlv|) + (SETQ |p| + (SPADCALL |p| + (SPADCALL |cp| |v| |d| + (|getShellEntry| $ 47)) + (|getShellEntry| $ 189))) + (LETT |ansx| + (|POLYCAT-;charthRootlv| |cp| + |vars| |ch| $) |POLYCAT-;charthRootlv|) - (EXIT (COND - ((EQL (CAR |dd|) 1) + (EXIT + (COND + ((EQL (CAR |ansx|) 1) (RETURN-FROM |POLYCAT-;charthRootlv| (CONS 1 "failed"))) (T (SEQ - (LETT |cp| - (SPADCALL |p| |v| |d| - (|getShellEntry| $ 188)) - |POLYCAT-;charthRootlv|) - (SETQ |p| - (SPADCALL |p| - (SPADCALL |cp| |v| |d| - (|getShellEntry| $ 47)) - (|getShellEntry| $ 189))) - (LETT |ansx| - (|POLYCAT-;charthRootlv| - |cp| |vars| |ch| $) - |POLYCAT-;charthRootlv|) + (SETQ |d| + (SPADCALL |p| |v| + (|getShellEntry| $ 46))) (EXIT - (COND - ((EQL (CAR |ansx|) 1) - (RETURN-FROM - |POLYCAT-;charthRootlv| - (CONS 1 "failed"))) - (T - (SEQ - (SETQ |d| - (SPADCALL |p| |v| - (|getShellEntry| $ - 46))) - (EXIT - (SETQ |ans| - (SPADCALL |ans| - (SPADCALL - (CDR |ansx|) |v| - (LET - ((#0=#:G1615 - (CDR |dd|))) - (|check-subtype| - (NOT - (MINUSP #0#)) - '(|NonNegativeInteger|) - #0#)) - (|getShellEntry| $ - 47)) - (|getShellEntry| $ - 183)))))))))))))))) - (LETT |ansx| - (|POLYCAT-;charthRootlv| |p| |vars| |ch| $) - |POLYCAT-;charthRootlv|) - (EXIT (COND - ((EQL (CAR |ansx|) 1) - (RETURN-FROM |POLYCAT-;charthRootlv| - (CONS 1 "failed"))) - (T (RETURN-FROM |POLYCAT-;charthRootlv| - (CONS 0 - (SPADCALL |ans| (CDR |ansx|) - (|getShellEntry| $ 183)))))))))))))) + (SETQ |ans| + (SPADCALL |ans| + (SPADCALL (CDR |ansx|) + |v| + (LET + ((#0=#:G1615 + (CDR |dd|))) + (|check-subtype| + (NOT (MINUSP #0#)) + '(|NonNegativeInteger|) + #0#)) + (|getShellEntry| $ 47)) + (|getShellEntry| $ 183)))))))))))))))) + (LETT |ansx| + (|POLYCAT-;charthRootlv| |p| |vars| |ch| $) + |POLYCAT-;charthRootlv|) + (EXIT (COND + ((EQL (CAR |ansx|) 1) + (RETURN-FROM |POLYCAT-;charthRootlv| + (CONS 1 "failed"))) + (T (RETURN-FROM |POLYCAT-;charthRootlv| + (CONS 0 + (SPADCALL |ans| (CDR |ansx|) + (|getShellEntry| $ 183))))))))))))) (DEFUN |POLYCAT-;monicDivide;2SVarSetR;30| (|p1| |p2| |mvar| $) (LET ((|result| diff --git a/src/algebra/strap/RNS-.lsp b/src/algebra/strap/RNS-.lsp index 1a319cca..3989a430 100644 --- a/src/algebra/strap/RNS-.lsp +++ b/src/algebra/strap/RNS-.lsp @@ -102,23 +102,22 @@ (DEFUN |RNS-;patternMatch;SP2Pmr;10| (|x| |p| |l| $) (PROG (|r|) (RETURN - (SEQ (COND - ((SPADCALL |p| (|getShellEntry| $ 46)) - (SPADCALL |p| |x| |l| (|getShellEntry| $ 48))) - ((SPADCALL |p| (|getShellEntry| $ 49)) - (SEQ (LETT |r| (SPADCALL |p| (|getShellEntry| $ 51)) - |RNS-;patternMatch;SP2Pmr;10|) - (EXIT (COND - ((ZEROP (CAR |r|)) - (COND - ((SPADCALL - (SPADCALL |x| - (|getShellEntry| $ 33)) - (CDR |r|) (|getShellEntry| $ 52)) - |l|) - (T (SPADCALL (|getShellEntry| $ 53))))) - (T (SPADCALL (|getShellEntry| $ 53))))))) - (T (SPADCALL (|getShellEntry| $ 53)))))))) + (COND + ((SPADCALL |p| (|getShellEntry| $ 46)) + (SPADCALL |p| |x| |l| (|getShellEntry| $ 48))) + ((SPADCALL |p| (|getShellEntry| $ 49)) + (SEQ (LETT |r| (SPADCALL |p| (|getShellEntry| $ 51)) + |RNS-;patternMatch;SP2Pmr;10|) + (EXIT (COND + ((ZEROP (CAR |r|)) + (COND + ((SPADCALL + (SPADCALL |x| (|getShellEntry| $ 33)) + (CDR |r|) (|getShellEntry| $ 52)) + |l|) + (T (SPADCALL (|getShellEntry| $ 53))))) + (T (SPADCALL (|getShellEntry| $ 53))))))) + (T (SPADCALL (|getShellEntry| $ 53))))))) (DEFUN |RealNumberSystem&| (|#1|) (LET* ((|dv$1| (|devaluate| |#1|)) diff --git a/src/algebra/strap/SINT.lsp b/src/algebra/strap/SINT.lsp index 18b88fc4..5dd91da0 100644 --- a/src/algebra/strap/SINT.lsp +++ b/src/algebra/strap/SINT.lsp @@ -291,14 +291,13 @@ '(XLAM (|x|) (|%iadd| (|%isub| |x| |$ShortMinimum|) 1))) (DEFUN |SINT;writeOMSingleInt| (|dev| |x| $) - (SEQ (COND - ((MINUSP |x|) - (SEQ (SPADCALL |dev| (|getShellEntry| $ 11)) - (SPADCALL |dev| "arith1" "unaryminus" - (|getShellEntry| $ 13)) - (SPADCALL |dev| (- |x|) (|getShellEntry| $ 16)) - (EXIT (SPADCALL |dev| (|getShellEntry| $ 17))))) - (T (SPADCALL |dev| |x| (|getShellEntry| $ 16)))))) + (COND + ((MINUSP |x|) + (SEQ (SPADCALL |dev| (|getShellEntry| $ 11)) + (SPADCALL |dev| "arith1" "unaryminus" (|getShellEntry| $ 13)) + (SPADCALL |dev| (- |x|) (|getShellEntry| $ 16)) + (EXIT (SPADCALL |dev| (|getShellEntry| $ 17))))) + (T (SPADCALL |dev| |x| (|getShellEntry| $ 16))))) (DEFUN |SINT;OMwrite;$S;2| (|x| $) (LET* ((|s| "") (|sp| (OM-STRINGTOSTRINGPTR |s|)) diff --git a/src/algebra/strap/STAGG-.lsp b/src/algebra/strap/STAGG-.lsp index 60c28e58..b6b60077 100644 --- a/src/algebra/strap/STAGG-.lsp +++ b/src/algebra/strap/STAGG-.lsp @@ -219,11 +219,11 @@ (EXIT |s|)))))))))))) (DEFUN |STAGG-;concat!;3A;13| (|x| |y| $) - (SEQ (COND - ((SPADCALL |x| (|getShellEntry| $ 18)) |y|) - (T (SEQ (SPADCALL (SPADCALL |x| (|getShellEntry| $ 54)) |y| - (|getShellEntry| $ 55)) - (EXIT |x|)))))) + (COND + ((SPADCALL |x| (|getShellEntry| $ 18)) |y|) + (T (SEQ (SPADCALL (SPADCALL |x| (|getShellEntry| $ 54)) |y| + (|getShellEntry| $ 55)) + (EXIT |x|))))) (DEFUN |StreamAggregate&| (|#1| |#2|) (LET* ((|dv$1| (|devaluate| |#1|)) (|dv$2| (|devaluate| |#2|)) diff --git a/src/algebra/strap/SYMBOL.lsp b/src/algebra/strap/SYMBOL.lsp index add07b55..787305a0 100644 --- a/src/algebra/strap/SYMBOL.lsp +++ b/src/algebra/strap/SYMBOL.lsp @@ -473,133 +473,125 @@ (DEFUN |SYMBOL;name;2$;31| (|sy| $) (PROG (|str|) (RETURN - (SEQ (COND - ((NOT (|SYMBOL;scripted?;$B;30| |sy| $)) |sy|) - (T (SEQ (LETT |str| - (|SYMBOL;string;$S;24| - (SPADCALL (|SYMBOL;list;$L;34| |sy| $) - (|getShellEntry| $ 137)) - $) - |SYMBOL;name;2$;31|) - (LET ((|i| (+ (SVREF $ 41) 1)) - (#0=#:G1526 (LENGTH |str|))) - (LOOP - (COND - ((> |i| #0#) (RETURN NIL)) - (T (COND - ((NOT (SPADCALL - (SPADCALL |str| |i| - (|getShellEntry| $ 106)) - (|getShellEntry| $ 139))) - (RETURN-FROM |SYMBOL;name;2$;31| - (|SYMBOL;coerce;S$;8| - (SPADCALL |str| - (SPADCALL |i| (LENGTH |str|) - (|getShellEntry| $ 141)) - (|getShellEntry| $ 142)) - $)))))) - (SETQ |i| (+ |i| 1)))) - (EXIT (|error| "Improper scripted symbol"))))))))) + (COND + ((NOT (|SYMBOL;scripted?;$B;30| |sy| $)) |sy|) + (T (SEQ (LETT |str| + (|SYMBOL;string;$S;24| + (SPADCALL (|SYMBOL;list;$L;34| |sy| $) + (|getShellEntry| $ 137)) + $) + |SYMBOL;name;2$;31|) + (LET ((|i| (+ (SVREF $ 41) 1)) + (#0=#:G1526 (LENGTH |str|))) + (LOOP + (COND + ((> |i| #0#) (RETURN NIL)) + (T (COND + ((NOT (SPADCALL + (SPADCALL |str| |i| + (|getShellEntry| $ 106)) + (|getShellEntry| $ 139))) + (RETURN-FROM |SYMBOL;name;2$;31| + (|SYMBOL;coerce;S$;8| + (SPADCALL |str| + (SPADCALL |i| (LENGTH |str|) + (|getShellEntry| $ 141)) + (|getShellEntry| $ 142)) + $)))))) + (SETQ |i| (+ |i| 1)))) + (EXIT (|error| "Improper scripted symbol")))))))) (DEFUN |SYMBOL;scripts;$R;32| (|sy| $) (PROG (|nscripts| |lscripts| |str| |nstr| |m| |allscripts|) (RETURN - (SEQ (COND - ((NOT (|SYMBOL;scripted?;$B;30| |sy| $)) - (VECTOR NIL NIL NIL NIL NIL)) - (T (SEQ (LETT |nscripts| '(0 0 0 0 0) - |SYMBOL;scripts;$R;32|) - (LETT |lscripts| (LIST NIL NIL NIL NIL NIL) - |SYMBOL;scripts;$R;32|) - (LETT |str| - (|SYMBOL;string;$S;24| - (SPADCALL (|SYMBOL;list;$L;34| |sy| $) - (|getShellEntry| $ 137)) - $) - |SYMBOL;scripts;$R;32|) - (LETT |nstr| (LENGTH |str|) - |SYMBOL;scripts;$R;32|) - (LETT |m| - (SPADCALL |nscripts| - (|getShellEntry| $ 144)) - |SYMBOL;scripts;$R;32|) - (LET ((|i| |m|) (|j| (+ (SVREF $ 41) 1))) - (LOOP - (COND - ((OR (> |j| |nstr|) - (NOT (SPADCALL + (COND + ((NOT (|SYMBOL;scripted?;$B;30| |sy| $)) + (VECTOR NIL NIL NIL NIL NIL)) + (T (SEQ (LETT |nscripts| '(0 0 0 0 0) |SYMBOL;scripts;$R;32|) + (LETT |lscripts| (LIST NIL NIL NIL NIL NIL) + |SYMBOL;scripts;$R;32|) + (LETT |str| + (|SYMBOL;string;$S;24| + (SPADCALL (|SYMBOL;list;$L;34| |sy| $) + (|getShellEntry| $ 137)) + $) + |SYMBOL;scripts;$R;32|) + (LETT |nstr| (LENGTH |str|) |SYMBOL;scripts;$R;32|) + (LETT |m| (SPADCALL |nscripts| (|getShellEntry| $ 144)) + |SYMBOL;scripts;$R;32|) + (LET ((|i| |m|) (|j| (+ (SVREF $ 41) 1))) + (LOOP + (COND + ((OR (> |j| |nstr|) + (NOT (SPADCALL + (SPADCALL |str| |j| + (|getShellEntry| $ 106)) + (|getShellEntry| $ 139)))) + (RETURN NIL)) + (T (SPADCALL |nscripts| |i| + (LET ((#0=#:G1517 + (- + (SPADCALL (SPADCALL |str| |j| (|getShellEntry| $ 106)) - (|getShellEntry| $ 139)))) - (RETURN NIL)) - (T (SPADCALL |nscripts| |i| - (LET ((#0=#:G1517 - (- - (SPADCALL - (SPADCALL |str| |j| - (|getShellEntry| $ 106)) - (|getShellEntry| $ 44)) - (SVREF $ 45)))) - (|check-subtype| (NOT (MINUSP #0#)) - '(|NonNegativeInteger|) #0#)) - (|getShellEntry| $ 148)))) - (SETQ |i| (+ |i| 1)) - (SETQ |j| (+ |j| 1)))) - (SETQ |nscripts| - (SPADCALL (CDR |nscripts|) - (|SPADfirst| |nscripts|) - (|getShellEntry| $ 151))) - (LETT |allscripts| - (CDR (|SYMBOL;list;$L;34| |sy| $)) - |SYMBOL;scripts;$R;32|) - (SETQ |m| - (SPADCALL |lscripts| - (|getShellEntry| $ 153))) - (LET ((|i| |m|) (#1=#:G1527 |nscripts|)) - (LOOP - (COND - ((ATOM #1#) (RETURN NIL)) - (T (LET ((|n| (CAR #1#))) - (COND - ((< (LIST-LENGTH |allscripts|) |n|) - (|error| - "Improper script count in symbol")) - (T (SEQ - (SPADCALL |lscripts| |i| - (LET - ((#2=#:G1529 - (SPADCALL |allscripts| |n| - (|getShellEntry| $ 156))) - (#3=#:G1528 NIL)) - (LOOP - (COND - ((ATOM #2#) - (RETURN (NREVERSE #3#))) - (T - (LET ((|a| (CAR #2#))) - (SETQ #3# - (CONS - (|SYMBOL;coerce;$Of;11| - |a| $) - #3#))))) - (SETQ #2# (CDR #2#)))) - (|getShellEntry| $ 157)) - (EXIT - (SETQ |allscripts| - (SPADCALL |allscripts| |n| - (|getShellEntry| $ 158)))))))))) - (SETQ |i| (+ |i| 1)) - (SETQ #1# (CDR #1#)))) - (EXIT (VECTOR (SPADCALL |lscripts| |m| - (|getShellEntry| $ 159)) - (SPADCALL |lscripts| (+ |m| 1) - (|getShellEntry| $ 159)) - (SPADCALL |lscripts| (+ |m| 2) - (|getShellEntry| $ 159)) - (SPADCALL |lscripts| (+ |m| 3) - (|getShellEntry| $ 159)) - (SPADCALL |lscripts| (+ |m| 4) - (|getShellEntry| $ 159))))))))))) + (|getShellEntry| $ 44)) + (SVREF $ 45)))) + (|check-subtype| (NOT (MINUSP #0#)) + '(|NonNegativeInteger|) #0#)) + (|getShellEntry| $ 148)))) + (SETQ |i| (+ |i| 1)) + (SETQ |j| (+ |j| 1)))) + (SETQ |nscripts| + (SPADCALL (CDR |nscripts|) + (|SPADfirst| |nscripts|) + (|getShellEntry| $ 151))) + (LETT |allscripts| (CDR (|SYMBOL;list;$L;34| |sy| $)) + |SYMBOL;scripts;$R;32|) + (SETQ |m| + (SPADCALL |lscripts| (|getShellEntry| $ 153))) + (LET ((|i| |m|) (#1=#:G1527 |nscripts|)) + (LOOP + (COND + ((ATOM #1#) (RETURN NIL)) + (T (LET ((|n| (CAR #1#))) + (COND + ((< (LIST-LENGTH |allscripts|) |n|) + (|error| "Improper script count in symbol")) + (T (SEQ (SPADCALL |lscripts| |i| + (LET + ((#2=#:G1529 + (SPADCALL |allscripts| |n| + (|getShellEntry| $ 156))) + (#3=#:G1528 NIL)) + (LOOP + (COND + ((ATOM #2#) + (RETURN (NREVERSE #3#))) + (T + (LET ((|a| (CAR #2#))) + (SETQ #3# + (CONS + (|SYMBOL;coerce;$Of;11| + |a| $) + #3#))))) + (SETQ #2# (CDR #2#)))) + (|getShellEntry| $ 157)) + (EXIT + (SETQ |allscripts| + (SPADCALL |allscripts| |n| + (|getShellEntry| $ 158)))))))))) + (SETQ |i| (+ |i| 1)) + (SETQ #1# (CDR #1#)))) + (EXIT (VECTOR (SPADCALL |lscripts| |m| + (|getShellEntry| $ 159)) + (SPADCALL |lscripts| (+ |m| 1) + (|getShellEntry| $ 159)) + (SPADCALL |lscripts| (+ |m| 2) + (|getShellEntry| $ 159)) + (SPADCALL |lscripts| (+ |m| 3) + (|getShellEntry| $ 159)) + (SPADCALL |lscripts| (+ |m| 4) + (|getShellEntry| $ 159)))))))))) (DEFUN |SYMBOL;istring| (|n| $) (COND diff --git a/src/algebra/strap/URAGG-.lsp b/src/algebra/strap/URAGG-.lsp index 901b077d..7c1983a0 100644 --- a/src/algebra/strap/URAGG-.lsp +++ b/src/algebra/strap/URAGG-.lsp @@ -224,29 +224,26 @@ (DEFUN |URAGG-;tail;2A;16| (|x| $) (PROG (|y|) (RETURN - (SEQ (COND - ((SPADCALL |x| (|getShellEntry| $ 20)) - (|error| "empty list")) - (T (SEQ (LETT |y| (SPADCALL |x| (|getShellEntry| $ 14)) - |URAGG-;tail;2A;16|) - (LET ((|k| 0)) - (LOOP - (COND - ((NOT (NOT (SPADCALL |y| - (|getShellEntry| $ 20)))) - (RETURN NIL)) - (T (SEQ (COND - ((EQL |k| 1000) - (COND - ((SPADCALL |x| - (|getShellEntry| $ 48)) - (EXIT (|error| "cyclic list")))))) - (EXIT - (SETQ |y| + (COND + ((SPADCALL |x| (|getShellEntry| $ 20)) (|error| "empty list")) + (T (SEQ (LETT |y| (SPADCALL |x| (|getShellEntry| $ 14)) + |URAGG-;tail;2A;16|) + (LET ((|k| 0)) + (LOOP + (COND + ((NOT (NOT (SPADCALL |y| (|getShellEntry| $ 20)))) + (RETURN NIL)) + (T (SEQ (COND + ((EQL |k| 1000) + (COND + ((SPADCALL |x| + (|getShellEntry| $ 48)) + (EXIT (|error| "cyclic list")))))) + (EXIT (SETQ |y| (SPADCALL (SETQ |x| |y|) (|getShellEntry| $ 14))))))) - (SETQ |k| (+ |k| 1)))) - (EXIT |x|)))))))) + (SETQ |k| (+ |k| 1)))) + (EXIT |x|))))))) (DEFUN |URAGG-;findCycle| (|x| $) (LET ((|y| (SPADCALL |x| (|getShellEntry| $ 14)))) @@ -272,93 +269,86 @@ (DEFUN |URAGG-;cycleTail;2A;18| (|x| $) (PROG (|z| |y|) (RETURN - (SEQ (COND - ((SPADCALL - (LETT |y| - (SETQ |x| - (SPADCALL |x| (|getShellEntry| $ 55))) - |URAGG-;cycleTail;2A;18|) - (|getShellEntry| $ 20)) - |x|) - (T (SEQ (LETT |z| (SPADCALL |x| (|getShellEntry| $ 14)) - |URAGG-;cycleTail;2A;18|) - (LOOP - (COND - ((NOT (NOT (SPADCALL |x| |z| - (|getShellEntry| $ 54)))) - (RETURN NIL)) - (T (SEQ (LETT |y| |z| - |URAGG-;cycleTail;2A;18|) - (EXIT (SETQ |z| + (COND + ((SPADCALL + (LETT |y| (SETQ |x| (SPADCALL |x| (|getShellEntry| $ 55))) + |URAGG-;cycleTail;2A;18|) + (|getShellEntry| $ 20)) + |x|) + (T (SEQ (LETT |z| (SPADCALL |x| (|getShellEntry| $ 14)) + |URAGG-;cycleTail;2A;18|) + (LOOP + (COND + ((NOT (NOT (SPADCALL |x| |z| + (|getShellEntry| $ 54)))) + (RETURN NIL)) + (T (SEQ (LETT |y| |z| |URAGG-;cycleTail;2A;18|) + (EXIT (SETQ |z| (SPADCALL |z| (|getShellEntry| $ 14)))))))) - (EXIT |y|)))))))) + (EXIT |y|))))))) (DEFUN |URAGG-;cycleEntry;2A;19| (|x| $) (PROG (|z| |l| |y|) (RETURN - (SEQ (COND - ((SPADCALL |x| (|getShellEntry| $ 20)) |x|) - ((SPADCALL - (LETT |y| (|URAGG-;findCycle| |x| $) - |URAGG-;cycleEntry;2A;19|) - (|getShellEntry| $ 20)) - |y|) - (T (SEQ (LETT |z| (SPADCALL |y| (|getShellEntry| $ 14)) - |URAGG-;cycleEntry;2A;19|) - (LETT |l| 1 |URAGG-;cycleEntry;2A;19|) - (LOOP - (COND - ((NOT (NOT (SPADCALL |y| |z| - (|getShellEntry| $ 54)))) - (RETURN NIL)) - (T (SEQ (SETQ |z| - (SPADCALL |z| - (|getShellEntry| $ 14))) - (EXIT (SETQ |l| (+ |l| 1))))))) - (LETT |y| |x| |URAGG-;cycleEntry;2A;19|) - (LET ((|k| 1)) - (LOOP - (COND - ((> |k| |l|) (RETURN NIL)) - (T (SETQ |y| - (SPADCALL |y| - (|getShellEntry| $ 14))))) - (SETQ |k| (+ |k| 1)))) - (LOOP - (COND - ((NOT (NOT (SPADCALL |x| |y| - (|getShellEntry| $ 54)))) - (RETURN NIL)) - (T (SEQ (SETQ |x| - (SPADCALL |x| - (|getShellEntry| $ 14))) - (EXIT (SETQ |y| + (COND + ((SPADCALL |x| (|getShellEntry| $ 20)) |x|) + ((SPADCALL + (LETT |y| (|URAGG-;findCycle| |x| $) + |URAGG-;cycleEntry;2A;19|) + (|getShellEntry| $ 20)) + |y|) + (T (SEQ (LETT |z| (SPADCALL |y| (|getShellEntry| $ 14)) + |URAGG-;cycleEntry;2A;19|) + (LETT |l| 1 |URAGG-;cycleEntry;2A;19|) + (LOOP + (COND + ((NOT (NOT (SPADCALL |y| |z| + (|getShellEntry| $ 54)))) + (RETURN NIL)) + (T (SEQ (SETQ |z| + (SPADCALL |z| (|getShellEntry| $ 14))) + (EXIT (SETQ |l| (+ |l| 1))))))) + (LETT |y| |x| |URAGG-;cycleEntry;2A;19|) + (LET ((|k| 1)) + (LOOP + (COND + ((> |k| |l|) (RETURN NIL)) + (T (SETQ |y| + (SPADCALL |y| (|getShellEntry| $ 14))))) + (SETQ |k| (+ |k| 1)))) + (LOOP + (COND + ((NOT (NOT (SPADCALL |x| |y| + (|getShellEntry| $ 54)))) + (RETURN NIL)) + (T (SEQ (SETQ |x| + (SPADCALL |x| (|getShellEntry| $ 14))) + (EXIT (SETQ |y| (SPADCALL |y| (|getShellEntry| $ 14)))))))) - (EXIT |x|)))))))) + (EXIT |x|))))))) (DEFUN |URAGG-;cycleLength;ANni;20| (|x| $) (PROG (|y| |k|) (RETURN - (SEQ (COND - ((OR (SPADCALL |x| (|getShellEntry| $ 20)) - (SPADCALL (SETQ |x| (|URAGG-;findCycle| |x| $)) - (|getShellEntry| $ 20))) - 0) - (T (SEQ (LETT |y| (SPADCALL |x| (|getShellEntry| $ 14)) - |URAGG-;cycleLength;ANni;20|) - (LETT |k| 1 |URAGG-;cycleLength;ANni;20|) - (LOOP - (COND - ((NOT (NOT (SPADCALL |x| |y| - (|getShellEntry| $ 54)))) - (RETURN NIL)) - (T (SEQ (SETQ |y| - (SPADCALL |y| - (|getShellEntry| $ 14))) - (EXIT (SETQ |k| (+ |k| 1))))))) - (EXIT |k|)))))))) + (COND + ((OR (SPADCALL |x| (|getShellEntry| $ 20)) + (SPADCALL (SETQ |x| (|URAGG-;findCycle| |x| $)) + (|getShellEntry| $ 20))) + 0) + (T (SEQ (LETT |y| (SPADCALL |x| (|getShellEntry| $ 14)) + |URAGG-;cycleLength;ANni;20|) + (LETT |k| 1 |URAGG-;cycleLength;ANni;20|) + (LOOP + (COND + ((NOT (NOT (SPADCALL |x| |y| + (|getShellEntry| $ 54)))) + (RETURN NIL)) + (T (SEQ (SETQ |y| + (SPADCALL |y| (|getShellEntry| $ 14))) + (EXIT (SETQ |k| (+ |k| 1))))))) + (EXIT |k|))))))) (DEFUN |URAGG-;rest;ANniA;21| (|x| |n| $) (SEQ (LET ((|i| 1)) @@ -385,46 +375,41 @@ (|getShellEntry| $ 63)))))) (DEFUN |URAGG-;=;2AB;23| (|x| |y| $) - (SEQ (COND - ((SPADCALL |x| |y| (|getShellEntry| $ 54)) T) - (T (SEQ (LET ((|k| 0)) - (LOOP - (COND - ((NOT (COND - ((SPADCALL |x| (|getShellEntry| $ 20)) - NIL) - (T (NOT (SPADCALL |y| - (|getShellEntry| $ 20)))))) - (RETURN NIL)) - (T (SEQ (COND - ((EQL |k| 1000) - (COND - ((SPADCALL |x| - (|getShellEntry| $ 48)) - (EXIT (|error| "cyclic list")))))) - (EXIT (COND - ((SPADCALL - (SPADCALL |x| - (|getShellEntry| $ 8)) - (SPADCALL |y| - (|getShellEntry| $ 8)) - (|getShellEntry| $ 66)) - (RETURN-FROM |URAGG-;=;2AB;23| - NIL)) - (T - (SEQ - (SETQ |x| - (SPADCALL |x| - (|getShellEntry| $ 14))) - (EXIT - (SETQ |y| - (SPADCALL |y| - (|getShellEntry| $ 14))))))))))) - (SETQ |k| (+ |k| 1)))) - (EXIT (COND - ((SPADCALL |x| (|getShellEntry| $ 20)) - (SPADCALL |y| (|getShellEntry| $ 20))) - (T NIL)))))))) + (COND + ((SPADCALL |x| |y| (|getShellEntry| $ 54)) T) + (T (SEQ (LET ((|k| 0)) + (LOOP + (COND + ((NOT (COND + ((SPADCALL |x| (|getShellEntry| $ 20)) NIL) + (T (NOT (SPADCALL |y| (|getShellEntry| $ 20)))))) + (RETURN NIL)) + (T (SEQ (COND + ((EQL |k| 1000) + (COND + ((SPADCALL |x| (|getShellEntry| $ 48)) + (EXIT (|error| "cyclic list")))))) + (EXIT (COND + ((SPADCALL + (SPADCALL |x| + (|getShellEntry| $ 8)) + (SPADCALL |y| + (|getShellEntry| $ 8)) + (|getShellEntry| $ 66)) + (RETURN-FROM |URAGG-;=;2AB;23| NIL)) + (T (SEQ + (SETQ |x| + (SPADCALL |x| + (|getShellEntry| $ 14))) + (EXIT + (SETQ |y| + (SPADCALL |y| + (|getShellEntry| $ 14))))))))))) + (SETQ |k| (+ |k| 1)))) + (EXIT (COND + ((SPADCALL |x| (|getShellEntry| $ 20)) + (SPADCALL |y| (|getShellEntry| $ 20))) + (T NIL))))))) (DEFUN |URAGG-;node?;2AB;24| (|u| |v| $) (SEQ (LET ((|k| 0)) @@ -460,12 +445,12 @@ (|getShellEntry| $ 76))) (DEFUN |URAGG-;setlast!;A2S;29| (|x| |s| $) - (SEQ (COND - ((SPADCALL |x| (|getShellEntry| $ 20)) - (|error| "setlast: empty list")) - (T (SEQ (SPADCALL (SPADCALL |x| (|getShellEntry| $ 24)) |s| - (|getShellEntry| $ 70)) - (EXIT |s|)))))) + (COND + ((SPADCALL |x| (|getShellEntry| $ 20)) + (|error| "setlast: empty list")) + (T (SEQ (SPADCALL (SPADCALL |x| (|getShellEntry| $ 24)) |s| + (|getShellEntry| $ 70)) + (EXIT |s|))))) (DEFUN |URAGG-;setchildren!;ALA;30| (|u| |lv| $) (COND @@ -479,44 +464,44 @@ (DEFUN |URAGG-;split!;AIA;32| (|p| |n| $) (PROG (|q|) (RETURN - (SEQ (COND - ((< |n| 1) (|error| "index out of range")) - (T (SEQ (SETQ |p| - (SPADCALL |p| - (LET ((#0=#:G1503 (- |n| 1))) - (|check-subtype| (NOT (MINUSP #0#)) - '(|NonNegativeInteger|) #0#)) - (|getShellEntry| $ 62))) - (LETT |q| (SPADCALL |p| (|getShellEntry| $ 14)) - |URAGG-;split!;AIA;32|) - (SPADCALL |p| (SPADCALL (|getShellEntry| $ 84)) - (|getShellEntry| $ 74)) - (EXIT |q|)))))))) + (COND + ((< |n| 1) (|error| "index out of range")) + (T (SEQ (SETQ |p| + (SPADCALL |p| + (LET ((#0=#:G1503 (- |n| 1))) + (|check-subtype| (NOT (MINUSP #0#)) + '(|NonNegativeInteger|) #0#)) + (|getShellEntry| $ 62))) + (LETT |q| (SPADCALL |p| (|getShellEntry| $ 14)) + |URAGG-;split!;AIA;32|) + (SPADCALL |p| (SPADCALL (|getShellEntry| $ 84)) + (|getShellEntry| $ 74)) + (EXIT |q|))))))) (DEFUN |URAGG-;cycleSplit!;2A;33| (|x| $) (PROG (|y| |z|) (RETURN - (SEQ (COND - ((OR (SPADCALL - (LETT |y| (SPADCALL |x| (|getShellEntry| $ 55)) - |URAGG-;cycleSplit!;2A;33|) - (|getShellEntry| $ 20)) - (SPADCALL |x| |y| (|getShellEntry| $ 54))) - |y|) - (T (SEQ (LETT |z| (SPADCALL |x| (|getShellEntry| $ 14)) - |URAGG-;cycleSplit!;2A;33|) - (LOOP - (COND - ((NOT (NOT (SPADCALL |z| |y| - (|getShellEntry| $ 54)))) - (RETURN NIL)) - (T (SEQ (SETQ |x| |z|) - (EXIT (SETQ |z| + (COND + ((OR (SPADCALL + (LETT |y| (SPADCALL |x| (|getShellEntry| $ 55)) + |URAGG-;cycleSplit!;2A;33|) + (|getShellEntry| $ 20)) + (SPADCALL |x| |y| (|getShellEntry| $ 54))) + |y|) + (T (SEQ (LETT |z| (SPADCALL |x| (|getShellEntry| $ 14)) + |URAGG-;cycleSplit!;2A;33|) + (LOOP + (COND + ((NOT (NOT (SPADCALL |z| |y| + (|getShellEntry| $ 54)))) + (RETURN NIL)) + (T (SEQ (SETQ |x| |z|) + (EXIT (SETQ |z| (SPADCALL |z| (|getShellEntry| $ 14)))))))) - (SPADCALL |x| (SPADCALL (|getShellEntry| $ 84)) - (|getShellEntry| $ 74)) - (EXIT |y|)))))))) + (SPADCALL |x| (SPADCALL (|getShellEntry| $ 84)) + (|getShellEntry| $ 74)) + (EXIT |y|))))))) (DEFUN |UnaryRecursiveAggregate&| (|#1| |#2|) (LET* ((|dv$1| (|devaluate| |#1|)) (|dv$2| (|devaluate| |#2|)) -- cgit v1.2.3