(DE FLTDEF () (SYNONYM 'EXPO 'CAAR) (SYNONYM 'SIGN 'CADAR) (SYNONYM 'FRACTION 'CDR) (PRIN "Enter decimal precision required (digits)") (SETQ NDIGITS (READ)) (SETQ E+1 (MAKEFLT 4 0 [-24576]) E+8 (MAKEFLT 27 0 [8192 -16708]) EW -13108 NFRAC (+ 2 (SCALE (ADD1 NDIGITS) 2076 10000)) E-1W (MAKEFLT -3 0 ((LAMBDA (N) (IFN (ZEROP N) (CONS EW (SELF (SUB1 N))))) NFRAC)) E-8W (MUL E-1W E-1W) E-8W (MUL E-8W E-8W) E-8W (MUL E-8W E-8W)) (RPLACB (FRACTION E-1W) (CDDR E-1W)) (RPLACB (FRACTION E-8W) (CDDR E-8W))) (DE MAKEFLT (EX SGN FRAC) (CONS [EX SGN] FRAC)) (DE REMOVL (X) (FREVERSE (CDR (FREVERSE X)))) (DE SHDOWN (A N A1) (FREVERSE (SHDN (FREVERSE A) (- N) A1))) (DE SHDN (A N A1) (COND ((ZEROP N) A) ((LE N -16) (SHDN (CONS 0 (REMOVL A)) (+ N 16) A1)) (T (SETQ N16 (+ N 16)) (MAPCAR (LAMBDA (X) (PROG1 (LOGOR (LSH X N) A1) (SETQ A1 (LSH X N16)))) A)))) (DE SHUP (A N) (COND ((ZEROP N) A) ((GE N 16) (SHUP (CONS 0 (REMOVL A)) (- N 16))) (T (SETQ N16 (- N 16) A1 0) (MAPCAR (LAMBDA (X) (PROG1 (LOGOR (LSH X N) A1) (SETQ A1 (LSH X N16)))) A)))) (DE NORM (A) (IF (ZEROP A) 0 (SETQ NSHIF (LEAD0 (FRACTION A))) (IF (ZEROP NSHIF) A (MAKEFLT (- (EXPO A) NSHIF) (SIGN A) (SHUP (FRACTION A) NSHIF))))) (DE LEAD0 (A) (SETQ AR (REVERSE A) AL 0) (WHILE (PROGN (SETQ AJ (LEAD (NEXTL AR)) AL (+ AL AJ)) (EQ AJ 16))) AL) (DE LEAD (X) (COND ((LT X) 0) ((GE X 128) (IF (GE X 2048) (IF (GE X 8192) (IF (GE X 16384) 1 2) (IF (GE X 4096) 3 4)) (IF (GE X 512) (IF (GE X 1024) 5 6) (IF (GE X 256) 7 8)))) (T (IF (GE X 8) (IF (GE X 32) (IF (GE X 64) 9 10) (IF (GE X 16) 11 12)) (IF (GE X 2) (IF (GE X 4) 13 14) (IF (ZEROP X) 16 15)))))) (DE ADD (X Y) (COND ((EQ X 0) Y) ((EQ Y 0) X) (T (SETQ DEXPO (- (EXPO X) (EXPO Y))) (COND ((ZEROP DEXPO) (IF (AND (EQ (+ (SIGN X) (SIGN Y)) 1) (EQUAL (FRACTION X) (FRACTION Y))) 0 (ADDA (EXPO X) (SIGN X) (SIGN Y) (FRACTION X) (FRACTION Y)))) ((GT DEXPO) (ADDA (EXPO X) (SIGN X) (SIGN Y) (FRACTION X) (SHDOWN (FRACTION Y) DEXPO 0))) (T (ADDA (EXPO Y) (SIGN X) (SIGN Y) (SHDOWN (FRACTION X) (- DEXPO) 0) (FRACTION Y))))))) (DE ADDA (EX S1 S2 F1 F2) (SETQ FR1 (IF (ZEROP S1) F1 (NEGFR F1)) FR2 (IF (ZEROP S2) F2 (NEGFR F2)) FR12 (ADDFR FR1 FR2) S12 (+ CRY S1 S2)) (IF (ZEROP (LOGXOR S1 S2)) (COND ((ZEROP S12) (NORM (MAKEFLT EX 0 FR12))) ((EQ S12 1) (MAKEFLT (ADD1 EX) 0 (SHDOWN FR12 1 -32768))) ((EQ S12 2) (MAKEFLT (ADD1 EX) 1 (NEGFR (SHDOWN FR12 1 0)))) (T (NORM (MAKEFLT (ADD1 EX) 1 (NEGFR (SHDOWN FR12 1 -32768)))))) (IF (ZEROP (LOGAND S12 1)) (NORM (MAKEFLT EX 0 FR12)) (NORM (MAKEFLT EX 1 (NEGFR FR12)))))) (DE NEGFR (F) (SETQ CRY 1) (MAPCAR (LAMBDA (X) (PROG1 (+ CRY (COMPL X)) (SETQ CRY CARRY))) F)) (DE ADDD (X Y) (COND ((EQ X 0) Y) ((EQ Y 0) X) (T (SETQ LDIF (- (LENGTH (FRACTION X)) (LENGTH (FRACTION Y)))) (COND ((ZEROP LDIF) (ADD X Y)) ((GT LDIF) (SETQ FR (FRACTION Y)) (UNTIL (ZEROP LDIF) (NEWL FR 0) (DECR LDIF)) (ADD X (MAKEFLT (EXPO Y) (SIGN Y) FR))) (T (SETQ FR (FRACTION X)) (UNTIL (ZEROP LDIF) (NEWL FR 0) (INCR LDIF)) (ADD Y (MAKEFLT (EXPO X) (SIGN X) FR))))))) (DE ADDFR (A B) (SETQ CRY 0) (MAPCAR (LAMBDA (X) (PROG1 (+ X (NEXTL B) CRY) (SETQ CRY CARRY))) A)) (DE MUL (X Y Z) (IF (OR (ZEROP X) (ZEROP Y)) 0 (SETQ EX (+ (EXPO X) (EXPO Y)) SGN (LOGXOR (SIGN X) (SIGN Y))) (IF (OR (AND (GE EX) (LT (EXPO X)) (LT (EXPO Y))) (AND (LT EX) (GE (EXPO X)) (GE (EXPO Y)))) (PRINT "FLOATING OVER/UNDER FLOW") (SETQ D1 1 L [[0]]) (MAPC (LAMBDA (D) (SETQ E1 D1) (MAPC (LAMBDA (E) (SETQ MULDE (MUL32 D E)) (ATTACH L E1 (1 MULDE)) (ATTACH L (INCR E1) (2 MULDE))) (FRACTION X)) (INCR D1)) (FRACTION Y)) (SETQ CRY 0) (SETQ MXY (MAPCAR (LAMBDA (A) (PROG1 (APPLY '+ (CONS CRY A)) (SETQ CRY CARRY))) L)) (ROUND) (NORM (MAKEFLT EX SGN MXY))))) (DE TXT1 () () () () () () () () () () () ()) (DE ROUND () (SETQ RND 0) (IFN Z (SETQ Z (LENGTH (FRACTION Y)))) (UNTIL (ZEROP Z) (SETQ RND (NEXTL MXY)) (DECR Z)) (IF (LT RND) (SETQ CRY 1 MXY (MAPCAR (LAMBDA (A) (PROG1 (+ CRY A) (SETQ CRY CARRY))) MXY)))) (DE ATTACH (L N E) (SETQ LN (N L)) (IF LN (NCONC1 LN E) (NCONC1 L [E]))) (DE NEG (X) (IF (ZEROP X) 0 (MAKEFLT (EXPO X) (- 1 (SIGN X)) (FRACTION X)))) (DE SUB (X Y) (ADD X (NEG Y))) (DE SUBB (X Y) (ADDD X (NEG Y))) (DE DIV (X Y) (MUL X (RECIP Y))) (DE RECIP (X) (IF (ZEROP X) (PRINT "DIVISION BY ZERO") (SETQ ROLD (GUESS X) RNEW (SUB (ADD ROLD ROLD) (MUL (MUL ROLD ROLD) X)) RCOUNT 0) (UNTIL (AND (EQUAL (CDR (FRACTION ROLD)) (CDR (FRACTION RNEW))) (LE (ABS (- (CAR (FRACTION ROLD)) (CAR (FRACTION RNEW)))) 256)) (SETQ ROLD RNEW RCOUNT (ADD1 RCOUNT) RNEW (SUB (ADD ROLD ROLD) (MUL (MUL ROLD ROLD) X)))) RNEW)) (DE GUESS (X) (MAKEFLT (COMPL (EXPO X)) (SIGN X) (CONS 0 (FRACTION X)))) (DE FLOAT (N LENGTH) (COND ((ZEROP N) 0) ((GE N) (NORM (MAKEFLT 16 0 (PROGN (SETQ A [N] LEN (SUB1 LENGTH)) (UNTIL (ZEROP LEN) (DECR LEN) (NEWL A 0)) A)))) (T (NORM (MAKEFLT 16 1 (PROGN (SETQ A [(- N)] LEN (SUB1 LENGTH)) (UNTIL (ZEROP LEN) (DECR LEN) (NEWL A 0)) A)))))) (DE FIX (X) (IF (EQ X 0) 0 (SETQ EX16 (- (EXPO X) 16)) (COND ((GT EX16) (PRINT "OVERFLOW FROM FIX")) ((LT EX16 -15) (PRINT "UNDEFLOW FROM FIX")) ((ZEROP (SIGN X)) (LSH (CAR (LAST (FRACTION X))) EX16)) (T (- (LSH (CAR (LAST (FRACTION X))) EX16)))))) (DE BINDEC (S NDIG) (IF (ZEROP S) 0 (SETQ SLEN (LENGTH (FRACTION S)) SGN1 (ZEROP (SIGN S)) EXP10 -1 DONE () DEC ()) (IFN NDIG (SETQ NDIG (- (SCALE SLEN 4816 1000) 3))) (IF (GT NDIG NDIGITS) (SETQ NDIG NDIGITS)) (GETSF) (UNTIL (LT (DECR NDIG)) (SETQ SF (ADDFR (SHUP SF 1) (SHUP SF 3))) (NEWL DEC (CAR (LAST SF))) (RPLACA (LAST SF) 0)) (SETQ SF (ADDFR (SHUP SF 1) (SHUP SF 3))) (COND ((GE (CAR (LAST SF)) 5) (SETQ DEC1 DEC) (RPLACA DEC1 (ADD1 (CAR DEC1))) (WHILE (AND (EQ (CAR DEC1) 10) (CDR DEC1)) (RPLACA DEC1 0) (NEXTL DEC1) (RPLACA DEC1 (ADD1 (CAR DEC1)))))) (SETQ DEC (FREVERSE (CONS (ASCII 69) DEC))) (COND ((ZEROP (CAR DEC)) (DECR EXP10) (NEXTL DEC))) (RPLACD DEC (CONS "." (CDR DEC))) (IFN SGN1 (NEWL DEC (ASCII 45))) (NEWL DEC "f") (IMPLODE (NCONC DEC (EXPLODE EXP10))))) (DE GETSF () (UNTIL DONE (SETQ EXP2 (EXPO S)) (COND ((GE EXP2 1) (IF (GE EXP2 28) (SETQ S (MUL S E-8W) EXP10 (+ EXP10 8)) (SETQ S (MUL S E-1W)) (INCR EXP10))) ((LE EXP2 -4) (IF (LE EXP2 -30) (SETQ S (MUL S E+8) EXP10 (- EXP10 8)) (SETQ S (MUL S E+1)) (DECR EXP10))) (T (SETQ DONE T)))) (SETQ SF (NCONC1 (SHDOWN (FRACTION S) (- (EXPO S)) 0) 0))) (DE ADJUST () (COND ((GT EXP10) (WHILE (GE EXP10 8) (SETQ SF (MUL SF E+8) EXP10 (- EXP10 8))) (UNTIL (ZEROP EXP10) (SETQ SF (MUL SF E+1)) (DECR EXP10))) ((LT EXP10) (WHILE (LE EXP10 -8) (SETQ SF (MUL SF E-8W) EXP10 (+ EXP10 8))) (UNTIL (ZEROP EXP10) (SETQ SF (MUL SF E-1W)) (INCR EXP10))))) (DE DECBIN (DEC N) (IF (ZEROP DEC) 0 (SETQ EXP10 0 NUMDIG 0 SGN 0 PERIOD () DEC (EXPLODE DEC) SF [0]) (WHILE DEC (SETQ DEC1 (NEXTL DEC)) (COND ((NUMBP DEC1) (IF PERIOD (DECR EXP10)) (INCR NUMDIG) (NCONC1 SF 0) (SETQ SF (ADDFR (SHUP SF 1) (SHUP SF 3))) (RPLACA SF (+ (CAR SF) DEC1)) (SETQ SF1 SF) (UNTIL (ZEROP CARRY) (NEXTL SF1) (RPLACA SF1 (+ 1 (CAR SF1)))) (IF (ZEROP (CAR (LAST SF))) (SETQ SF (REMOVL SF)))) ((EQ DEC1 (ASCII 69)) (SETQ EXP10 (+ EXP10 (IMPLODE DEC)) DEC ())) ((EQ DEC1 ".") (SETQ PERIOD T)) ((EQ DEC1 (ASCII 45)) (SETQ SGN 1)))) (IFN N (SETQ N (+ 2 (SCALE (ADD1 NUMDIG) 2076 10000)))) (IF (GT N NFRAC) (SETQ N NFRAC)) (SETQ EXSF ("*" 16 (LENGTH SF))) (WHILE (LT (LENGTH SF) N) (NEWL SF 0)) (WHILE (GT (LENGTH SF) N) (NEXTL SF)) (SETQ SF (NORM (MAKEFLT EXSF SGN SF))) (ADJUST) SF)) (DE SUM (X Y N) (BINDEC (ADDD (DECBIN X N) (DECBIN Y N)))) (DE DIF (X Y N) (BINDEC (SUBB (DECBIN X N) (DECBIN Y N)))) (DE PROD (X Y N) (BINDEC (MUL (DECBIN X N) (DECBIN Y N)))) (DE QUOT (X Y N) (BINDEC (DIV (DECBIN X N) (DECBIN Y N)))) (DE SVFLT () (SETQ CPOS 77) (SAVE FLTDEF MAKEFLT REMOVL SHDOWN SHDN SHUP NORM LEAD0 LEAD ADD ADDA NEGFR ADDD ADDFR MUL TXT1 ROUND ATTACH NEG SUB SUBB DIV RECIP GUESS FLOAT FIX BINDEC GETSF ADJUST DECBIN SUM DIF PROD QUOT SVFLT)) (FLTDEF)