diff options
Diffstat (limited to 'src/algebra/strap/FPS-.lsp')
| -rw-r--r-- | src/algebra/strap/FPS-.lsp | 55 |
1 files changed, 47 insertions, 8 deletions
diff --git a/src/algebra/strap/FPS-.lsp b/src/algebra/strap/FPS-.lsp index 56751bc4..1ec37dce 100644 --- a/src/algebra/strap/FPS-.lsp +++ b/src/algebra/strap/FPS-.lsp @@ -2,17 +2,18 @@ (/VERSIONCHECK 2) (DEFUN |FPS-;float;2IS;1| (|ma| |ex| $) - (SPADCALL |ma| |ex| (SPADCALL (QREFELT $ 8)) (QREFELT $ 10))) + (SPADCALL |ma| |ex| (SPADCALL (|getShellEntry| $ 8)) + (|getShellEntry| $ 10))) (DEFUN |FPS-;digits;Pi;2| ($) - (PROG (#0=#:G1389) + (PROG (#0=#:G1398) (RETURN (PROG1 (LETT #0# (MAX 1 (QUOTIENT2 (SPADCALL 4004 - (- (SPADCALL (QREFELT $ 13)) 1) - (QREFELT $ 14)) + (- (SPADCALL (|getShellEntry| $ 13)) 1) + (|getShellEntry| $ 14)) 13301)) |FPS-;digits;Pi;2|) (|check-subtype| (> #0# 0) '(|PositiveInteger|) #0#))))) @@ -23,15 +24,15 @@ (PROGN (LETT |dv$1| (|devaluate| |#1|) . #0=(|FloatingPointSystem&|)) (LETT |dv$| (LIST '|FloatingPointSystem&| |dv$1|) . #0#) - (LETT $ (GETREFV 17) . #0#) - (QSETREFV $ 0 |dv$|) - (QSETREFV $ 3 + (LETT $ (|newShell| 17) . #0#) + (|setShellEntry| $ 0 |dv$|) + (|setShellEntry| $ 3 (LETT |pv$| (|buildPredVector| 0 0 (LIST (|HasAttribute| |#1| '|arbitraryExponent|) (|HasAttribute| |#1| '|arbitraryPrecision|))) . #0#)) (|stuffDomainSlots| $) - (QSETREFV $ 6 |#1|) + (|setShellEntry| $ 6 |#1|) $)))) (MAKEPROP '|FloatingPointSystem&| '|infovec| @@ -48,3 +49,41 @@ 13 2 9 0 7 0 14 0 6 0 15 2 0 0 9 9 11 0 0 7 16))))) '|lookupComplete|)) + +(SETQ |$CategoryFrame| + (|put| '|FloatingPointSystem&| '|isFunctor| + '(((|digits| ((|PositiveInteger|) (|PositiveInteger|))) T + (ELT $ NIL)) + ((|digits| ((|PositiveInteger|))) T (ELT $ 16)) + ((|float| ($ (|Integer|) (|Integer|) + (|PositiveInteger|))) + T (ELT $ NIL)) + ((|float| ($ (|Integer|) (|Integer|))) T (ELT $ 11))) + (|addModemap| '|FloatingPointSystem&| + '(|FloatingPointSystem&| |#1|) + '((CATEGORY |domain| + (SIGNATURE |digits| + ((|PositiveInteger|) (|PositiveInteger|))) + (SIGNATURE |digits| ((|PositiveInteger|))) + (SIGNATURE |float| + (|#1| (|Integer|) (|Integer|) + (|PositiveInteger|))) + (SIGNATURE |float| + (|#1| (|Integer|) (|Integer|)))) + (|FloatingPointSystem|)) + T '|FloatingPointSystem&| + (|put| '|FloatingPointSystem&| '|mode| + '(|Mapping| + (CATEGORY |domain| + (SIGNATURE |digits| + ((|PositiveInteger|) + (|PositiveInteger|))) + (SIGNATURE |digits| + ((|PositiveInteger|))) + (SIGNATURE |float| + (|#1| (|Integer|) (|Integer|) + (|PositiveInteger|))) + (SIGNATURE |float| + (|#1| (|Integer|) (|Integer|)))) + (|FloatingPointSystem|)) + |$CategoryFrame|)))) |