CP/M 2.2Ђ DOUBLE-DђDISKETTE^ЂCPM FROMЂNORTH * ЂSTAR Ђ--------Ђ-SYSTEM-†-TRACKS-†BIOS †USER †CPM CCP †CPM BDOS †--------ЂDIR.SEC1ѓDIR.SEC2ѓDIR.SEC3ѓDIR.SEC4ѓ--------ЂCPM DATA‡DATASEC1‡DATASEC2‡DATASEC3‡DATASEC4‡........‡ FPOINT SCRЂ FPOINT SCRЂ !FPOINT SCRЂ"#$%&'()*+,-./01FPOINT SCR23ееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееее ( MicroMotion Z-80 Floating Point Package ) ( Copyright 1982 ) ( MicroMotion ) ( 12077 Wilshire Blvd., #506 ) ( Los Angeles, CA 90025 ) ( 213-821-4340 ) ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) FORTH DEFINITIONS HEX VARIABLE FSTAT VARIABLE RSAVE 9 ALLOT RSAVE 4 + CONSTANT GUARD ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE UNFLO HL POP, RSAVE ) HL LD, A 4 LD, HL FSTAT LD, (HL) OR, (HL) A LD, DE POP, DE POP, DE 0 LD, DE PUSH, DE PUSH, HL RSAVE ) LD, (HL) JP, END-CODE ееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееееее ( Written by Martin Tracy and Ron Anderson ) RSAVE 5 + CONSTANT XPTR RSAVE 6 + CONSTANT FTEMP RSAVE 7 + CONSTANT FTEMP1 RSAVE 8 + CONSTANT FTEMP2 RSAVE 9 + CONSTANT FTEMP3 RSAVE 0A + CONSTANT FTEMP4 CODE OVFLO HL POP, RSAVE ) HL LD, A 2 LD, HL FSTAT LD, (HL) OR, (HL) A LD, DE POP, D RL, DE POP, DE FFFF LD, DE PUSH, D 7F LD, D RR, DE PUSH, HL RSAVE ) LD, (HL) JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) ( EXP+1 ) CODE EXP+1 HL POP, RSAVE ) HL LD, HL POP, D H LD, H SLA, A H LD, A 2 ADD, AF PUSH, H A LD, D RL, H RR, AF POP, HL PUSH, PE ' OVFLO 4 + JP, HL POP, DE POP, SCF, L RR, D RR, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE ROUND A GUARD ) LD, A OR, P RET, HL POP, RSAVE ) HL LD, ( ALTERNATE ENTRY FROM INVERT ) DE POP, HL POP, HL INC, A H LD, L OR, NZ 1 L# JP, E INC, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE INVERT HL POP, RSAVE ) HL LD, DE POP, HL POP, A 80 LD, D XOR, D A LD, A E LD, CPL, E A LD, A H LD, CPL, H A LD, A L LD, CPL, L A LD, A GUARD ) LD, CPL, GUARD ) A LD, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE DENORM HL POP, RSAVE ) HL LD, 20 CP, NCY ' UNFLO 0B + JP, DE POP, HL POP, 1 L: 8 CP, CY 2 L# JP, AF AF' EX, A L LD, GUARD ) A LD, AF AF' EX, L H LD, H E LD, E 0 LD, 8 SUB, 1 L# JP, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE NORM HL POP, RSAVE ) HL LD, EXX, DE POP, HL POP, A L LD, H OR, E OR, NZ 1 L# JP, D 0 LD, 6 L# JP, 1 L: B D LD, B SLA, 2 L: A E LD, A OR, NZ 4 L# JP, E H LD, H L LD, A GUARD ) LD, L A LD, A XOR, GUARD ) A LD, A B LD, 10 SUB, B A LD, E RR, DE PUSH, HL PUSH, HL RSAVE ) LD, (HL) JP, END-CODE 1 L: HL PUSH, DE PUSH, Z ' EXP+1 2+ 2+ JP, HL RSAVE ) LD, (HL) JP, END-CODE HL PUSH, DE PUSH, HL GUARD LD, (HL) INC, Z ' ROUND 9 + JP, HL RSAVE ) LD, (HL) JP, END-CODE 2 L: A OR, Z 3 L# JP, E SRL, H RR, L RR, AF PUSH, A GUARD ) LD, RRA, GUARD ) A LD, AF POP, A DEC, 2 L# JP, 3 L: HL PUSH, DE PUSH, HL RSAVE ) LD, (HL) JP, END-CODE PO 2 L# JP, 3 L: HL PUSH, DE PUSH, EXX, ' UNFLO 4 + JP, 4 L: 7 E BIT, NZ 5 L# JP, A GUARD ) LD, A SLA, GUARD ) A LD, L RL, H RL, E RL, A B LD, 2 SUB, B A LD, PO 4 L# JP, 3 L# JP, 5 L: D RL, B RR, D B LD, 6 L: HL PUSH, DE PUSH, EXX, HL RSAVE ) LD, (HL) JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE F+- HL POP, RSAVE 2+ ) HL LD, EXX, A XOR, GUARD ) A LD, XPTR ) A LD, DE POP, E OR, NZ 1 L# JP, DE POP, EXX, HL RSAVE 2+ ) LD, (HL) JP, 1 L: IX POP, HL POP, A XOR, L OR, NZ 2 L# JP, HL POP, IX PUSH, DE PUSH, EXX, HL RSAVE 2+ ) LD, (HL) JP, 2 L: A H LD, D XOR, B A LD, C H LD, C SLA, A D LD, A SLA, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) ( F+ ) HL POP, A L LD, HL POP, DE POP, BC POP, HL BC ADD, A E ADC, E A LD, HL PUSH, DE PUSH, EXX, CY 9 L# JP, HL RSAVE 2+ ) LD, (HL) JP, 9 L: HL RSAVE 2+ ) LD, RSAVE ) HL LD, ' EXP+1 4 + JP, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE F+ ' F+- CALL, ' ROUND CALL, NEXT JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE FXET HL POP, RSAVE ) HL LD, DE POP, IX POP, HL POP, A D LD, 80 AND, H XOR, H A LD, A E LD, A OR, NZ 2 L# JP, A XPTR ) LD, A OR, NZ 3 L# JP, 1 L: DE POP, DE 0 LD, DE PUSH, DE PUSH, HL RSAVE 2+ ) LD, (HL) JP, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE (F*) HL POP, RSAVE 2+ ) HL LD, A XOR, XPTR ) A LD, ' FXET CALL, HL RSAVE 2+ ) LD, RSAVE ) HL LD, EXX, HL POP, DE POP, BC POP, H SLA, A B LD, A SLA, A H ADD, PO 1 L# JP, BC PUSH, EXX, M ' OVFLO 4 + JP, ' UNFLO 4 + JP, C SUB, PO 3 L# JP, A 3F LD, 3 L: M 4 L# JP, Z 7 L# JP, H D LD, XPTR ) A LD, 5 L# JP, 4 L: NEG, 5 L: A SRL, C A LD, A XPTR ) LD, A OR, A C LD, HL PUSH, NZ 6 L# JP, IX PUSH, DE PUSH, ' DENORM CALL, 8 L# JP, 6 L: EXX, ' DENORM CALL, EXX, IX PUSH, DE PUSH, 8 L# JP, 7 L: HL PUSH, IX PUSH, DE PUSH, 8 L: A B LD, A OR, M 10 L# JP, ( F- ) 10 L: A XPTR ) LD, A OR, HL POP, NZ 11 L# JP, BC POP, DE POP, A E LD, E L LD, HL POP, 12 L# JP, 11 L: A L LD, HL POP, DE POP, BC POP, 12 L: HL BC SBC, A E SBC, E A LD, HL PUSH, DE PUSH, EXX, NCY 13 L# JP, ' INVERT CALL, 13 L: HL RSAVE 2+ ) LD, RSAVE ) HL LD, ' NORM 4 + JP, END-CODE CODE F- HL POP, A H LD, 80 XOR, H A LD, HL PUSH, ' F+- CALL, ' ROUND CALL, NEXT JP, END-CODE 2 L: A L LD, A OR, Z 1 L# JP, HL PUSH, IX PUSH, DE PUSH, HL RSAVE ) LD, (HL) JP, 3 L: A FSTAT ) LD, 10 OR, FSTAT ) A LD, HL PUSH, HL RSAVE 2+ ) LD, RSAVE ) HL LD, ' OVFLO 4 + JP, END-CODE 1 L: B SLA, RRA, XPTR ) A LD, B L LD, HL POP, A C LD, AF PUSH, A H LD, AF PUSH, A L LD, AF PUSH, A XOR, GUARD ) A LD, H A LD, L A LD, C A LD, A 3 LD, 2 L: AF AF' EX, AF POP, A OR, NZ 3 L# JP, A L LD, GUARD ) A LD, L H LD, H C LD, C 0 LD, 6 L# JP, 3 L: A SRL, 7 A SET, 4 L: FTEMP ) A LD, NCY 5 L# JP, A C LD, HL DE ADD, A B ADC, C A LD, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) 5 L: C RR, H RR, L RR, A GUARD ) LD, RRA, GUARD ) A LD, A FTEMP ) LD, A SRL, NZ 4 L# JP, 6 L: AF AF' EX, A DEC, NZ 2 L# JP, HL PUSH, A XPTR ) LD, B A LD, BC PUSH, ' NORM 5 + JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE (F/) HL POP, RSAVE 2+ ) HL LD, A 1 LD, XPTR ) A LD, ' FXET CALL, HL RSAVE 2+ ) LD, RSAVE ) HL LD, D 1 LD, EXX, HL POP, DE POP, BC POP, H SLA, A B LD, A SLA, H SUB, AF PUSH, 7E CP, Z 1 L# JP, AF POP, PO 2 L# JP, BC PUSH, EXX, M ' OVFLO 4 + JP, ' UNFLO 4 + JP, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) AF AF' EX, EXX, D 40 LD, EXX, 8 L# JP, 6 L: NCY 10 L# JP, AF AF' EX, EXX, D 1 LD, EXX, 8 L# JP, 7 L: EXX, D A LD, EXX, 8 L: AF POP, NCY 9 L# JP, CCF, HL DE SBC, A C LD, A B SBC, C A LD, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE F* ' (F*) CALL, ' ROUND CALL, NEXT JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE (FIT) EXX, HL POP, RSAVE 2+ ) HL LD, HL POP, A L LD, A OR, Z 4 L# JP, A H LD, A A ADD, Z 4 L# JP, P 1 L# JP, A 4 LD, 4 L# JP, 1 L: 40 CP, CY 2 L# JP, A 2 LD, 4 L# JP, 2 L: A H LD, 1 L: AF POP, 2 L: A 2 ADD, B SLA, RRA, FTEMP ) A LD, A XOR, AF AF' EX, IX FTEMP LD, B L LD, HL POP, 3 L: A C LD, B CP, NZ 4 L# JP, A H LD, D CP, NZ 4 L# JP, A L LD, E CP, 4 L: CCF, 5 L: EXX, A D LD, EXX, AF PUSH, RLA, NCY 7 L# JP, IX INC, 0 +IX) A LD, AF AF' EX, A INC, 3 CP, NZ 6 L# JP, 9 L: L SLA, H RL, C RL, CY 5 L# JP, 7 C BIT, Z 5 L# JP, 3 L# JP, 10 L: AF POP, AF AF' EX, A A ADD, A A ADD, A A ADD, A A ADD, A A ADD, A A ADD, GUARD ) A LD, L -1 +IX) LD, H -2 +IX) LD, E -3 +IX) LD, D -4 +IX) LD, ' NORM 7 + JP, END-CODE CODE F/ ' (F/) CALL, ' ROUND CALL, NEXT JP, END-CODE AF AF' EX, A L LD, HL POP, DE POP, BC POP, AF AF' EX, 3 L: AF AF' EX, L SLA, H RL, A RL, C RL, B RL, E RL, D RL, AF AF' EX, A DEC, NZ 3 L# JP, GUARD ) A LD, BC PUSH, DE PUSH, HL PUSH, H A LD, AF AF' EX, L A LD, HL PUSH, EXX, ' NORM CALL, A XOR, 5 L# JP, 4 L: HL PUSH, EXX, 5 L: H 0 LD, L A LD, HL PUSH, HL RSAVE 2+ ) LD, (HL) JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE FIT A XOR, FSTAT ) A LD, ' (FIT) CALL, NEXT JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE NORMAL A XOR, GUARD ) A LD, ' NORM CALL, NEXT JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE .FR EXX, HL POP, RSAVE 2+ ) HL LD, A XOR, B 18 LD, 1 L: (HL) A LD, HL INC, 1 L# DJNZ, DE POP, A D LD, RLA, A SRA, NEG, DE PUSH, ' DENORM CALL, DE POP, HL POP, B 18 LD, 2 L: E SRL, H RR, L RR, C 0 LD, IX RSAVE 2+ ) LD, AF AF' EX, 3 L: AF AF' EX, A 0 LD, NCY 4 L# JP, CCF, A BASE ) LD, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE FABS HL POP, 7 H RES, HL PUSH, NEXT JP, END-CODE CODE (EXP) ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE (F<) IX POP, EXX, BC POP, DE POP, HL POP, A H LD, B XOR, P 1 L# JP, A H LD, RLCA, 1 AND, HL PUSH, EXX, (IX) JP, 1 L: A H LD, AF AF' EX, A B LD, FTEMP ) A LD, A SLA, H SLA, H SUB, PO 2 L# JP, 80 XOR, : 2BASE BASE @ 1800 NORMAL ; : FNEGATE 8000 XOR ; : FLOAT ( D# --- F# ) DUP >R DABS >R 1800 NORMAL R> 2800 NORMAL F+ R> 0< IF FNEGATE THEN ; 4 L: A 0 +IX) ADD, A SRL, 0 +IX) A LD, C INC, IX INC, AF AF' EX, A C LD, 18 XOR, NZ 3 L# JP, 2 L# DJNZ, C DEC, IX DEC, 5 L: A 0 +IX) LD, 0A CP, CY 6 L# JP, A 7 ADD, 6 L: A 30 ADD, 0 +IX) A LD, IX DEC, C DEC, P 5 L# JP, EXX, NEXT JP, END-CODE HL POP, HL PUSH, A H LD, RLA, A SRA, L A LD, RLA, A A SBC, H A LD, HL PUSH, NEXT JP, END-CODE 2 L: A SLA, B L LD, HL POP, Z 3 L# JP, CCF, 4 L# JP, 3 L: A B LD, C CP, NZ 4 L# JP, A H LD, D CP, NZ 4 L# JP, A L LD, E CP, 4 L: E RR, A FTEMP ) LD, E XOR, AF AF' EX, HL PUSH, H A LD, L B LD, HL PUSH, AF AF' EX, RLCA, 1 AND, EXX, (IX) JP, END-CODE ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) CODE F< ' (F<) CALL, HL POP, HL POP, H 0 LD, L A LD, ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) TABLE A[N] ( USED BY ARCTAN ) 0000 , 4000 , 0A92 , 0086 , 0FDB , 01C9 , 0A92 , 0186 , : .5 0 0080 ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : 2ROT 6 ROLL 6 ROLL ; : 2CONSTANT CREATE , , DOES> 2@ ; : 2VARIABLE CREATE 4 ALLOT ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : FVAL ( STR --- F# ) >R PAD 1+ R@ CMOVE 0 PAD 1+ R> + C! 0. PAD 1+ C@ >R PAD CONVERT >R DABS FLOAT R> DUP C@ ASCII . = ( FRACTION? ) IF DUP 1+ >R 0. ROT CONVERT >R FLOAT R> R> OVER >R - ( #DIGITS ) 0 DO 2BASE F/ LOOP F+ R> ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : F/EXP (EXP) >R HILO DROP R> ; : FIXED ( FN# --- DN# ) 0 0 2SWAP DUP >R FABS FIT 2 = IF 2DROP -1 3FFF 2SWAP FSTAT @ 2 OR FSTAT ! HL PUSH, NEXT JP, END-CODE : 1.0 0 0180 ; : ASCII ( --- C ) BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : +SIGN 0< IF ASCII - HOLD ELSE BL HOLD THEN ; THEN DUP C@ 5E ( ^ ) = ( EXPONENT? ) IF 0. ROT CONVERT >R 0< IF ABS 0 DO 2BASE F/ LOOP ELSE ?DUP IF 0 DO 2BASE F* LOOP THEN THEN R> THEN C@ BL OR BL - 0 ?ERROR R> ASCII - = IF FNEGATE THEN ; : REAL ( --- ) BL WORD COUNT FVAL [COMPILE] DLITERAL ; IMMEDIATE THEN 2DROP R> 0< IF DNEGATE THEN ; : FERROR FSTAT C@ OR FSTAT C! ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : FSTR$ ( FN# FRAC-WIDTH --- STR ) >R DUP >R ( SAVE WIDTH, SIGN ) <# -18 HLD +! HLD @ 1- >R ( ^DPL) 0 0 2SWAP FABS FIT DUP 4 = ( UNFLO? ) IF BEGIN WHILE ASCII 0 HOLD 2BASE F* FIT REPEAT ASCII . HOLD R> HLD @ >R 1+ DUP HLD ! .FR #S R@ HLD ! ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : ESTR$ ( FN# FRAC-WIDTH --- STR ) OVER >R >R 0 >R 0 0 2SWAP DUP ( <>0? ) IF FABS BEGIN 2DUP 2BASE F< 0= WHILE R> 1+ >R 2BASE F/ REPEAT BEGIN (EXP) 0> 0= WHILE R> 1- >R 2BASE F* REPEAT THEN FIT DROP <# PAD .FR R@ ABS 0 # #S 2DROP R> +SIGN ASCII ^ HOLD ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : LN ( FN# --- LN-OF-FN# ) DUP 0> 0= ( ARG <= 0? ) IF 8 FERROR 2DROP FFFF BFFF ( -FBIG ) EXIT THEN F/EXP >R 2DUP 04F3 00B5 F< IF R> 1- >R 007F AND NORMAL 2DUP ELSE 2DUP 007F AND NORMAL .5 F- 2SWAP ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : EXP ( FN# --- EXP-OF-FN# ) 2DUP AC00 06AE F< 0= ( EXCEPTIONS ) IF 18 FERROR 2DROP FFFF 3FFF ( FBIG ) EXIT THEN 2DUP 0000 86C0 F< IF 18 FERROR 2DROP 0 0 ( FZERO ) EXIT THEN 2DUP FABS 0 6880 ( EPSILON ) F< IF 2DROP 1.0 ( FONE ) EXIT THEN ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : (COS) ( FNX FNY SIGN --- COSINE ) >R ( SIGN ) 2DUP 0C00 0EC9 F< 0= IF 2 FERROR 2DROP 2DROP 0 0 R> DROP EXIT THEN F984 7FA2 F* .5 F+ FIXED OVER 1 AND ( ODD? ) IF R> NEGATE >R THEN ( CHANGE SIGN ) FLOAT R@ ABS 1 > ( COSINE? ) IF .5 F- THEN ELSE ?DUP ( OVFLO? ) IF BEGIN WHILE R> 1+ >R 2BASE F/ FIT REPEAT THEN HLD @ .FR HLD @ DUP 1- DUP HLD ! R@ OVER - CMOVE ASCII . R@ C! #S THEN R> R> SIGN HLD @ - R@ 0> R> + + >R #> DROP R> ; : F.R >R FSTR$ R> OVER - SPACES TYPE ; R@ NEGATE HLD +! PAD HLD @ R> CMOVE ASCII . HOLD #S R> SIGN #> ; : E.R >R ESTR$ R> OVER - SPACES TYPE ; : F. 2 0 F.R SPACE ; : E. 5 0 E.R SPACE ; : G. (EXP) DUP 0< SWAP BL < NOT OR IF 5 ESTR$ ELSE 2 FSTR$ THEN TYPE SPACE ; THEN .5 F* .5 F+ F/ ( Z ) 2DUP 2DUP 2DUP F* ( W ) 7E3B 808D 2OVER 3F3A 83D4 F+ F/ F* F* F+ ( R ) R> S->D FLOAT 2DUP 8000 00B1 F* 2SWAP 8063 F4DE F* F+ F+ ; 2DUP AA3B 01B8 F* FIXED OVER >R ( N ) FLOAT 2SWAP 2OVER 8000 00B1 F* F- 2SWAP 8063 F4DE F* F- 2DUP 2DUP F* 2SWAP 2OVER 5308 7988 F* 0 7F80 F+ F* 2SWAP BF5A 7CCC F* .5 F+ 2OVER F- F/ .5 F+ (EXP) R> 1+ + 7F AND SQUISH ; 2SWAP FABS 2OVER 0 02C9 F* F- 2SWAP AA22 76FD F* F- 2DUP FABS 0 7580 F< 0= ( ABS F < EPSILON? ) IF 2DUP 2DUP F* 9C5A 6EAE 2OVER F* B223 F4CF F+ 2OVER F* 873E 7A88 F+ 2OVER F* AAA0 FEAA F+ F* 2OVER F* F+ THEN R> 0< IF FNEGATE THEN ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : SIN ( FN# --- SIN ) 2DUP DUP 0< IF FNEGATE -1 ELSE 1 THEN (COS) ; : COS ( FN# --- COS ) 2DUP FABS 0FDB 01C9 F+ 2 (COS) ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : TAN ( FN# --- TAN ) 2DUP FABS 0FD7 0DC9 F< 0= IF 18 FERROR 2DROP 0 0 EXIT THEN 2DUP F984 00A2 F* FIXED OVER >R FLOAT 2SWAP 2OVER 0 01C9 F* F- 2SWAP AA22 75FD F* F- 2DUP FABS 0 7580 F< ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : ARCTAN ( FN# --- ARCTAN ) DUP >R FABS 2DUP 1.0 F< IF 0 >R ELSE 1.0 2SWAP F/ 2 >R THEN 2DUP 30A2 7F89 F< 0= IF R> 1+ >R 2DUP 67AE 00BB F* 0 0180 F- 2OVER F+ 2SWAP B3D7 01DD F+ F/ ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : SQRT ( FN# --- SQRT-OF-FN# ) DUP 0< IF 8 FERROR FABS THEN DUP IF F/EXP >R 2DUP 14BA 0097 F* A9A8 7FD5 F+ ( Y0 ) 2OVER 2OVER F/ F+ 2SWAP 2OVER F/ 2SWAP F/EXP 2- SQUISH FABS F+ ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) DECIMAL REAL 3.1415927 2CONSTANT PI PI .5 F* 2CONSTANT PI/2 PI/2 .5 F* 2CONSTANT PI/4 : FSGN ( FN1 --- FN2 ) DUP 0< IF 1.0 2SWAP ELSE 2DUP >R >R 2DUP F* 2DUP 3374 7A9F F* B7B0 FFDB F+ 2OVER F* 1.0 F+ 2SWAP R> R> 2SWAP 2OVER 33B8 FDC4 F* F* F+ THEN R> 1 AND ( ODD? ) IF FNEGATE ELSE 2SWAP THEN F/ ; THEN 2DUP FABS 0 7580 F< 0= IF 2DUP 2DUP F* 2DUP 2DUP 8690 FCD0 F* 10F6 FFF1 F+ F* 2SWAP CCD6 01B4 F+ F/ 2OVER F* F+ THEN R@ 1 > IF FNEGATE THEN R@ 2* A[N] R> 2* 1+ A[N] F+ R> 0< IF FNEGATE THEN ; R@ 1 AND ( N ODD? ) IF 04F3 00B5 F* R> 1+ >R THEN R> 2/ >R F/EXP R> + SQUISH FABS THEN ; : F** ( FN# FN#-POWER --- FN#**POWER ) 2SWAP LN F* EXP ; IF 2DROP REAL -1 ELSE OR IF REAL 1 ELSE 0 0 THEN THEN ; : DEG->RAD ( F1 --- F2 ) ( CONVERT DEGREES TO RADIANS ) REAL .01745329 F* ; : RAD->DEG ( F1 --- F2 ) ( CONVERT RADIANS TO DEGREES ) REAL 57.29578 F* ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : CSC ( FN1 --- FN2 ) ( COSECANT ) SIN REAL 1 2SWAP F/ ; : SEC ( FN1 --- FN2 ) ( SECANT ) COS REAL 1 2SWAP F/ ; : COT ( FN1 --- FN2 ) ( COTANGENT ) TAN REAL 1 2SWAP F/ ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : ARCCOS ( FN1 --- FN2 ) ( INVERSE COSINE ) 2DUP OR 0= OVER 0< 2* 2* + >R REAL 1 2OVER 2DUP F* F- SQRT 2SWAP 2DUP OR 0= 0 FLOAT F+ F/ ARCTAN R> 0 FLOAT PI/4 F* F+ ; : ARCSIN ( FN1 --- FN2 ) ( INVERSE SINE ) ARCCOS FNEGATE PI/2 F+ ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : EUEU- 2DUP EXP 2SWAP FNEGATE EXP ; : SINH ( FN1 --- FN2 ) ( HYPERBOLIC SINE ) EUEU- F- .5 F* ; : COSH ( FN1 --- FN2 ) ( HYPERBOLIC COSINE ) EUEU- F+ .5 F* ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : ARCSINH ( FN1 --- FN2 ) ( INVERSE HYPERBOLIC SINE ) 2DUP 2DUP F* 1.0 F+ SQRT F+ LN ; : ARCCOSH ( FN1 --- FN2 ) ( INVERSE HYPERBOLIC COSINE ) 2DUP 2DUP F* 1.0 F- SQRT F+ LN ; : ARCTANH ( FN1 --- FN2 ) ( INVERSE HYPERBOLIC TANGENT ) 2DUP 1.0 F+ 2OVER 1.0 2SWAP F- F/ LN .5 F* ; ( FLOATING POINT COPYRIGHT 1982 MICROMOTION 19 JAN 82 ) : 2, ( N --- ) , , ; : 2TABLE ( --- ) CREATE DOES> ( N --- ) SWAP 2* 2* + 2@ ; : 2ARRAY ( N --- ) : ARCCSC ( FN1 --- FN2 ) ( INVERSE COSECANT ) 2DUP 2DUP F* 1.0 F- SQRT 1.0 2SWAP F/ ARCTAN 2SWAP FSGN 1.0 F- PI/2 F* F+ ; : ARCSEC ( FN1 --- FN2 ) ( INVERSE SECANT ) 2DUP 2DUP F* 1.0 F- SQRT ARCTAN 2SWAP FSGN 1.0 F- PI/2 F* F+ ; : ARCCOT ( FN1 --- FN2 ) ( INVERSE TANGENT ) ARCTAN FNEGATE PI/2 F+ ; : TANH ( FN1 --- FN2 ) ( HYPERBOLIC TANGENT ) EUEU- 2OVER 2OVER F+ >R >R F- R> R> F/ ; : CSCH ( FN1 --- FN2 ) ( HYPERBOLIC COSECANT ) EUEU- F- REAL 2 2SWAP F/ ; : SECH ( FN1 --- FN2 ) ( HYPERBOLIC SECANT ) EUEU- F+ REAL 2 2SWAP F/ ; : COTH ( FN1 --- FN2 ) ( HYPERBOLIC COTANGENT ) EUEU- 2OVER 2OVER F- >R >R F+ R> R> F/ ; : ARCCSCH ( FN1 --- FN2 ) ( INVERSE HYPERBOLIC COSECANT ) 2DUP 2DUP F* 1.0 F+ SQRT 2OVER FSGN F* 1.0 F+ 2SWAP F/ LN ; : ARCSECH ( FN1 --- FN2 ) ( INVERSE HYPERBOLIC SECANT ) 1.0 2OVER 2DUP F* F- SQRT 1.0 F+ 2SWAP F/ LN ; : ARCCOTH ( FN1 --- FN2 ) ( INVERSE HYPERBOLIC COTANGENT ) 2DUP 1.0 F+ 2OVER 1.0 F- F/ LN .5 F* ; CREATE 0 DO 0. 2, LOOP DOES> ( N --- ) SWAP 2* 2* + ; : 2D2ARRAY ( N1 N2 --- ) CREATE DUP 2* 2* , U* DROP 0 DO 0. 2, LOOP DOES> ( N1 N2 --- ) ROT OVER @ U* DROP + SWAP 2* 2* + ;