From 5c81f5a89627a71d4e0054730eea47cc99a9cef2 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 23 Jun 2010 12:57:00 +0000 Subject: * interp/nruncomp.boot (optDeltaEntry): Don't optimize current domain modemap references here. * interp/g-opt.boot ($VMsideEffectFreeOperators): Include more floating point operators. ($simpleVMoperators): Move FUNCALL here. (isVMConstantForm): Tidy. * interp/g-util.boot: Expand more floating point insns. * interp/c-util.boot (replaceSimpleFunctions): Replace more constants. * algebra/integer.spad.pamphlet (Integer): More cleanup. Use builtin functions. * algebra/sf.spad.pamphlet: Likewise. --- src/ChangeLog | 15 ++ src/algebra/integer.spad.pamphlet | 25 +-- src/algebra/sf.spad.pamphlet | 60 ++++---- src/algebra/strap/ABELGRP-.lsp | 2 +- src/algebra/strap/CHAR.lsp | 2 +- src/algebra/strap/DFLOAT.lsp | 312 ++++++++++++++++++-------------------- src/algebra/strap/DIVRING-.lsp | 4 +- src/algebra/strap/FFIELDC-.lsp | 2 +- src/algebra/strap/FPS-.lsp | 2 +- src/algebra/strap/GCDDOM-.lsp | 4 +- src/algebra/strap/INT.lsp | 86 +++++------ src/algebra/strap/ISTRING.lsp | 43 +++--- src/algebra/strap/LNAGG-.lsp | 2 +- src/algebra/strap/NNI.lsp | 2 +- src/algebra/strap/OUTFORM.lsp | 10 +- src/algebra/strap/POLYCAT-.lsp | 2 +- src/algebra/strap/SINT.lsp | 16 +- src/algebra/strap/STAGG-.lsp | 8 +- src/algebra/strap/SYMBOL.lsp | 4 +- src/algebra/strap/URAGG-.lsp | 10 +- src/interp/c-util.boot | 4 +- src/interp/g-opt.boot | 15 +- src/interp/g-util.boot | 63 +++++++- src/interp/nruncomp.boot | 4 +- 24 files changed, 386 insertions(+), 311 deletions(-) diff --git a/src/ChangeLog b/src/ChangeLog index 209f8c98..b2dab14d 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,18 @@ +2010-06-23 Gabriel Dos Reis + + * interp/nruncomp.boot (optDeltaEntry): Don't optimize current + domain modemap references here. + * interp/g-opt.boot ($VMsideEffectFreeOperators): Include more + floating point operators. + ($simpleVMoperators): Move FUNCALL here. + (isVMConstantForm): Tidy. + * interp/g-util.boot: Expand more floating point insns. + * interp/c-util.boot (replaceSimpleFunctions): Replace more + constants. + * algebra/integer.spad.pamphlet (Integer): More cleanup. Use + builtin functions. + * algebra/sf.spad.pamphlet: Likewise. + 2010-06-22 Gabriel Dos Reis Group sequence of LETT definitions into LET/LET* expressions where diff --git a/src/algebra/integer.spad.pamphlet b/src/algebra/integer.spad.pamphlet index 2ca80be3..ffcb0206 100644 --- a/src/algebra/integer.spad.pamphlet +++ b/src/algebra/integer.spad.pamphlet @@ -82,6 +82,12 @@ Integer: Join(IntegerNumberSystem, ConvertibleTo String, OpenMath) with == add ZP ==> SparseUnivariatePolynomial % ZZP ==> SparseUnivariatePolynomial Integer + import %ineg: % -> % from Foreign Builtin + import %hash: % -> SingleInteger from Foreign Builtin + import %iadd: (%,%) -> % from Foreign Builtin + import %isub: (%,%) -> % from Foreign Builtin + import %imul: (%,%) -> % from Foreign Builtin + x,y: % n: NonNegativeInteger @@ -138,19 +144,19 @@ Integer: Join(IntegerNumberSystem, ConvertibleTo String, OpenMath) with copy x == x inc x == x + 1 dec x == x - 1 - hash x == SXHASH(x)$Lisp + hash x == %hash x negative? x == MINUSP(x)$Lisp coerce(x):OutputForm == outputForm(x pretend Integer) coerce(m:Integer):% == m pretend % convert(x:%):Integer == x pretend Integer length a == INTEGER_-LENGTH(a)$Lisp addmod(a, b, p) == - (c:=a + b) >= p => c - p + (c := %iadd(a,b)) >= p => c - p c submod(a, b, p) == - (c:=a - b) < 0 => c + p + (c := %isub(a,b)) < 0 => c + p c - mulmod(a, b, p) == (a * b) rem p + mulmod(a, b, p) == %imul(a,b) rem p convert(x:%):Float == coerce(x pretend Integer)$Float convert(x:%):DoubleFloat == coerce(x pretend Integer)$DoubleFloat convert(x:%):InputForm == convert(x pretend Integer)$InputForm @@ -182,12 +188,11 @@ Integer: Join(IntegerNumberSystem, ConvertibleTo String, OpenMath) with x > y == %igt(x,y)$Foreign(Builtin) x <= y == %ile(x,y)$Foreign(Builtin) x >= y == %ige(x,y)$Foreign(Builtin) - - x == (-x)$Lisp - x + y == %iadd(x,y)$Foreign(Builtin) - x - y == %isub(x,y)$Foreign(Builtin) - x * y == %imul(x,y)$Foreign(Builtin) - (m:Integer) * (y:%) == - %imul(m,y)$Foreign(Builtin) -- for subsumption problem + - x == %ineg x + x + y == %iadd(x,y) + x - y == %isub(x,y) + x * y == %imul(x,y) + (m:Integer) * (y:%) == %imul(m,y) -- for subsumption problem x ** n == %ipow(x,n)$Foreign(Builtin) odd? x == %iodd?(x)$Foreign(Builtin) max(x,y) == %imax(x,y)$Foreign(Builtin) diff --git a/src/algebra/sf.spad.pamphlet b/src/algebra/sf.spad.pamphlet index c1a29b22..1b36780f 100644 --- a/src/algebra/sf.spad.pamphlet +++ b/src/algebra/sf.spad.pamphlet @@ -279,17 +279,25 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, == add MER ==> Record(MANTISSA:Integer,EXPONENT:Integer) - import %fmul: (%,%) -> % from Foreign Builtin - import %fadd: (%,%) -> % from Foreign Builtin - import %fsub: (%,%) -> % from Foreign Builtin - import %fdiv: (%,%) -> % from Foreign Builtin - import %fmin: (%,%) -> % from Foreign Builtin - import %fmax: (%,%) -> % from Foreign Builtin - import %feq: (%,%) -> Boolean from Foreign Builtin - import %flt: (%,%) -> Boolean from Foreign Builtin - import %fle: (%,%) -> Boolean from Foreign Builtin - import %fgt: (%,%) -> Boolean from Foreign Builtin - import %fge: (%,%) -> Boolean from Foreign Builtin + import %fminval: () -> % from Foreign Builtin + import %fmaxval: () -> % from Foreign Builtin + import %fbase: () -> PositiveInteger from Foreign Builtin + import %fprec: () -> PositiveInteger from Foreign Builtin + import %i2f: Integer -> % from Foreign Builtin + import %fabs: % -> % from Foreign Builtin + import %fneg: % -> % from Foreign Builtin + import %ftrunc: % -> Integer from Foreign Builtin + import %fmul: (%,%) -> % from Foreign Builtin + import %fadd: (%,%) -> % from Foreign Builtin + import %fsub: (%,%) -> % from Foreign Builtin + import %fdiv: (%,%) -> % from Foreign Builtin + import %fmin: (%,%) -> % from Foreign Builtin + import %fmax: (%,%) -> % from Foreign Builtin + import %feq: (%,%) -> Boolean from Foreign Builtin + import %flt: (%,%) -> Boolean from Foreign Builtin + import %fle: (%,%) -> Boolean from Foreign Builtin + import %fgt: (%,%) -> Boolean from Foreign Builtin + import %fge: (%,%) -> Boolean from Foreign Builtin manexp: % -> MER @@ -334,21 +342,21 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, -- complex to get the correct behaviour. --makeComplex(x: %):% == COMPLEX(x, 0$%)$Lisp - base() == FLOAT_-RADIX(0$%)$Lisp + base() == %fbase() mantissa x == manexp(x).MANTISSA exponent x == manexp(x).EXPONENT - precision() == FLOAT_-DIGITS(0$%)$Lisp + precision() == %fprec() bits() == base() = 2 => precision() base() = 16 => 4*precision() - wholePart(precision()*log2(base()::%))::PositiveInteger - max() == _$DoubleFloatMaximum$Lisp - min() == _$DoubleFloatMinimum$Lisp + wholePart(precision() * log2 %i2f base())::PositiveInteger + max() == %fmaxval() + min() == %fminval() order(a) == precision() + exponent a - 1 - 0 == FLOAT(0$Lisp,_$DoubleFloatMaximum$Lisp)$Lisp - 1 == FLOAT(1$Lisp,_$DoubleFloatMaximum$Lisp)$Lisp + 0 == %i2f(0@Integer) + 1 == %i2f(1@Integer) -- rational approximation to e accurate to 23 digits - exp1() == FLOAT(534625820200,_$DoubleFloatMaximum$Lisp)$Lisp / FLOAT(196677847971,_$DoubleFloatMaximum$Lisp)$Lisp + exp1() == %i2f(534625820200) / %i2f(196677847971) pi() == PI$Lisp coerce(x:%):OutputForm == outputForm x convert(x:%):InputForm == convert(x pretend DoubleFloat)$InputForm @@ -356,7 +364,7 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, x > y == %fgt(x,y) x <= y == %fle(x,y) x >= y == %fge(x,y) - - x == (-x)$Lisp + - x == %fneg x x + y == %fadd(x,y) x:% - y:% == %fsub(x,y) x:% * y:% == %fmul(x,y) @@ -369,7 +377,7 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, log10 x == checkComplex log(x)$Lisp x:% ** i:Integer == EXPT(x,i)$Lisp x:% ** y:% == checkComplex EXPT(x,y)$Lisp - coerce(i:Integer):% == FLOAT(i,_$DoubleFloatMaximum$Lisp)$Lisp + coerce(i:Integer):% == %i2f i exp x == EXP(x)$Lisp log x == checkComplex LN(x)$Lisp log2 x == checkComplex LOG2(x)$Lisp @@ -411,8 +419,8 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, Gamma x == Gamma(sfx)$SFSFUN pretend % Beta(x,y) == Beta(sfx,sfy)$SFSFUN pretend % - wholePart x == FIX(x)$Lisp - float(ma,ex,b) == ma*(b::%)**ex + wholePart x == %ftrunc x + float(ma,ex,b) == ma * %i2f(b)**ex convert(x:%):DoubleFloat == x pretend DoubleFloat convert(x:%):Float == convert(x pretend DoubleFloat)$Float rationalApproximation(x, d) == rationalApproximation(x, d, 10) @@ -435,15 +443,15 @@ DoubleFloat(): Join(FloatingPointSystem, DifferentialRing, OpenMath, rationalApproximation(x, (precision() - 1)::NonNegativeInteger, base()) retract(x:%):Integer == - x = ((n := wholePart x)::%) => n + x = (%i2f(n := wholePart x)) => n error "Not an integer" retractIfCan(x:%):Union(Integer, "failed") == - x = ((n := wholePart x)::%) => n + x = (%i2f(n := wholePart x)) => n "failed" sign(x) == retract FLOAT_-SIGN(x,1)$Lisp - abs x == FLOAT_-SIGN(1,x)$Lisp + abs x == %fabs x diff --git a/src/algebra/strap/ABELGRP-.lsp b/src/algebra/strap/ABELGRP-.lsp index 65266dc4..47493f92 100644 --- a/src/algebra/strap/ABELGRP-.lsp +++ b/src/algebra/strap/ABELGRP-.lsp @@ -27,7 +27,7 @@ (DEFUN |ABELGRP-;*;I2S;4| (|n| |x| $) (COND ((ZEROP |n|) (|spadConstant| $ 19)) - ((> |n| 0) (SPADCALL |n| |x| (|getShellEntry| $ 24))) + ((< 0 |n|) (SPADCALL |n| |x| (|getShellEntry| $ 24))) ('T (SPADCALL (- |n|) (SPADCALL |x| (|getShellEntry| $ 7)) (|getShellEntry| $ 24))))) diff --git a/src/algebra/strap/CHAR.lsp b/src/algebra/strap/CHAR.lsp index 54208bca..f45315ba 100644 --- a/src/algebra/strap/CHAR.lsp +++ b/src/algebra/strap/CHAR.lsp @@ -129,7 +129,7 @@ (DEFUN |CHAR;lookup;$Pi;8| (|c| $) (LET ((#0=#:G1407 (+ 1 (CHAR-CODE |c|)))) - (|check-subtype| (> #0# 0) '(|PositiveInteger|) #0#))) + (|check-subtype| (< 0 #0#) '(|PositiveInteger|) #0#))) (DEFUN |CHAR;char;Nni$;9| (|n| $) (DECLARE (IGNORE $)) diff --git a/src/algebra/strap/DFLOAT.lsp b/src/algebra/strap/DFLOAT.lsp index 2d6c6a81..9828f0bc 100644 --- a/src/algebra/strap/DFLOAT.lsp +++ b/src/algebra/strap/DFLOAT.lsp @@ -23,7 +23,7 @@ (DECLAIM (FTYPE (FUNCTION (|%Shell|) (|%IntegerSection| 1)) |DFLOAT;base;Pi;6|)) -(PUT '|DFLOAT;base;Pi;6| '|SPADreplace| '(XLAM NIL (FLOAT-RADIX 0.0))) +(PUT '|DFLOAT;base;Pi;6| '|SPADreplace| '|%fbase|) (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%Integer|) |DFLOAT;mantissa;$I;7|)) @@ -34,21 +34,18 @@ (DECLAIM (FTYPE (FUNCTION (|%Shell|) (|%IntegerSection| 1)) |DFLOAT;precision;Pi;9|)) -(PUT '|DFLOAT;precision;Pi;9| '|SPADreplace| - '(XLAM NIL (FLOAT-DIGITS 0.0))) +(PUT '|DFLOAT;precision;Pi;9| '|SPADreplace| '|%fprec|) (DECLAIM (FTYPE (FUNCTION (|%Shell|) (|%IntegerSection| 1)) |DFLOAT;bits;Pi;10|)) (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%DoubleFloat|) |DFLOAT;max;$;11|)) -(PUT '|DFLOAT;max;$;11| '|SPADreplace| - '(XLAM NIL |$DoubleFloatMaximum|)) +(PUT '|DFLOAT;max;$;11| '|SPADreplace| '|%fmaxval|) (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%DoubleFloat|) |DFLOAT;min;$;12|)) -(PUT '|DFLOAT;min;$;12| '|SPADreplace| - '(XLAM NIL |$DoubleFloatMinimum|)) +(PUT '|DFLOAT;min;$;12| '|SPADreplace| '|%fminval|) (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%Integer|) |DFLOAT;order;$I;13|)) @@ -56,22 +53,15 @@ (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%DoubleFloat|) |DFLOAT;Zero;$;14|)) -(PUT '|DFLOAT;Zero;$;14| '|SPADreplace| - '(XLAM NIL (FLOAT 0 |$DoubleFloatMaximum|))) +(PUT '|DFLOAT;Zero;$;14| '|SPADreplace| '(XLAM NIL (|%i2f| 0))) (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%DoubleFloat|) |DFLOAT;One;$;15|)) -(PUT '|DFLOAT;One;$;15| '|SPADreplace| - '(XLAM NIL (FLOAT 1 |$DoubleFloatMaximum|))) +(PUT '|DFLOAT;One;$;15| '|SPADreplace| '(XLAM NIL (|%i2f| 1))) (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%DoubleFloat|) |DFLOAT;exp1;$;16|)) -(PUT '|DFLOAT;exp1;$;16| '|SPADreplace| - '(XLAM NIL - (|%fdiv| (FLOAT 534625820200 |$DoubleFloatMaximum|) - (FLOAT 196677847971 |$DoubleFloatMaximum|)))) - (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%DoubleFloat|) |DFLOAT;pi;$;17|)) (PUT '|DFLOAT;pi;$;17| '|SPADreplace| '(XLAM NIL PI)) @@ -109,7 +99,7 @@ (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%DoubleFloat|) |DFLOAT;-;2$;24|)) -(PUT '|DFLOAT;-;2$;24| '|SPADreplace| '-) +(PUT '|DFLOAT;-;2$;24| '|SPADreplace| '|%fneg|) (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%DoubleFloat| |%Shell|) |%DoubleFloat|) @@ -178,8 +168,7 @@ (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%DoubleFloat|) |DFLOAT;coerce;I$;37|)) -(PUT '|DFLOAT;coerce;I$;37| '|SPADreplace| - '(XLAM (|i|) (FLOAT |i| |$DoubleFloatMaximum|))) +(PUT '|DFLOAT;coerce;I$;37| '|SPADreplace| '|%i2f|) (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%DoubleFloat|) |DFLOAT;exp;2$;38|)) @@ -315,9 +304,6 @@ (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%Boolean|) |DFLOAT;one?;$B;68|)) -(PUT '|DFLOAT;one?;$B;68| '|SPADreplace| - '(XLAM (|x|) (|%feq| |x| 1.0))) - (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%Short|) |DFLOAT;hash;$Si;69|)) @@ -329,8 +315,6 @@ (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%DoubleFloat|) |DFLOAT;differentiate;2$;71|)) -(PUT '|DFLOAT;differentiate;2$;71| '|SPADreplace| '(XLAM (|x|) 0.0)) - (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%DoubleFloat|) |DFLOAT;Gamma;2$;72|)) @@ -341,7 +325,7 @@ (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%Integer|) |DFLOAT;wholePart;$I;74|)) -(PUT '|DFLOAT;wholePart;$I;74| '|SPADreplace| 'FIX) +(PUT '|DFLOAT;wholePart;$I;74| '|SPADreplace| '|%ftrunc|) (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Integer| (|%IntegerSection| 1) @@ -384,8 +368,7 @@ (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%DoubleFloat|) |DFLOAT;abs;2$;85|)) -(PUT '|DFLOAT;abs;2$;85| '|SPADreplace| - '(XLAM (|x|) (FLOAT-SIGN 1.0 |x|))) +(PUT '|DFLOAT;abs;2$;85| '|SPADreplace| '|%fabs|) (DECLAIM (FTYPE (FUNCTION (|%DoubleFloat| |%Shell|) |%Pair|) |DFLOAT;manexp|)) @@ -400,6 +383,15 @@ |%DoubleFloat|) |DFLOAT;**;$F$;88|)) +(PUT '|DFLOAT;exp1;$;16| '|SPADreplace| + '(XLAM NIL (|%fdiv| (|%i2f| 534625820200) (|%i2f| 196677847971)))) + +(PUT '|DFLOAT;one?;$B;68| '|SPADreplace| + '(XLAM (|x|) (|%feq| |x| (|%i2f| 1)))) + +(PUT '|DFLOAT;differentiate;2$;71| '|SPADreplace| + '(XLAM (|x|) (|%i2f| 0))) + (DEFUN |DFLOAT;OMwrite;$S;1| (|x| $) (LET* ((|s| "") (|sp| (OM-STRINGTOSTRINGPTR |s|)) (|dev| (SPADCALL |sp| (SPADCALL (|getShellEntry| $ 7)) @@ -435,29 +427,26 @@ (DECLARE (IGNORE $)) (C-TO-R |x|)) -(DEFUN |DFLOAT;base;Pi;6| ($) (DECLARE (IGNORE $)) (FLOAT-RADIX 0.0)) +(DEFUN |DFLOAT;base;Pi;6| ($) (DECLARE (IGNORE $)) 2) (DEFUN |DFLOAT;mantissa;$I;7| (|x| $) (CAR (|DFLOAT;manexp| |x| $))) (DEFUN |DFLOAT;exponent;$I;8| (|x| $) (CDR (|DFLOAT;manexp| |x| $))) -(DEFUN |DFLOAT;precision;Pi;9| ($) - (DECLARE (IGNORE $)) - (FLOAT-DIGITS 0.0)) +(DEFUN |DFLOAT;precision;Pi;9| ($) (DECLARE (IGNORE $)) 53) (DEFUN |DFLOAT;bits;Pi;10| ($) (COND - ((EQL (FLOAT-RADIX 0.0) 2) (FLOAT-DIGITS 0.0)) - ((EQL (FLOAT-RADIX 0.0) 16) (* 4 (FLOAT-DIGITS 0.0))) + ((EQL 2 2) 53) + ((EQL 2 16) (* 4 53)) ('T - (LET ((#0=#:G1425 - (FIX (SPADCALL (FLOAT-DIGITS 0.0) - (|DFLOAT;log2;2$;40| - (FLOAT (FLOAT-RADIX 0.0) - |$DoubleFloatMaximum|) - $) - (|getShellEntry| $ 34))))) - (|check-subtype| (AND (>= #0# 0) (> #0# 0)) '(|PositiveInteger|) + (LET ((#0=#:G1427 + (TRUNCATE + (SPADCALL 53 + (|DFLOAT;log2;2$;40| + (FLOAT 2 |$DoubleFloatMaximum|) $) + (|getShellEntry| $ 32))))) + (|check-subtype| (AND (>= #0# 0) (< 0 #0#)) '(|PositiveInteger|) #0#))))) (DEFUN |DFLOAT;max;$;11| ($) @@ -469,15 +458,11 @@ |$DoubleFloatMinimum|) (DEFUN |DFLOAT;order;$I;13| (|a| $) - (- (+ (FLOAT-DIGITS 0.0) (|DFLOAT;exponent;$I;8| |a| $)) 1)) + (- (+ 53 (|DFLOAT;exponent;$I;8| |a| $)) 1)) -(DEFUN |DFLOAT;Zero;$;14| ($) - (DECLARE (IGNORE $)) - (FLOAT 0 |$DoubleFloatMaximum|)) +(DEFUN |DFLOAT;Zero;$;14| ($) (DECLARE (IGNORE $)) 0.0) -(DEFUN |DFLOAT;One;$;15| ($) - (DECLARE (IGNORE $)) - (FLOAT 1 |$DoubleFloatMaximum|)) +(DEFUN |DFLOAT;One;$;15| ($) (DECLARE (IGNORE $)) 1.0) (DEFUN |DFLOAT;exp1;$;16| ($) (DECLARE (IGNORE $)) @@ -494,7 +479,7 @@ (DEFUN |DFLOAT;<;2$B;20| (|x| |y| $) (DECLARE (IGNORE $)) (< |x| |y|)) -(DEFUN |DFLOAT;>;2$B;21| (|x| |y| $) (DECLARE (IGNORE $)) (> |x| |y|)) +(DEFUN |DFLOAT;>;2$B;21| (|x| |y| $) (DECLARE (IGNORE $)) (< |y| |x|)) (DEFUN |DFLOAT;<=;2$B;22| (|x| |y| $) (DECLARE (IGNORE $)) @@ -619,7 +604,7 @@ (DEFUN |DFLOAT;wholePart;$I;74| (|x| $) (DECLARE (IGNORE $)) - (FIX |x|)) + (TRUNCATE |x|)) (DEFUN |DFLOAT;float;2IPi$;75| (|ma| |ex| |b| $) (* |ma| (EXPT (FLOAT |b| |$DoubleFloatMaximum|) |ex|))) @@ -638,47 +623,54 @@ (SEQ (COND ((= |x| 0.0) (COND - ((> |y| 0.0) (/ PI 2)) - ((< |y| 0.0) (- (/ PI 2))) + ((PLUSP |y|) (/ PI 2)) + ((MINUSP |y|) (- (/ PI 2))) ('T 0.0))) ('T - (SEQ (LETT |theta| (ATAN (FLOAT-SIGN 1.0 (/ |y| |x|))) + (SEQ (LETT |theta| (ATAN (ABS (/ |y| |x|))) |DFLOAT;atan;3$;79|) - (COND ((< |x| 0.0) (SETQ |theta| (- PI |theta|)))) - (COND ((< |y| 0.0) (SETQ |theta| (- |theta|)))) + (COND ((MINUSP |x|) (SETQ |theta| (- PI |theta|)))) + (COND ((MINUSP |y|) (SETQ |theta| (- |theta|)))) (EXIT |theta|)))))))) (DEFUN |DFLOAT;retract;$F;80| (|x| $) (|DFLOAT;rationalApproximation;$2NniF;87| |x| - (LET ((#0=#:G1504 (- (FLOAT-DIGITS 0.0) 1))) + (LET ((#0=#:G1506 (- 53 1))) (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) #0#)) - (FLOAT-RADIX 0.0) $)) + 2 $)) (DEFUN |DFLOAT;retractIfCan;$U;81| (|x| $) (CONS 0 (|DFLOAT;rationalApproximation;$2NniF;87| |x| - (LET ((#0=#:G1512 (- (FLOAT-DIGITS 0.0) 1))) + (LET ((#0=#:G1514 (- 53 1))) (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) #0#)) - (FLOAT-RADIX 0.0) $))) + 2 $))) (DEFUN |DFLOAT;retract;$I;82| (|x| $) - (LET ((|n| (FIX |x|))) - (COND - ((= |x| (FLOAT |n| |$DoubleFloatMaximum|)) |n|) - ('T (|error| "Not an integer"))))) + (PROG (|n|) + (RETURN + (COND + ((= |x| + (FLOAT (LETT |n| (TRUNCATE |x|) |DFLOAT;retract;$I;82|) + |$DoubleFloatMaximum|)) + |n|) + ('T (|error| "Not an integer")))))) (DEFUN |DFLOAT;retractIfCan;$U;83| (|x| $) - (LET ((|n| (FIX |x|))) - (COND - ((= |x| (FLOAT |n| |$DoubleFloatMaximum|)) (CONS 0 |n|)) - ('T (CONS 1 "failed"))))) + (PROG (|n|) + (RETURN + (COND + ((= |x| + (FLOAT (LETT |n| (TRUNCATE |x|) + |DFLOAT;retractIfCan;$U;83|) + |$DoubleFloatMaximum|)) + (CONS 0 |n|)) + ('T (CONS 1 "failed")))))) (DEFUN |DFLOAT;sign;$I;84| (|x| $) (|DFLOAT;retract;$I;82| (FLOAT-SIGN |x| 1.0) $)) -(DEFUN |DFLOAT;abs;2$;85| (|x| $) - (DECLARE (IGNORE $)) - (FLOAT-SIGN 1.0 |x|)) +(DEFUN |DFLOAT;abs;2$;85| (|x| $) (DECLARE (IGNORE $)) (ABS |x|)) (DEFUN |DFLOAT;manexp| (|x| $) (PROG (|s| |me| |two53|) @@ -688,9 +680,9 @@ ('T (SEQ (LETT |s| (|DFLOAT;sign;$I;84| |x| $) |DFLOAT;manexp|) - (SETQ |x| (FLOAT-SIGN 1.0 |x|)) + (SETQ |x| (ABS |x|)) (COND - ((> |x| |$DoubleFloatMaximum|) + ((< |$DoubleFloatMaximum| |x|) (RETURN-FROM |DFLOAT;manexp| (CONS (+ (* |s| (|DFLOAT;mantissa;$I;7| @@ -699,11 +691,10 @@ (|DFLOAT;exponent;$I;8| |$DoubleFloatMaximum| $))))) (LETT |me| (MANEXP |x|) |DFLOAT;manexp|) - (LETT |two53| - (EXPT (FLOAT-RADIX 0.0) (FLOAT-DIGITS 0.0)) - |DFLOAT;manexp|) - (EXIT (CONS (* |s| (FIX (* |two53| (CAR |me|)))) - (- (CDR |me|) (FLOAT-DIGITS 0.0))))))))))) + (LETT |two53| (EXPT 2 53) |DFLOAT;manexp|) + (EXIT (CONS (* |s| + (TRUNCATE (* |two53| (CAR |me|)))) + (- (CDR |me|) 53)))))))))) (DEFUN |DFLOAT;rationalApproximation;$2NniF;87| (|f| |d| |b| $) (PROG (BASE |de| |tol| |s| |t| |p0| |p1| |q0| |q1| |#G110| |q| |r| @@ -713,8 +704,7 @@ (LET* ((|#G109| (|DFLOAT;manexp| |f| $)) (|nu| (CAR |#G109|)) (|ex| (CDR |#G109|))) (SEQ |#G109| - (LETT BASE (FLOAT-RADIX 0.0) - |DFLOAT;rationalApproximation;$2NniF;87|) + (LETT BASE 2 |DFLOAT;rationalApproximation;$2NniF;87|) (EXIT (COND ((>= |ex| 0) (SPADCALL @@ -722,11 +712,11 @@ (EXPT BASE (|check-subtype| (>= |ex| 0) '(|NonNegativeInteger|) |ex|))) - (|getShellEntry| $ 135))) + (|getShellEntry| $ 134))) ('T (SEQ (LETT |de| (EXPT BASE - (LET ((#0=#:G1540 (- |ex|))) + (LET ((#0=#:G1542 (- |ex|))) (|check-subtype| (>= #0# 0) '(|NonNegativeInteger|) #0#))) |DFLOAT;rationalApproximation;$2NniF;87|) @@ -777,13 +767,13 @@ (- (* |nu| |q2|) (* |de| |p2|))) (|getShellEntry| $ - 144)) + 143)) (* |de| (ABS |p2|)))) (RETURN-FROM |DFLOAT;rationalApproximation;$2NniF;87| (SPADCALL |p2| |q2| (|getShellEntry| $ - 142))))) + 141))))) (LETT |#G111| |p1| |DFLOAT;rationalApproximation;$2NniF;87|) (LETT |#G112| |p2| @@ -811,20 +801,20 @@ (SEQ (COND ((ZEROP |x|) (COND - ((SPADCALL |r| (|getShellEntry| $ 146)) + ((SPADCALL |r| (|getShellEntry| $ 145)) (|error| "0**0 is undefined")) - ((SPADCALL |r| (|getShellEntry| $ 147)) + ((SPADCALL |r| (|getShellEntry| $ 146)) (|error| "division by 0")) ('T 0.0))) - ((OR (SPADCALL |r| (|getShellEntry| $ 146)) (= |x| 1.0)) + ((OR (SPADCALL |r| (|getShellEntry| $ 145)) (= |x| 1.0)) 1.0) ('T (COND - ((SPADCALL |r| (|getShellEntry| $ 148)) |x|) + ((SPADCALL |r| (|getShellEntry| $ 147)) |x|) ('T - (SEQ (LETT |n| (SPADCALL |r| (|getShellEntry| $ 149)) + (SEQ (LETT |n| (SPADCALL |r| (|getShellEntry| $ 148)) |DFLOAT;**;$F$;88|) - (LETT |d| (SPADCALL |r| (|getShellEntry| $ 150)) + (LETT |d| (SPADCALL |r| (|getShellEntry| $ 149)) |DFLOAT;**;$F$;88|) (EXIT (COND ((MINUSP |x|) @@ -851,7 +841,7 @@ (DEFUN |DoubleFloat| () (DECLARE (SPECIAL |$ConstructorCache|)) - (PROG (#0=#:G1562) + (PROG (#0=#:G1565) (RETURN (COND ((SETQ #0# (HGET |$ConstructorCache| '|DoubleFloat|)) @@ -883,25 +873,26 @@ (21 . |OMputEndObject|) (26 . |OMclose|) |DFLOAT;OMwrite;$S;1| (|Boolean|) |DFLOAT;OMwrite;$BS;2| |DFLOAT;OMwrite;Omd$V;3| |DFLOAT;OMwrite;Omd$BV;4| - (CONS IDENTITY - (FUNCALL (|dispatchFunction| |DFLOAT;Zero;$;14|) $)) (|PositiveInteger|) |DFLOAT;base;Pi;6| (|Integer|) |DFLOAT;mantissa;$I;7| |DFLOAT;exponent;$I;8| - |DFLOAT;precision;Pi;9| (31 . =) (37 . *) (43 . |coerce|) - |DFLOAT;log2;2$;40| (48 . *) |DFLOAT;wholePart;$I;74| + |DFLOAT;precision;Pi;9| (31 . =) (37 . *) + |DFLOAT;log2;2$;40| (43 . *) |DFLOAT;wholePart;$I;74| |DFLOAT;bits;Pi;10| |DFLOAT;max;$;11| |DFLOAT;min;$;12| - (54 . +) (60 . |One|) (64 . -) |DFLOAT;order;$I;13| + (49 . +) (55 . |One|) (59 . -) |DFLOAT;order;$I;13| + (65 . |Zero|) + (CONS IDENTITY + (FUNCALL (|dispatchFunction| |DFLOAT;Zero;$;14|) $)) (CONS IDENTITY (FUNCALL (|dispatchFunction| |DFLOAT;One;$;15|) $)) |DFLOAT;/;3$;65| |DFLOAT;exp1;$;16| |DFLOAT;pi;$;17| - (|OutputForm|) (70 . |outputForm|) |DFLOAT;coerce;$Of;18| - (|InputForm|) (75 . |convert|) |DFLOAT;convert;$If;19| + (|OutputForm|) (69 . |outputForm|) |DFLOAT;coerce;$Of;18| + (|InputForm|) (74 . |convert|) |DFLOAT;convert;$If;19| |DFLOAT;<;2$B;20| |DFLOAT;>;2$B;21| |DFLOAT;<=;2$B;22| |DFLOAT;>=;2$B;23| |DFLOAT;-;2$;24| |DFLOAT;+;3$;25| |DFLOAT;-;3$;26| |DFLOAT;*;3$;27| |DFLOAT;*;I2$;28| |DFLOAT;max;3$;29| |DFLOAT;min;3$;30| |DFLOAT;=;2$B;31| |DFLOAT;/;$I$;32| |DFLOAT;sqrt;2$;33| |DFLOAT;log10;2$;34| - |DFLOAT;**;$I$;35| |DFLOAT;**;3$;36| |DFLOAT;coerce;I$;37| + |DFLOAT;**;$I$;35| |DFLOAT;**;3$;36| (79 . |coerce|) |DFLOAT;exp;2$;38| |DFLOAT;log;2$;39| |DFLOAT;sin;2$;41| |DFLOAT;cos;2$;42| |DFLOAT;tan;2$;43| |DFLOAT;cot;2$;44| |DFLOAT;sec;2$;45| |DFLOAT;csc;2$;46| |DFLOAT;asin;2$;47| @@ -917,25 +908,24 @@ |DFLOAT;zero?;$B;67| |DFLOAT;one?;$B;68| (|SingleInteger|) |DFLOAT;hash;$Si;69| (|Union| $ '"failed") |DFLOAT;recip;$U;70| |DFLOAT;differentiate;2$;71| - (|DoubleFloatSpecialFunctions|) (80 . |Gamma|) - |DFLOAT;Gamma;2$;72| (85 . |Beta|) |DFLOAT;Beta;3$;73| - |DFLOAT;float;2IPi$;75| (|Float|) (91 . |convert|) - |DFLOAT;convert;$F;77| (|Fraction| 26) + (|DoubleFloatSpecialFunctions|) (84 . |Gamma|) + |DFLOAT;Gamma;2$;72| (89 . |Beta|) |DFLOAT;Beta;3$;73| + |DFLOAT;float;2IPi$;75| (|Float|) (95 . |convert|) + |DFLOAT;convert;$F;77| (|Fraction| 25) (|NonNegativeInteger|) |DFLOAT;rationalApproximation;$2NniF;87| - |DFLOAT;rationalApproximation;$NniF;78| (96 . |Zero|) - |DFLOAT;abs;2$;85| |DFLOAT;atan;3$;79| (100 . |One|) - |DFLOAT;retract;$F;80| (|Union| 114 '"failed") - |DFLOAT;retractIfCan;$U;81| |DFLOAT;retract;$I;82| - (|Union| 26 '"failed") |DFLOAT;retractIfCan;$U;83| - |DFLOAT;sign;$I;84| (104 . *) (110 . **) (116 . |Zero|) - (120 . |Zero|) (124 . >=) (130 . **) (136 . |coerce|) - (141 . -) (146 . <) (152 . **) + |DFLOAT;rationalApproximation;$NniF;78| |DFLOAT;abs;2$;85| + |DFLOAT;atan;3$;79| (100 . |One|) |DFLOAT;retract;$F;80| + (|Union| 114 '"failed") |DFLOAT;retractIfCan;$U;81| + |DFLOAT;retract;$I;82| (|Union| 25 '"failed") + |DFLOAT;retractIfCan;$U;83| |DFLOAT;sign;$I;84| (104 . *) + (110 . **) (116 . |Zero|) (120 . |Zero|) (124 . >=) + (130 . **) (136 . |coerce|) (141 . -) (146 . <) (152 . **) (|Record| (|:| |quotient| $) (|:| |remainder| $)) (158 . |divide|) (164 . =) (170 . /) (176 . |abs|) (181 . *) (187 . <) (193 . |zero?|) (198 . |negative?|) (203 . |one?|) (208 . |numer|) (213 . |denom|) - (218 . |odd?|) |DFLOAT;**;$F$;88| + (218 . |odd?|) |DFLOAT;**;$F$;88| |DFLOAT;coerce;I$;37| (|PatternMatchResult| 111 $) (|Pattern| 111) (|Factored| $) (|List| $) (|Union| 156 '"failed") (|Record| (|:| |coef1| $) (|:| |coef2| $) @@ -1028,11 +1018,11 @@ (|LeftLinearSet| $$) (|RightLinearSet| $$) (|AbelianSemiGroup|) (|SemiGroup|) - (|LeftLinearSet| 26) + (|LeftLinearSet| 25) (|TranscendentalFunctionCategory|) (|DifferentialDomain| $$) (|RetractableTo| 114) - (|RetractableTo| 26) (|RealConstant|) + (|RetractableTo| 25) (|RealConstant|) (|SetCategory|) (|ConvertibleTo| 50) (|ElementaryFunctionCategory|) (|ArcHyperbolicFunctionCategory|) @@ -1046,73 +1036,73 @@ (|ConvertibleTo| 13) (|CoercibleFrom| 114) (|CoercibleFrom| $$) - (|CoercibleFrom| 26) (|BasicType|) + (|CoercibleFrom| 25) (|BasicType|) (|CoercibleTo| 47)) (|makeByteWordVec2| 163 '(0 6 0 7 2 9 0 8 6 10 1 9 11 0 12 2 9 11 0 13 15 1 9 11 0 16 1 9 11 0 17 2 - 24 19 0 0 30 2 24 0 24 0 31 1 0 0 26 - 32 2 0 0 24 0 34 2 26 0 0 0 39 0 26 0 - 40 2 26 0 0 0 41 1 47 0 13 48 1 50 0 - 13 51 1 105 13 13 106 2 105 13 13 13 - 108 1 111 0 13 112 0 26 0 118 0 24 0 - 121 2 26 0 26 0 129 2 26 0 0 115 130 - 0 114 0 131 0 115 0 132 2 26 19 0 0 - 133 2 24 0 0 115 134 1 114 0 26 135 1 - 26 0 0 136 2 115 19 0 0 137 2 115 0 0 - 115 138 2 26 139 0 0 140 2 26 19 0 0 - 141 2 114 0 26 26 142 1 26 0 0 143 2 - 26 0 115 0 144 2 26 19 0 0 145 1 114 - 19 0 146 1 114 19 0 147 1 114 19 0 - 148 1 114 26 0 149 1 114 26 0 150 1 - 26 19 0 151 2 0 19 0 0 1 1 0 19 0 98 - 1 0 26 0 35 1 0 163 0 1 1 0 0 0 1 1 0 + 23 19 0 0 29 2 23 0 23 0 30 2 0 0 23 + 0 32 2 25 0 0 0 37 0 25 0 38 2 25 0 0 + 0 39 0 25 0 41 1 47 0 13 48 1 50 0 13 + 51 1 0 0 25 70 1 105 13 13 106 2 105 + 13 13 13 108 1 111 0 13 112 0 23 0 + 120 2 25 0 25 0 128 2 25 0 0 115 129 + 0 114 0 130 0 115 0 131 2 25 19 0 0 + 132 2 23 0 0 115 133 1 114 0 25 134 1 + 25 0 0 135 2 115 19 0 0 136 2 115 0 0 + 115 137 2 25 138 0 0 139 2 25 19 0 0 + 140 2 114 0 25 25 141 1 25 0 0 142 2 + 25 0 115 0 143 2 25 19 0 0 144 1 114 + 19 0 145 1 114 19 0 146 1 114 19 0 + 147 1 114 25 0 148 1 114 25 0 149 1 + 25 19 0 150 2 0 19 0 0 1 1 0 19 0 98 + 1 0 25 0 33 1 0 163 0 1 1 0 0 0 1 1 0 19 0 1 1 0 0 0 1 1 0 0 0 87 1 0 0 0 75 2 0 102 0 0 1 1 0 0 0 1 1 0 155 0 1 1 0 0 0 66 2 0 19 0 0 1 1 0 0 0 85 - 1 0 0 0 73 1 0 26 0 128 1 0 0 0 90 1 - 0 0 0 77 0 0 0 1 1 0 0 0 1 1 0 123 0 - 124 1 0 126 0 127 1 0 114 0 122 1 0 - 26 0 125 2 0 0 0 0 1 1 0 102 0 103 2 + 1 0 0 0 73 1 0 25 0 127 1 0 0 0 90 1 + 0 0 0 77 0 0 0 1 1 0 0 0 1 1 0 122 0 + 123 1 0 125 0 126 1 0 114 0 121 1 0 + 25 0 124 2 0 0 0 0 1 1 0 102 0 103 2 0 114 0 115 117 3 0 114 0 115 115 116 2 0 0 0 0 1 1 0 161 156 1 1 0 19 0 1 - 0 0 24 29 1 0 19 0 1 0 0 0 46 3 0 153 - 0 154 153 1 1 0 26 0 42 1 0 19 0 99 2 - 0 0 0 26 1 1 0 0 0 1 1 0 19 0 97 2 0 - 157 156 0 1 0 0 0 38 2 0 0 0 0 63 0 0 - 0 37 2 0 0 0 0 62 1 0 26 0 27 1 0 0 0 - 33 1 0 0 0 67 1 0 0 0 72 1 0 0 156 1 + 0 0 23 28 1 0 19 0 1 0 0 0 46 3 0 153 + 0 154 153 1 1 0 25 0 40 1 0 19 0 99 2 + 0 0 0 25 1 1 0 0 0 1 1 0 19 0 97 2 0 + 157 156 0 1 0 0 0 36 2 0 0 0 0 63 0 0 + 0 35 2 0 0 0 0 62 1 0 25 0 26 1 0 0 0 + 31 1 0 0 0 67 1 0 0 0 72 1 0 0 156 1 2 0 0 0 0 1 1 0 8 0 1 1 0 0 0 1 1 0 100 0 101 2 0 162 162 162 1 1 0 0 156 1 2 0 0 0 0 1 1 0 0 0 1 1 0 0 0 1 3 0 - 0 26 26 24 110 2 0 0 26 26 1 1 0 155 + 0 25 25 23 110 2 0 0 25 25 1 1 0 155 0 1 2 0 158 0 0 1 3 0 160 0 0 0 1 2 0 - 102 0 0 1 2 0 157 156 0 1 1 0 26 0 28 + 102 0 0 1 2 0 157 156 0 1 1 0 25 0 27 0 0 0 45 1 0 0 0 71 1 0 115 0 1 2 0 - 139 0 0 1 0 0 24 1 2 0 0 0 115 1 1 0 + 138 0 0 1 0 0 23 1 2 0 0 0 115 1 1 0 0 0 104 1 0 0 0 88 1 0 0 0 78 1 0 0 0 89 1 0 0 0 76 1 0 0 0 86 1 0 0 0 74 1 0 50 0 52 1 0 154 0 1 1 0 111 0 113 1 - 0 13 0 14 1 0 0 114 1 1 0 0 26 70 1 0 - 0 114 1 1 0 0 0 1 1 0 0 26 70 1 0 47 - 0 49 0 0 115 1 1 0 0 0 1 0 0 24 36 2 - 0 19 0 0 1 0 0 24 25 1 0 0 0 93 2 0 0 - 0 0 120 1 0 0 0 81 2 0 19 0 0 1 1 0 0 - 0 91 1 0 0 0 79 1 0 0 0 96 1 0 0 0 84 - 1 0 0 0 94 1 0 0 0 82 1 0 0 0 95 1 0 - 0 0 83 1 0 0 0 92 1 0 0 0 80 1 0 0 0 - 119 0 0 0 23 0 0 0 43 2 0 11 9 0 21 3 - 0 11 9 0 19 22 1 0 8 0 18 2 0 8 0 19 - 20 1 0 0 0 107 2 0 0 0 115 1 1 0 0 0 - 1 2 0 0 0 0 109 2 0 19 0 0 56 2 0 19 - 0 0 54 2 0 19 0 0 64 2 0 19 0 0 55 2 - 0 19 0 0 53 2 0 0 0 26 65 2 0 0 0 0 + 0 13 0 14 1 0 0 114 1 1 0 0 25 152 1 + 0 0 114 1 1 0 0 0 1 1 0 0 25 152 1 0 + 47 0 49 0 0 115 1 1 0 0 0 1 0 0 23 34 + 2 0 19 0 0 1 0 0 23 24 1 0 0 0 93 2 0 + 0 0 0 119 1 0 0 0 81 2 0 19 0 0 1 1 0 + 0 0 91 1 0 0 0 79 1 0 0 0 96 1 0 0 0 + 84 1 0 0 0 94 1 0 0 0 82 1 0 0 0 95 1 + 0 0 0 83 1 0 0 0 92 1 0 0 0 80 1 0 0 + 0 118 0 0 0 42 0 0 0 43 2 0 11 9 0 21 + 3 0 11 9 0 19 22 1 0 8 0 18 2 0 8 0 + 19 20 1 0 0 0 107 2 0 0 0 115 1 1 0 0 + 0 1 2 0 0 0 0 109 2 0 19 0 0 56 2 0 + 19 0 0 54 2 0 19 0 0 64 2 0 19 0 0 55 + 2 0 19 0 0 53 2 0 0 0 25 65 2 0 0 0 0 44 2 0 0 0 0 59 1 0 0 0 57 2 0 0 0 0 - 58 2 0 0 0 0 69 2 0 0 0 114 152 2 0 0 - 0 26 68 2 0 0 0 115 1 2 0 0 0 24 1 2 + 58 2 0 0 0 0 69 2 0 0 0 114 151 2 0 0 + 0 25 68 2 0 0 0 115 1 2 0 0 0 23 1 2 0 0 114 0 1 2 0 0 0 114 1 2 0 0 0 0 - 60 2 0 0 26 0 61 2 0 0 115 0 1 2 0 0 - 24 0 34))))) + 60 2 0 0 25 0 61 2 0 0 115 0 1 2 0 0 + 23 0 32))))) '|lookupComplete|)) (MAKEPROP '|DoubleFloat| 'NILADIC T) diff --git a/src/algebra/strap/DIVRING-.lsp b/src/algebra/strap/DIVRING-.lsp index 1f00bd68..af1162d4 100644 --- a/src/algebra/strap/DIVRING-.lsp +++ b/src/algebra/strap/DIVRING-.lsp @@ -11,8 +11,8 @@ (COND ((ZEROP |n|) (|spadConstant| $ 10)) ((SPADCALL |x| (|getShellEntry| $ 11)) - (COND ((< |n| 0) (|error| "division by zero")) ('T |x|))) - ((< |n| 0) + (COND ((MINUSP |n|) (|error| "division by zero")) ('T |x|))) + ((MINUSP |n|) (SPADCALL (SPADCALL |x| (|getShellEntry| $ 15)) (- |n|) (|getShellEntry| $ 19))) ('T (SPADCALL |x| |n| (|getShellEntry| $ 19))))) diff --git a/src/algebra/strap/FFIELDC-.lsp b/src/algebra/strap/FFIELDC-.lsp index 26185c00..9ad8712c 100644 --- a/src/algebra/strap/FFIELDC-.lsp +++ b/src/algebra/strap/FFIELDC-.lsp @@ -104,7 +104,7 @@ (T (SEQ (LETT |e| (SPADCALL (|check-subtype| - (AND (>= |i| 0) (> |i| 0)) + (AND (>= |i| 0) (< 0 |i|)) '(|PositiveInteger|) |i|) (|getShellEntry| $ 14)) |FFIELDC-;createPrimitiveElement;S;8|) diff --git a/src/algebra/strap/FPS-.lsp b/src/algebra/strap/FPS-.lsp index 50471189..562d295c 100644 --- a/src/algebra/strap/FPS-.lsp +++ b/src/algebra/strap/FPS-.lsp @@ -19,7 +19,7 @@ (- (SPADCALL (|getShellEntry| $ 14)) 1) (|getShellEntry| $ 16)) 13301)))) - (|check-subtype| (AND (>= #0# 0) (> #0# 0)) '(|PositiveInteger|) + (|check-subtype| (AND (>= #0# 0) (< 0 #0#)) '(|PositiveInteger|) #0#))) (DEFUN |FloatingPointSystem&| (|#1|) diff --git a/src/algebra/strap/GCDDOM-.lsp b/src/algebra/strap/GCDDOM-.lsp index 67277b94..92b58126 100644 --- a/src/algebra/strap/GCDDOM-.lsp +++ b/src/algebra/strap/GCDDOM-.lsp @@ -76,7 +76,7 @@ (SPADCALL |p1| (|getShellEntry| $ 29)) |GCDDOM-;gcdPolynomial;3Sup;4|) (EXIT (COND - ((> |e1| 0) + ((< 0 |e1|) (SETQ |p1| (LET ((#0# @@ -95,7 +95,7 @@ (SPADCALL |p2| (|getShellEntry| $ 29)) |GCDDOM-;gcdPolynomial;3Sup;4|) (EXIT (COND - ((> |e2| 0) + ((< 0 |e2|) (SETQ |p2| (LET ((#0# diff --git a/src/algebra/strap/INT.lsp b/src/algebra/strap/INT.lsp index 6ebab972..d7368a63 100644 --- a/src/algebra/strap/INT.lsp +++ b/src/algebra/strap/INT.lsp @@ -25,8 +25,6 @@ (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Boolean|) |INT;one?;$B;7|)) -(PUT '|INT;one?;$B;7| '|SPADreplace| '(XLAM (|x|) (|%ieq| |x| 1))) - (DECLAIM (FTYPE (FUNCTION (|%Shell|) |%Integer|) |INT;Zero;$;8|)) (PUT '|INT;Zero;$;8| '|SPADreplace| '(XLAM NIL 0)) @@ -47,17 +45,13 @@ (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Integer|) |INT;inc;2$;12|)) -(PUT '|INT;inc;2$;12| '|SPADreplace| '(XLAM (|x|) (|%iadd| |x| 1))) - (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Integer|) |INT;dec;2$;13|)) -(PUT '|INT;dec;2$;13| '|SPADreplace| '(XLAM (|x|) (|%isub| |x| 1))) - (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Short|) |INT;hash;$Si;14|)) -(PUT '|INT;hash;$Si;14| '|SPADreplace| 'SXHASH) +(PUT '|INT;hash;$Si;14| '|SPADreplace| '|%hash|) (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Boolean|) |INT;negative?;$B;15|)) @@ -100,8 +94,7 @@ (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%DoubleFloat|) |INT;convert;$Df;24|)) -(PUT '|INT;convert;$Df;24| '|SPADreplace| - '(XLAM (|x|) (FLOAT |x| |$DoubleFloatMaximum|))) +(PUT '|INT;convert;$Df;24| '|SPADreplace| '|%i2f|) (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Thing|) |INT;convert;$If;25|)) @@ -170,7 +163,7 @@ (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Integer|) |INT;-;2$;39|)) -(PUT '|INT;-;2$;39| '|SPADreplace| '-) +(PUT '|INT;-;2$;39| '|SPADreplace| '|%ineg|) (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Integer| |%Shell|) |%Integer|) |INT;+;3$;40|)) @@ -247,8 +240,6 @@ (DECLAIM (FTYPE (FUNCTION (|%Integer| |%Shell|) |%Integer|) |INT;unitCanonical;2$;55|)) -(PUT '|INT;unitCanonical;2$;55| '|SPADreplace| '|%iabs|) - (DECLAIM (FTYPE (FUNCTION (|%List| |%Thing| |%Shell|) |%Pair|) |INT;solveLinearPolynomialEquation|)) @@ -264,9 +255,18 @@ (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Shell|) |%Thing|) |INT;gcdPolynomial;3Sup;60|)) +(PUT '|INT;one?;$B;7| '|SPADreplace| '(XLAM (|x|) (|%ieq| |x| 1))) + +(PUT '|INT;inc;2$;12| '|SPADreplace| '(XLAM (|x|) (|%iadd| |x| 1))) + +(PUT '|INT;dec;2$;13| '|SPADreplace| '(XLAM (|x|) (|%isub| |x| 1))) + +(PUT '|INT;unitCanonical;2$;55| '|SPADreplace| + '(XLAM (|x|) (|%iabs| |x|))) + (DEFUN |INT;writeOMInt| (|dev| |x| $) (SEQ (COND - ((< |x| 0) + ((MINUSP |x|) (SEQ (SPADCALL |dev| (|getShellEntry| $ 13)) (SPADCALL |dev| "arith1" "unary_minus" (|getShellEntry| $ 15)) @@ -342,20 +342,20 @@ (LET ((|c| (+ |a| |b|))) (COND ((>= |c| |p|) (- |c| |p|)) ('T |c|)))) (DEFUN |INT;submod;4$;21| (|a| |b| |p| $) - (LET ((|c| (- |a| |b|))) (COND ((< |c| 0) (+ |c| |p|)) ('T |c|)))) + (LET ((|c| (- |a| |b|))) (COND ((MINUSP |c|) (+ |c| |p|)) ('T |c|)))) (DEFUN |INT;mulmod;4$;22| (|a| |b| |p| $) (REMAINDER2 (* |a| |b|) |p|)) (DEFUN |INT;convert;$F;23| (|x| $) - (SPADCALL |x| (|getShellEntry| $ 57))) + (SPADCALL |x| (|getShellEntry| $ 56))) (DEFUN |INT;convert;$Df;24| (|x| $) (DECLARE (IGNORE $)) (FLOAT |x| |$DoubleFloatMaximum|)) (DEFUN |INT;convert;$If;25| (|x| $) - (SPADCALL |x| (|getShellEntry| $ 63))) + (SPADCALL |x| (|getShellEntry| $ 62))) (DEFUN |INT;convert;$S;26| (|x| $) (DECLARE (IGNORE $)) @@ -391,7 +391,7 @@ (DEFUN |INT;<;2$B;35| (|x| |y| $) (DECLARE (IGNORE $)) (< |x| |y|)) -(DEFUN |INT;>;2$B;36| (|x| |y| $) (DECLARE (IGNORE $)) (> |x| |y|)) +(DEFUN |INT;>;2$B;36| (|x| |y| $) (DECLARE (IGNORE $)) (< |y| |x|)) (DEFUN |INT;<=;2$B;37| (|x| |y| $) (DECLARE (IGNORE $)) (<= |x| |y|)) @@ -441,7 +441,7 @@ (DEFUN |INT;gcd;3$;53| (|x| |y| $) (DECLARE (IGNORE $)) (GCD |x| |y|)) (DEFUN |INT;unitNormal;$R;54| (|x| $) - (COND ((< |x| 0) (VECTOR -1 (- |x|) -1)) ('T (VECTOR 1 |x| 1)))) + (COND ((MINUSP |x|) (VECTOR -1 (- |x|) -1)) ('T (VECTOR 1 |x| 1)))) (DEFUN |INT;unitCanonical;2$;55| (|x| $) (DECLARE (IGNORE $)) @@ -492,7 +492,7 @@ (DEFUN |Integer| () (DECLARE (SPECIAL |$ConstructorCache|)) - (PROG (#0=#:G1524) + (PROG (#0=#:G1525) (RETURN (COND ((SETQ #0# (HGET |$ConstructorCache| '|Integer|)) @@ -513,7 +513,7 @@ (|haddProp| |$ConstructorCache| '|Integer| NIL (CONS 1 $)) (|stuffDomainSlots| $) (|setShellEntry| $ 83 - (|setShellEntry| $ 53 + (|setShellEntry| $ 82 (CONS (|dispatchFunction| |INT;*;3$;43|) $))) $)) @@ -539,7 +539,7 @@ (|SingleInteger|) |INT;hash;$Si;14| |INT;negative?;$B;15| (|OutputForm|) (56 . |outputForm|) |INT;coerce;$Of;16| |INT;coerce;2$;17| |INT;convert;2$;18| |INT;length;2$;19| - |INT;>=;2$B;38| |INT;addmod;4$;20| |INT;submod;4$;21| NIL + |INT;>=;2$B;38| |INT;addmod;4$;20| |INT;submod;4$;21| |INT;rem;3$;50| |INT;mulmod;4$;22| (|Float|) (61 . |coerce|) |INT;convert;$F;23| (|DoubleFloat|) (66 . |coerce|) |INT;convert;$Df;24| (|InputForm|) @@ -547,10 +547,10 @@ |INT;convert;$S;26| (81 . <) (87 . |concat|) |INT;latex;$S;27| |INT;positiveRemainder;3$;28| (|Matrix| 17) (|Matrix| $) |INT;reducedSystem;2M;29| - (|Vector| 17) (|Record| (|:| |mat| 71) (|:| |vec| 74)) + (|Vector| 17) (|Record| (|:| |mat| 70) (|:| |vec| 73)) (|Vector| $) |INT;reducedSystem;MVR;30| |INT;abs;2$;31| |INT;random;$;32| |INT;random;2$;33| |INT;>;2$B;36| - |INT;<=;2$B;37| NIL |INT;**;$Nni$;44| |INT;odd?;$B;45| + |INT;<=;2$B;37| NIL NIL |INT;**;$Nni$;44| |INT;odd?;$B;45| |INT;max;3$;46| |INT;min;3$;47| (|Record| (|:| |quotient| $) (|:| |remainder| $)) |INT;divide;2$R;48| |INT;quo;3$;49| |INT;shift;3$;51| @@ -659,11 +659,11 @@ (|DifferentialDomain| $$) (|SetCategory|) (|OpenMath|) (|ConvertibleTo| 14) - (|ConvertibleTo| 56) - (|ConvertibleTo| 59) + (|ConvertibleTo| 55) + (|ConvertibleTo| 58) (|CombinatorialFunctionCategory|) (|ConvertibleTo| 131) - (|ConvertibleTo| 62) + (|ConvertibleTo| 61) (|ConvertibleTo| 17) (|Type|) (|CoercibleFrom| $$) (|CoercibleFrom| 17) (|BasicType|) @@ -673,9 +673,9 @@ 15 2 12 11 0 17 18 1 12 11 0 19 0 20 0 21 2 12 0 14 20 22 1 12 11 0 23 1 12 11 0 24 1 12 11 0 25 0 7 0 32 1 44 - 0 17 45 1 56 0 17 57 1 59 0 17 60 1 - 62 0 17 63 1 14 0 17 65 2 17 9 0 0 67 - 2 14 0 0 0 68 2 101 100 99 98 102 1 + 0 17 45 1 55 0 17 56 1 58 0 17 59 1 + 61 0 17 62 1 14 0 17 64 2 17 9 0 0 66 + 2 14 0 0 0 67 2 101 100 99 98 102 1 105 104 103 106 1 103 0 0 107 1 103 2 0 108 1 109 104 103 110 1 103 0 2 111 2 0 92 0 0 112 1 0 113 0 114 2 117 @@ -686,37 +686,37 @@ 9 0 1 2 0 0 0 0 1 2 0 92 0 0 1 3 0 0 0 0 0 52 1 0 0 0 1 1 0 113 0 1 2 0 9 0 0 1 1 0 17 0 1 2 0 0 0 0 91 0 0 0 1 - 1 0 133 0 1 1 0 17 0 1 2 0 0 0 0 54 2 - 0 75 76 0 1 1 0 71 76 1 1 0 71 72 73 - 2 0 75 72 76 77 1 0 92 0 93 1 0 130 0 - 1 1 0 9 0 1 1 0 129 0 1 0 0 0 79 1 0 - 0 0 80 2 0 0 0 0 90 1 0 135 134 1 1 0 - 9 0 1 3 0 0 0 0 0 1 2 0 0 0 0 70 1 0 + 1 0 133 0 1 1 0 17 0 1 2 0 0 0 0 53 2 + 0 74 75 0 1 1 0 70 75 1 1 0 70 71 72 + 2 0 74 71 75 76 1 0 92 0 93 1 0 130 0 + 1 1 0 9 0 1 1 0 129 0 1 0 0 0 78 1 0 + 0 0 79 2 0 0 0 0 90 1 0 135 134 1 1 0 + 9 0 1 3 0 0 0 0 0 1 2 0 0 0 0 69 1 0 9 0 1 2 0 0 0 0 1 3 0 132 0 131 132 1 1 0 9 0 34 1 0 9 0 85 1 0 92 0 1 1 0 - 9 0 43 2 0 136 134 0 1 3 0 0 0 0 0 55 + 9 0 43 2 0 136 134 0 1 3 0 0 0 0 0 54 2 0 0 0 0 87 2 0 0 0 0 86 1 0 0 0 1 1 0 0 0 49 2 0 0 0 0 1 1 0 0 134 1 1 0 - 14 0 69 2 0 0 0 0 1 0 0 0 1 1 0 0 0 + 14 0 68 2 0 0 0 0 1 0 0 0 1 1 0 0 0 38 1 0 41 0 42 2 0 127 127 127 128 2 0 0 0 0 94 1 0 0 134 1 1 0 0 0 1 1 0 113 0 114 2 0 137 0 0 1 3 0 139 0 0 0 1 2 0 92 0 0 112 2 0 136 134 0 1 1 0 9 0 1 1 0 7 0 1 2 0 88 0 0 89 2 0 0 0 7 1 1 0 0 0 1 1 0 0 0 40 1 0 0 0 36 1 - 0 14 0 66 1 0 59 0 61 1 0 56 0 58 1 0 - 131 0 1 1 0 62 0 64 1 0 17 0 48 1 0 0 + 0 14 0 65 1 0 58 0 60 1 0 55 0 57 1 0 + 131 0 1 1 0 61 0 63 1 0 17 0 48 1 0 0 17 47 1 0 0 0 1 1 0 0 17 47 1 0 44 0 46 0 0 7 1 2 0 9 0 0 1 2 0 0 0 0 1 2 0 9 0 0 1 0 0 0 35 2 0 9 0 0 1 3 0 0 - 0 0 0 51 1 0 0 0 78 0 0 0 6 0 0 0 31 + 0 0 0 51 1 0 0 0 77 0 0 0 6 0 0 0 31 3 0 11 12 0 9 29 2 0 14 0 9 27 2 0 11 12 0 28 1 0 14 0 26 2 0 0 0 7 1 1 0 0 - 0 1 2 0 9 0 0 50 2 0 9 0 0 81 2 0 9 0 - 0 33 2 0 9 0 0 82 2 0 9 0 0 10 1 0 0 + 0 1 2 0 9 0 0 50 2 0 9 0 0 80 2 0 9 0 + 0 33 2 0 9 0 0 81 2 0 9 0 0 10 1 0 0 0 16 2 0 0 0 0 39 2 0 0 0 0 37 2 0 0 0 7 84 2 0 0 0 140 1 2 0 0 17 0 83 2 - 0 0 0 0 53 2 0 0 17 0 83 2 0 0 7 0 1 + 0 0 0 0 82 2 0 0 17 0 83 2 0 0 7 0 1 2 0 0 140 0 1))))) '|lookupComplete|)) diff --git a/src/algebra/strap/ISTRING.lsp b/src/algebra/strap/ISTRING.lsp index 9340674d..b3224386 100644 --- a/src/algebra/strap/ISTRING.lsp +++ b/src/algebra/strap/ISTRING.lsp @@ -191,7 +191,7 @@ (- (SPADCALL |s| (|getShellEntry| $ 47)) (|getShellEntry| $ 6)))))) (SEQ (COND - ((OR (OR (< |l| 0) (>= |h| |m|)) (< |h| (- |l| 1))) + ((OR (OR (MINUSP |l|) (>= |h| |m|)) (< |h| (- |l| 1))) (EXIT (|error| "index out of range")))) (LETT |r| (MAKE-FULL-CVEC @@ -228,7 +228,7 @@ (DEFUN |ISTRING;setelt;$I2C;16| (|s| |i| |c| $) (SEQ (COND ((OR (< |i| (|getShellEntry| $ 6)) - (> |i| (SPADCALL |s| (|getShellEntry| $ 47)))) + (< (SPADCALL |s| (|getShellEntry| $ 47)) |i|)) (|error| "index out of range")) ('T (SEQ (QESET |s| (- |i| (|getShellEntry| $ 6)) |c|) @@ -238,8 +238,8 @@ (LET* ((|np| (QCSIZE |part|)) (|nw| (QCSIZE |whole|))) (SEQ (SETQ |startpos| (- |startpos| (|getShellEntry| $ 6))) (EXIT (COND - ((< |startpos| 0) (|error| "index out of bounds")) - ((> |np| (- |nw| |startpos|)) NIL) + ((MINUSP |startpos|) (|error| "index out of bounds")) + ((< (- |nw| |startpos|) |np|) NIL) ('T (SEQ (LET ((|ip| 0) (#0=#:G1538 (- |np| 1)) (|iw| |startpos|)) @@ -262,7 +262,8 @@ (RETURN (SEQ (SETQ |startpos| (- |startpos| (|getShellEntry| $ 6))) (EXIT (COND - ((< |startpos| 0) (|error| "index out of bounds")) + ((MINUSP |startpos|) + (|error| "index out of bounds")) ((>= |startpos| (QCSIZE |t|)) (- (|getShellEntry| $ 6) 1)) ('T @@ -276,7 +277,7 @@ (DEFUN |ISTRING;position;C$2I;19| (|c| |t| |startpos| $) (SEQ (SETQ |startpos| (- |startpos| (|getShellEntry| $ 6))) (EXIT (COND - ((< |startpos| 0) (|error| "index out of bounds")) + ((MINUSP |startpos|) (|error| "index out of bounds")) ((>= |startpos| (QCSIZE |t|)) (- (|getShellEntry| $ 6) 1)) ('T @@ -296,7 +297,7 @@ (DEFUN |ISTRING;position;Cc$2I;20| (|cc| |t| |startpos| $) (SEQ (SETQ |startpos| (- |startpos| (|getShellEntry| $ 6))) (EXIT (COND - ((< |startpos| 0) (|error| "index out of bounds")) + ((MINUSP |startpos|) (|error| "index out of bounds")) ((>= |startpos| (QCSIZE |t|)) (- (|getShellEntry| $ 6) 1)) ('T @@ -318,7 +319,7 @@ (LET* ((|m| (SPADCALL |s| (|getShellEntry| $ 47))) (|n| (SPADCALL |t| (|getShellEntry| $ 47)))) (COND - ((> |m| |n|) NIL) + ((< |n| |m|) NIL) ('T (|ISTRING;substring?;2$IB;17| |s| |t| (- (+ (|getShellEntry| $ 6) |n|) |m|) $))))) @@ -331,7 +332,7 @@ (SEQ (LOOP (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (SPADCALL (|ISTRING;elt;$IC;30| |s| |i| $) |c| (|getShellEntry| $ 69))))) @@ -341,7 +342,7 @@ (LOOP (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (>= (LETT |j| (|ISTRING;position;C$2I;19| |c| |s| @@ -361,7 +362,7 @@ (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (SPADCALL (|ISTRING;elt;$IC;30| |s| |i| @@ -370,7 +371,7 @@ (RETURN NIL)) (T (SETQ |i| (+ |i| 1)))))))))) (COND - ((NOT (> |i| |n|)) + ((NOT (< |n| |i|)) (SETQ |l| (SPADCALL (|ISTRING;elt;$Us$;31| |s| @@ -387,7 +388,7 @@ (SEQ (LOOP (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (SPADCALL (|ISTRING;elt;$IC;30| |s| |i| $) |cc| (|getShellEntry| $ 65))))) @@ -397,7 +398,7 @@ (LOOP (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (>= (LETT |j| (|ISTRING;position;Cc$2I;20| |cc| @@ -417,7 +418,7 @@ (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (SPADCALL (|ISTRING;elt;$IC;30| |s| |i| @@ -426,7 +427,7 @@ (RETURN NIL)) (T (SETQ |i| (+ |i| 1)))))))))) (COND - ((NOT (> |i| |n|)) + ((NOT (< |n| |i|)) (SETQ |l| (SPADCALL (|ISTRING;elt;$Us$;31| |s| @@ -441,7 +442,7 @@ (SEQ (LOOP (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (SPADCALL (|ISTRING;elt;$IC;30| |s| |i| $) |c| (|getShellEntry| $ 69))))) @@ -456,7 +457,7 @@ (SEQ (LOOP (COND ((NOT (COND - ((> |i| |n|) NIL) + ((< |n| |i|) NIL) ('T (SPADCALL (|ISTRING;elt;$IC;30| |s| |i| $) |cc| (|getShellEntry| $ 65))))) @@ -530,14 +531,14 @@ (|n| (QCSIZE |y|))) (SEQ (SETQ |s| (- |s| (|getShellEntry| $ 6))) (COND - ((OR (< |s| 0) (> (+ |s| |m|) |n|)) + ((OR (MINUSP |s|) (< |n| (+ |s| |m|))) (EXIT (|error| "index out of range")))) (RPLACSTR |y| |s| |m| |x| 0 |m|) (EXIT |y|)))) (DEFUN |ISTRING;elt;$IC;30| (|s| |i| $) (COND ((OR (< |i| (|getShellEntry| $ 6)) - (> |i| (SPADCALL |s| (|getShellEntry| $ 47)))) + (< (SPADCALL |s| (|getShellEntry| $ 47)) |i|)) (|error| "index out of range")) ('T (CHAR |s| (- |i| (|getShellEntry| $ 6)))))) @@ -552,7 +553,7 @@ (- (SPADCALL |s| (|getShellEntry| $ 47)) (|getShellEntry| $ 6)))))) (SEQ (COND - ((OR (< |l| 0) (>= |h| (QCSIZE |s|))) + ((OR (MINUSP |l|) (>= |h| (QCSIZE |s|))) (EXIT (|error| "index out of bound")))) (EXIT (SUBSTRING |s| |l| (MAX 0 (+ (- |h| |l|) 1))))))) diff --git a/src/algebra/strap/LNAGG-.lsp b/src/algebra/strap/LNAGG-.lsp index 2dc153c6..71915a22 100644 --- a/src/algebra/strap/LNAGG-.lsp +++ b/src/algebra/strap/LNAGG-.lsp @@ -33,7 +33,7 @@ (DEFUN |LNAGG-;index?;IAB;2| (|i| |a| $) (COND ((>= |i| (SPADCALL |a| (|getShellEntry| $ 9))) - (NOT (> |i| (SPADCALL |a| (|getShellEntry| $ 10))))) + (NOT (< (SPADCALL |a| (|getShellEntry| $ 10)) |i|))) ('T NIL))) (DEFUN |LNAGG-;concat;ASA;3| (|a| |x| $) diff --git a/src/algebra/strap/NNI.lsp b/src/algebra/strap/NNI.lsp index 184b8ab6..eba910e6 100644 --- a/src/algebra/strap/NNI.lsp +++ b/src/algebra/strap/NNI.lsp @@ -33,7 +33,7 @@ (DEFUN |NNI;subtractIfCan;2$U;3| (|x| |y| $) (LET ((|c| (- |x| |y|))) (COND - ((< |c| 0) (CONS 1 "failed")) + ((MINUSP |c|) (CONS 1 "failed")) ('T (CONS 0 (|check-subtype| (>= |c| 0) '(|NonNegativeInteger|) |c|)))))) diff --git a/src/algebra/strap/OUTFORM.lsp b/src/algebra/strap/OUTFORM.lsp index 6244906c..dd5ede72 100644 --- a/src/algebra/strap/OUTFORM.lsp +++ b/src/algebra/strap/OUTFORM.lsp @@ -616,20 +616,20 @@ (DEFUN |OUTFORM;vspace;I$;28| (|n| $) (COND - ((> |n| 0) + ((< 0 |n|) (|OUTFORM;vconcat;3$;50| " " (|OUTFORM;vspace;I$;28| (- |n| 1) $) $)) ('T (|OUTFORM;empty;$;73| $)))) (DEFUN |OUTFORM;hspace;I$;29| (|n| $) (COND - ((> |n| 0) (|fillerSpaces| |n|)) + ((< 0 |n|) (|fillerSpaces| |n|)) ('T (|OUTFORM;empty;$;73| $)))) (DEFUN |OUTFORM;rspace;2I$;30| (|n| |m| $) (SEQ (COND - ((> |n| 0) - (COND ((NOT (> |m| 0)) (EXIT (|OUTFORM;empty;$;73| $))))) + ((< 0 |n|) + (COND ((NOT (< 0 |m|)) (EXIT (|OUTFORM;empty;$;73| $))))) ('T (EXIT (|OUTFORM;empty;$;73| $)))) (EXIT (|OUTFORM;vconcat;3$;50| (|OUTFORM;hspace;I$;29| |n| $) (|OUTFORM;rspace;2I$;30| |n| (- |m| 1) $) $)))) @@ -937,7 +937,7 @@ ('T (SEQ (LETT |r| (SPADCALL - (|check-subtype| (> |nn| 0) + (|check-subtype| (< 0 |nn|) '(|PositiveInteger|) |nn|) (|getShellEntry| $ 137)) |OUTFORM;differentiate;$Nni$;97|) diff --git a/src/algebra/strap/POLYCAT-.lsp b/src/algebra/strap/POLYCAT-.lsp index ca4bdc5f..46d17c73 100644 --- a/src/algebra/strap/POLYCAT-.lsp +++ b/src/algebra/strap/POLYCAT-.lsp @@ -936,7 +936,7 @@ |POLYCAT-;charthRootlv|) (LOOP (COND - ((NOT (> |d| 0)) (RETURN NIL)) + ((NOT (< 0 |d|)) (RETURN NIL)) (T (SEQ (LETT |dd| (SPADCALL |d| |ch| (|getShellEntry| $ 173)) diff --git a/src/algebra/strap/SINT.lsp b/src/algebra/strap/SINT.lsp index ca473e7e..7aaa1956 100644 --- a/src/algebra/strap/SINT.lsp +++ b/src/algebra/strap/SINT.lsp @@ -92,8 +92,6 @@ (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Short|) |SINT;and;3$;22|)) -(PUT '|SINT;and;3$;22| '|SPADreplace| 'LOGAND) - (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Short|) |SINT;Or;3$;23|)) @@ -102,8 +100,6 @@ (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Short|) |SINT;or;3$;24|)) -(PUT '|SINT;or;3$;24| '|SPADreplace| 'LOGIOR) - (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Short|) |SINT;xor;3$;25|)) @@ -198,8 +194,6 @@ (DECLAIM (FTYPE (FUNCTION (|%Short| |%Shell|) |%Boolean|) |SINT;one?;$B;44|)) -(PUT '|SINT;one?;$B;44| '|SPADreplace| '(XLAM (|x|) (|%ieq| |x| 1))) - (DECLAIM (FTYPE (FUNCTION (|%Short| |%Short| |%Shell|) |%Short|) |SINT;max;3$;45|)) @@ -284,6 +278,14 @@ (DECLAIM (FTYPE (FUNCTION (|%Short| |%Shell|) |%Shell|) |SINT;unitNormal;$R;62|)) +(PUT '|SINT;and;3$;22| '|SPADreplace| + '(XLAM (|x| |y|) (LOGAND |x| |y|))) + +(PUT '|SINT;or;3$;24| '|SPADreplace| + '(XLAM (|x| |y|) (LOGIOR |x| |y|))) + +(PUT '|SINT;one?;$B;44| '|SPADreplace| '(XLAM (|x|) (|%ieq| |x| 1))) + (DEFUN |SINT;writeOMSingleInt| (|dev| |x| $) (SEQ (COND ((QSLESSP |x| 0) @@ -509,7 +511,7 @@ (DEFUN |SINT;unitNormal;$R;62| (|x| $) (COND - ((QSLESSP |x| 0) (VECTOR -1 (QSMINUS |x|) -1)) + ((QSLESSP |x| 0) (VECTOR (QSMINUS 1) (QSMINUS |x|) (QSMINUS 1))) ('T (VECTOR 1 |x| 1)))) (DEFUN |SingleInteger| () diff --git a/src/algebra/strap/STAGG-.lsp b/src/algebra/strap/STAGG-.lsp index 7bfb0d2d..53991265 100644 --- a/src/algebra/strap/STAGG-.lsp +++ b/src/algebra/strap/STAGG-.lsp @@ -74,7 +74,7 @@ (DEFUN |STAGG-;elt;AIS;5| (|x| |i| $) (SEQ (SETQ |i| (- |i| (SPADCALL |x| (|getShellEntry| $ 21)))) (COND - ((OR (< |i| 0) + ((OR (MINUSP |i|) (SPADCALL (SETQ |x| (SPADCALL |x| @@ -91,7 +91,7 @@ (LET ((|l| (- (SPADCALL |i| (|getShellEntry| $ 28)) (SPADCALL |x| (|getShellEntry| $ 21))))) (COND - ((< |l| 0) (|error| "index out of range")) + ((MINUSP |l|) (|error| "index out of range")) ((NOT (SPADCALL |i| (|getShellEntry| $ 29))) (SPADCALL (SPADCALL |x| (|check-subtype| (>= |l| 0) @@ -156,7 +156,7 @@ (DEFUN |STAGG-;setelt;AI2S;11| (|x| |i| |s| $) (SEQ (SETQ |i| (- |i| (SPADCALL |x| (|getShellEntry| $ 21)))) (COND - ((OR (< |i| 0) + ((OR (MINUSP |i|) (SPADCALL (SETQ |x| (SPADCALL |x| @@ -173,7 +173,7 @@ (LET ((|l| (- (SPADCALL |i| (|getShellEntry| $ 28)) (SPADCALL |x| (|getShellEntry| $ 21))))) (COND - ((< |l| 0) (|error| "index out of range")) + ((MINUSP |l|) (|error| "index out of range")) ('T (SEQ (LETT |h| (COND diff --git a/src/algebra/strap/SYMBOL.lsp b/src/algebra/strap/SYMBOL.lsp index 7aca9e5f..e5372535 100644 --- a/src/algebra/strap/SYMBOL.lsp +++ b/src/algebra/strap/SYMBOL.lsp @@ -278,7 +278,7 @@ (RETURN (LET ((|s| (PNAME (SPADCALL |e| (|getShellEntry| $ 100))))) (SEQ (COND - ((> (QCSIZE |s|) 1) + ((< 1 (QCSIZE |s|)) (COND ((SPADCALL (SPADCALL |s| 1 (|getShellEntry| $ 106)) (SPADCALL "\\" (|getShellEntry| $ 43)) @@ -607,7 +607,7 @@ (DEFUN |SYMBOL;istring| (|n| $) (COND - ((> |n| 9) (|error| "Can have at most 9 scripts of each kind")) + ((< 9 |n|) (|error| "Can have at most 9 scripts of each kind")) ('T (|getSimpleArrayEntry| (|getShellEntry| $ 18) (+ |n| 0))))) (DEFUN |SYMBOL;list;$L;34| (|sy| $) diff --git a/src/algebra/strap/URAGG-.lsp b/src/algebra/strap/URAGG-.lsp index 6befa66f..6d2558bb 100644 --- a/src/algebra/strap/URAGG-.lsp +++ b/src/algebra/strap/URAGG-.lsp @@ -168,20 +168,20 @@ (SEQ (LOOP (COND ((NOT (COND - ((> |i| 0) + ((< 0 |i|) (NOT (SPADCALL |l| (|getShellEntry| $ 20)))) ('T NIL))) (RETURN NIL)) (T (SEQ (SETQ |l| (SPADCALL |l| (|getShellEntry| $ 14))) (EXIT (SETQ |i| (- |i| 1))))))) - (EXIT (> |i| 0))))) + (EXIT (< 0 |i|))))) (DEFUN |URAGG-;more?;ANniB;13| (|l| |n| $) (LET ((|i| |n|)) (SEQ (LOOP (COND ((NOT (COND - ((> |i| 0) + ((< 0 |i|) (NOT (SPADCALL |l| (|getShellEntry| $ 20)))) ('T NIL))) (RETURN NIL)) @@ -198,7 +198,7 @@ (COND ((NOT (COND ((SPADCALL |l| (|getShellEntry| $ 20)) NIL) - ('T (> |i| 0)))) + ('T (< 0 |i|)))) (RETURN NIL)) (T (SEQ (SETQ |l| (SPADCALL |l| (|getShellEntry| $ 14))) (EXIT (SETQ |i| (- |i| 1))))))) @@ -376,7 +376,7 @@ (DEFUN |URAGG-;last;ANniA;22| (|x| |n| $) (LET ((|m| (SPADCALL |x| (|getShellEntry| $ 60)))) (COND - ((> |n| |m|) (|error| "index out of range")) + ((< |m| |n|) (|error| "index out of range")) ('T (SPADCALL (SPADCALL |x| diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 17d630b4..c2c55b14 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -1148,10 +1148,10 @@ replaceSimpleFunctions form == optLET mutateLETFormWithUnaryFunction(form,"replaceSimpleFunctions") form is ["spadConstant","$",n] => null(op := getCapsuleDirectoryEntry n) => form - getFunctionReplacement op is ["XLAM",=nil,body] - and isAtomicForm body => body -- Conservatively preserve object identity and storage -- consumption by not folding non-atomic constant forms. + getFunctionReplacement op isnt ['XLAM,=nil,body] => form + isAtomicForm body or isVMConstantForm body => body form -- 1. process argument first. for args in tails rest form repeat diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index f8e28b42..a78abadd 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -471,18 +471,19 @@ $VMsideEffectFreeOperators == SPADfirst QVELT _+ _- _* _< _= _<_= _> _>_= ASH INTEGER_-LENGTH QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP MINUSP GREATERP ZEROP ODDP FLOAT_-RADIX FLOAT FLOAT_-SIGN FLOAT_-DIGITS - CGREATERP GGREATERP CHAR BOOLE GET BVEC_-GREATER FUNCALL %false %true + CGREATERP GGREATERP CHAR BOOLE GET BVEC_-GREATER %false %true %and %or %not %eq %ieq %ilt %ile %igt %ige %head %tail %integer? %imul %iadd %isub %igcd %ilcm %ipow %imin %imax %ieven? %iodd? %iinc %feq %flt %fle %fgt %fge %fmul %fadd %fsub %fexp %fmin %fmax %float? - %fpow %fdiv %nil %pair? %lconcat %llength %lfirst %lsecond %lthird - %lreverse %lempty? %hash %ismall? %string? - %ceq %clt %cle %cgt %cge %c2i %i2c) + %fpow %fdiv %fneg %i2f %fminval %fmaxval %fbase %fprec %ftrunc + %nil %pair? %lconcat %llength %lfirst %lsecond %lthird + %lreverse %lempty? %hash %ismall? %string? + %ceq %clt %cle %cgt %cge %c2i %i2c) ++ List of simple VM operators $simpleVMoperators == append($VMsideEffectFreeOperators, - ["CONS","LIST","VECTOR","STRINGIMAGE",'%gensym, '%lreverse_!, + ['CONS,'LIST,'VECTOR,'STRINGIMAGE,'FUNCALL,'%gensym, '%lreverse_!, "MAKE-FULL-CVEC","BVEC-MAKE-FULL","COND"]) ++ Return true if the `form' is semi-simple with respect to @@ -513,10 +514,8 @@ isFloatableVMForm form == isVMConstantForm: %Code -> %Boolean isVMConstantForm form == integer? form or string? form => true - form=nil or form=true => true form isnt [op,:args] => false - op = "QUOTE" => true - MEMQ(op,$simpleVMoperators) and + MEMQ(op,$VMsideEffectFreeOperators) and "and"/[isVMConstantForm arg for arg in args] ++ Return the set of free variables in the VM form `form'. diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index bf4a02ee..af20fb51 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -226,6 +226,50 @@ expandReturn(x is ['%return,.,y]) == expandEq ["%eq",:args] == ["EQ",:expandToVMForm args] + +expandIneg ['%ineg,x] == + x := expandToVMForm x + integer? x => -x + ['_-,x] + +expandIlt ['%ilt,x,y] == + integer? x and x = 0 => ['PLUSP,expandToVMForm y] + integer? y and y = 0 => ['MINUSP,expandToVMForm x] + ['_<,expandToVMForm x,expandToVMForm y] + +expandIgt ['%igt,x,y] == + expandFlt ['%ilt,y,x] + +-- Floating point support + +expandFbase ['%fbase] == + FLOAT_-RADIX $DoubleFloatMaximum + +expandFprec ['%fprec] == + FLOAT_-DIGITS $DoubleFloatMaximum + +expandFminval ['%fminval] == + '$DoubleFloatMinimum + +expandFmaxval ['%fmaxval] == + '$DoubleFloatMaximum + +expandI2f ['%i2f,x] == + x := expandToVMForm x + integer? x and (x = 0 or x = 1) => FLOAT(x,$DoubleFloatMaximum) + ['FLOAT,x,'$DoubleFloatMaximum] + +expandFneg ['%fneg,x] == + ['_-,expandToVMForm x] + +expandFlt ['%flt,x,y] == + x is ['%i2f,0] => ['PLUSP,expandToVMForm y] + y is ['%i2f,0] => ['MINUSP,expandToVMForm x] + ['_<,expandToVMForm x,expandToVMForm y] + +expandFgt ['%fgt,x,y] == + expandFlt ['%flt,y,x] + -- Local variable bindings expandBind ['%bind,inits,body] == body := expandToVMForm body @@ -274,7 +318,6 @@ for x in [ -- unary integer operations. ['%iabs, :'ABS], ['%ieven?, :'EVENP], - ['%ineg, :"-"], ['%integer?,:'INTEGERP], ['%iodd?, :'ODDP], ['%ismall?, :'FIXNUMP], @@ -283,11 +326,9 @@ for x in [ ['%ieq, :"EQL"], ['%igcd,:'GCD], ['%ige, :">="], - ['%igt, :">"], ['%iinc,:"1+"], ['%ilcm,:'LCM], ['%ile, :"<="], - ['%ilt, :"<"], ['%imax,:'MAX], ['%imin,:'MIN], ['%imul,:"*"], @@ -297,14 +338,13 @@ for x in [ -- unary float operations. ['%fabs, :'ABS], ['%float?,:'FLOATP], + ['%ftrunc,:'TRUNCATE], -- binary float operations. ['%fadd, :"+"], ['%fdiv, :"/"], ['%feq, :"="], ['%fge, :">="], - ['%fgt, :">"], ['%fle, :"<="], - ['%flt, :"<"], ['%fmax, :'MAX], ['%fmin, :'MIN], ['%fmul, :"*"], @@ -348,6 +388,19 @@ for x in [ ['%loop, :function expandLoop], ['%return, :function expandReturn], + ['%igt, :function expandIgt], + ['%ilt, :function expandIlt], + ['%ineg, :function expandIneg], + + ['%i2f, :function expandI2f], + ['%fbase, :function expandFbase], + ['%fgt, :function expandFgt], + ['%flt, :function expandFlt], + ['%fmaxval, :function expandFmaxval], + ['%fminval, :function expandFminval], + ['%fneg, :function expandFneg], + ['%fprec, :function expandFprec], + ["%eq",:function expandEq], ["%bind",:function expandBind], diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 71cd6a21..8981fd7e 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -164,8 +164,10 @@ needToQuoteFlags?(sig,env) == optDeltaEntry(op,sig,dc,eltOrConst) == $killOptimizeIfTrue = true => nil + -- references to modemaps from current domain are folded in a later + -- stage of the compilation process. + dc = '$ => nil ndc := - dc = '$ => $functorForm atom dc and (dcval := get(dc,'value,$e)) => dcval.expr dc sig := MSUBST(ndc,dc,sig) -- cgit v1.2.3