home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
SIMTEL
/
CPMUG
/
CPMUG023.ARK
/
STOICFLT.STC
< prev
next >
Wrap
Text File
|
1984-04-29
|
11KB
|
309 lines
% ***************************************************************************
% ** COPYRIGHT (C) MASSACHUSETTS INSTITUTE OF TECHNOLOGY AND HARVARD **
% ** UNIVERSITY, BIOMEDICAL ENGINEERING CENTER 1977. ALL RIGHTS RESERVED. **
% ***************************************************************************
% 8080 FLOATING POINT PACKAGE
% J. SACHS 3/3/77
RADIX @ OCTAL
% FLOATING COMPARISONS WITH 0.0
'FLTZ CODE< H POP, D POP, . H A MOV, A ORA, -1PUSH JM, 0PUSH JMP, >
'FLEZ CODE< H POP, D POP, D A MOV, E ORA, -1PUSH JZ, JMP, >
'FGEZ CODE< H POP, D POP, . H A MOV, A ORA, -1PUSH JP, 0PUSH JMP, >
'FGTZ CODE< H POP, D POP, D A MOV, E ORA, 0PUSH JZ, JMP, >
'FEQZ CODE< H POP, D POP, D A MOV, E ORA, -1PUSH JZ, 0PUSH JMP, >
'FNEZ CODE< H POP, D POP, D A MOV, E ORA, -1PUSH JNZ, 0PUSH JMP, >
% FLOATING LITERAL
'F() CODE< .I LHLD, H INX, H INX, M C MOV, H INX, M B MOV, H INX,
.I SHLD, M E MOV, H INX, M D MOV, D PUSH, B PUSH, NEXT JMP, >
% FLOATING STORE
'F! CODE< H POP, . . D POP, E M MOV, H INX, D M MOV, D POP, H INX,
E M MOV, H INX, D M MOV, NEXT JMP, >
% STORE TOP-1,TOP AT TOP-5,TOP-4
'D2UNDER CODE< 10 H LXI, SP DAD, JMP, >
% STORE TOP-1,TOP AT TOP-7,TOP-6
'D3UNDER CODE< 14 H LXI, SP DAD, JMP, >
% FLOATING LOAD
'F@ CODE< H POP, . . . M C MOV, H INX, M B MOV, H INX, M E MOV,
H INX, M D MOV, D PUSH, B PUSH, NEXT JMP, >
% FLOATING DEFINE CONSTANT
'FCONSTANT : CONSTANT , ;CODE< XCHG, JMP, >
% LOAD COPY OF TOP-3,TOP-2
'D2OVER CODE< 10 H LXI, SP DAD, JMP, >
% LOAD COPY OF TOP-5,TOP-4
'D3OVER CODE< 14 H LXI, SP DAD, JMP, >
% FLOATING DEFINE VARIABLE
'FVARIABLE : VARIABLE , ;
% FLOATING NEGATE
'FMINUS CODE< H POP, H A MOV, 200 XRI, A H MOV, PUSH JMP, >
% FLOATING ABSOLUTE VALUE
'FABS CODE< H POP, 0 H MVI, PUSH JMP, >
% PUSH H, PUSH B, AND RETURN
. ASSEMBLER<
H PUSH, B PUSH, T1 4 + LHLD, PCHL, >
'FRET CONSTANT
% NORMALIZE EXIT
. ASSEMBLER<
H A MOV, L ORA, IFZ, H A MOV, . <L A ORA, IFM, E A MOV, RAL,
A E MOV, D A MOV, RAL, A D MOV, L A MOV, RAL, A L MOV, H A MOV,
RAL, A H MOV, C DCR, L> JMP, THEN, D A MOV, A ORA, FRET JP, H INX,
H A MOV, L ORA, FRET JNZ, 100000 H LXI, C INR, FRET JMP, THEN,
0 B LXI, FRET JMP, >
'NORM CONSTANT
% CONVERT FROM INTERGER TO FLOATING POINT
. ASSEMBLER<
H POP, T1 4 + SHLD, H POP, H A MOV, A ORA, 0 B MVI, IFP, 200 B MVI,
-HL CALL, THEN, 20 C MVI, 0 D LXI, NORM JMP, >
'(FLOAT) CONSTANT
'FLOAT CODE< (FLOAT) CALL, NEXT JMP, >
% RETURN FRACTION PART
. ASSEMBLER<
H POP, T1 4 + SHLD, B POP, H POP, C A MOV, 1 CPI, FRET JM, 20 CPI,
IFP, . A ORA, L A MOV, RAL, A L MOV, H A MOV, RAL, A H MOV,
C DCR, JNZ, NORM JMP, THEN, 0 H LXI, 0 B LXI, FRET JMP, >
'(FRAC) CONSTANT
'FRAC CODE< (FRAC) CALL, NEXT JMP, >
% CONVERT FROM FLOATING POINT TO INTEGER
. <L "INT OVERFLOW" S,
. ASSEMBLER<
H POP, T1 4 + SHLD, D POP, H POP, E A MOV, 1 CPI, IFM, 20 CPI,
IFP, 20 A MVI, E SUB, A E MOV, . A ORA, H A MOV, RAR, A H MOV,
L A MOV, RAR, A L MOV, E DCR, JNZ, D A MOV, A ORA, -HL CM,
H PUSH, T1 4 + LHLD, PCHL, THEN, L> H LXI, ERROR JMP, THEN,
0 H LXI, H PUSH, T1 4 + LHLD, PCHL, >
'(INTEGER) CONSTANT
'INTEGER CODE< (INTEGER) CALL, NEXT JMP, >
% FLOATING MULTIPLY
. ASSEMBLER<
H POP, T1 4 + SHLD, H POP, T1 2 + SHLD, D POP, H POP, T1 SHLD,
H POP, MUL CALL, T1 LDA, A C MOV, T1 2 + LDA, C ADD, A C MOV,
T1 1+ LDA, A B MOV, T1 3 + LDA, B XRA, A B MOV, NORM JMP, >
'(F*) CONSTANT
'F* CODE< (F*) CALL, NEXT JMP, >
% FLOATING DIVIDE
. <L "ZERO DIVIDE" S,
. ASSEMBLER<
H POP, T1 4 + SHLD, H POP, T1 2 + SHLD, B POP, H POP, T1 SHLD, H POP,
B A MOV, C ORA, IFZ, 0 D LXI, H A MOV, A ORA, RAR, A H MOV,
L A MOV, RAR, A L MOV, D A MOV, RAR, A D MOV, B PUSH, DIV CALL,
B POP, D PUSH, 0 D LXI, DIV CALL, H POP, T1 2+ LDA, A C MOV,
T1 LDA, C SUB, A INR, A C MOV, T1 1+ LDA, A B MOV, T1 3 + LDA,
B XRA, A B MOV, NORM JMP, THEN, L> H LXI, ERROR JMP, >
'(F/) CONSTANT
'F/ CODE< (F/) CALL, NEXT JMP, >
% FLOATING ADD
. ASSEMBLER<
H POP, T1 4 + SHLD, H POP, T1 2 + SHLD, D POP, H POP, T1 SHLD,
H POP, H A MOV, L ORA, IFZ, D A MOV, E ORA, IFZ, . <L T1 LDA,
A C MOV, T1 2 + LDA, C SUB, IFZ, IFM, XCHG, T1 2 + LDA, A B MOV,
T1 LDA, T1 2 + STA, B A MOV, T1 STA, T1 3 + LDA, A B MOV, T1 1+ LDA,
T1 3 + STA, B A MOV, T1 1+ STA, L> JMP, THEN, 20 CPI, IFP, A B MOV,
. A ORA, D A MOV, RAR, A D MOV, E A MOV, RAR, A E MOV, B INR, JNZ,
IFNC, D INX, THEN, SWAP THEN, T1 1+ LDA, A B MOV, T1 3 + LDA,
B CMP, IFNZ, D DAD, FRET JNC, H A MOV, RAR, A H MOV, L A MOV, RAR,
A L MOV, IFNC, H INX, THEN, C INR, FRET JMP, THEN, A ORA, IFM,
XCHG, THEN, L A MOV, E SUB, A L MOV, H A MOV, D SBB, A H MOV,
IFNC, 200 B MVI, -HL CALL, ELSE, 0 B MVI, THEN, 0 D LXI, NORM JMP,
THEN, THEN, XCHG, T1 LHLD, . <L H B MOV, L C MOV, XCHG, FRET JMP,
THEN, T1 2 + LHLD, L> JMP, >
'(F+) CONSTANT
'F+ CODE< (F+) CALL, NEXT JMP, >
% FLOATING SUBTRACT
. ASSEMBLER<
H POP, T1 4 + SHLD, H POP, H A MOV, 200 XRI, A H MOV, (F+) 5 + JMP, >
'(F-) CONSTANT
'F- CODE< (F-) CALL, NEXT JMP, >
% FLOATING COMPARISONS
'FLT : F- FLTZ ;
'FLE : F- FLEZ ;
'FGT : F- FGTZ ;
'FGE : F- FGEZ ;
'FEQ : F- FEQZ ;
'FNE : F- FNEZ ;
% FLOATING MOD OPERATOR
'FMOD : DSWAP DOVER F/ FRAC F* ;
% FLOATING ADD TO MEMORY
'F+! : DUP <L F@ F+ L> F! ;
% FLOATING LITERAL PROCESSOR
. ASSEMBLER<
T1 6 + LHLD, M A MOV, H INX, T1 6 + SHLD, RET, >
'LITG CONSTANT
'FLITERAL CODE<
H POP, H INX, T1 6 + SHLD, 0 H LXI, T1 10 + SHLD, T1 12 + SHLD,
T1 14 + SHLD, T1 20 + SHLD, H PUSH, H PUSH, LITG CALL, 53 CPI,
IFZ, 55 CPI, IFNZ, -1 H LXI, T1 10 + SHLD, . <L . <L . <L SWAP THEN,
LITG CALL, THEN, 56 CPI, IFNZ, -1 H LXI, T1 20 + SHLD, L> JMP,
THEN, A ORA, IFZ, 105 CPI, IFZ, 60 CPI, IFM, 72 CPI, IFP, 60 SUI,
A L MOV, 0 H MVI, T1 16 + SHLD, 120000 H LXI, H PUSH, 4 H LXI,
H PUSH, (F*) CALL, T1 16 + LHLD, H PUSH, (FLOAT) CALL, (F+) CALL,
T1 20 + LHLD, H A MOV, L ORA, L> JZ, T1 12 + LHLD, H DCX,
T1 12 + SHLD, L> JMP, THEN, THEN, . <L . <L H POP, H POP, 0PUSH JMP,
THEN, 0 H LXI, T1 16 + SHLD, LITG CALL, 53 CPI, IFZ, 55 CPI, IFNZ,
-1 H LXI, T1 14 + SHLD, SWAP THEN, . <L LITG CALL, THEN, A ORA,
IFZ, 60 CPI, L> L> JM, 72 CPI, L> JP, <L 60 SUI, PSW PUSH,
T1 16 + LHLD, 12 D LXI, MUL CALL, PSW POP, A L MOV, 0 H MVI, D DAD,
T1 16 + SHLD, L> JMP, THEN, T1 16 + LHLD, H PUSH, T1 14 + LHLD,
H A MOV, L ORA, H POP, -HL CM, XCHG, T1 12 + LHLD, D DAD,
T1 12 + SHLD, THEN, T1 20 + LHLD, H A MOV, A ORA, IFNZ, H POP,
H POP, 0PUSH JMP, THEN, T1 12 + LHLD, H A MOV, A ORA, IFM, . <L
T1 12 + LHLD, H A MOV, L ORA, IFZ, H DCX, T1 12 + SHLD, 120000 H LXI,
H PUSH, 4 H LXI, H PUSH, (F*) CALL, L> JMP, SWAP THEN, . <L
T1 12 + LHLD, H A MOV, L ORA, IFZ, H INX, T1 12 + SHLD, 120000 H LXI,
H PUSH, 4 H LXI, H PUSH, (F/) CALL, L> JMP, THEN, THEN, T1 10 + LHLD,
H A MOV, L ORA, -1PUSH JZ, H POP, H A MOV, 200 XRI, A H MOV, H PUSH,
-1PUSH JMP, >
% CAUSE COMPILER TO PROCESS FLOATING POINT LITERALS
'FLIT : // LIT @ C, // IF
-1 ELSE . FLITERAL IF () F() C, C, C, -1 ELSE 0 THEN THEN ;
() FLIT LIT !
3.14159 'PI FCONSTANT
% FLOATING POINT PRINT
0 'EXP VARIABLE
'FSCL : 3 EXP !
BEGIN DDUP 10000.0 FGE IF EXP 1+! 10.0 F/ REPEAT
BEGIN DDUP 1000.0 FLT IF EXP 1-! 10.0 F* REPEAT
;
'FPRINT : RADIX @ <L DECIMAL
INTEGER <# # # # 56 #PUT # #> TYPE
105 TYO EXP @ DUP LTZ IF MINUS 55 ELSE 53 THEN TYO
<# # # #> TYPE SPACE
L> RADIX ! ;
'F= : DDUP FEQZ IF 2DROP " 0.000E+00 " MSG ELSE
DDUP FLTZ IF FMINUS 55 ELSE 40 THEN TYO
FSCL FPRINT THEN ;
'F? : F@ F= ;
% SQUARE ROOT
'GUESS CODE< H POP, D POP,
L A MOV, RAL, L A MOV, RAR, A L MOV, CMC,
IFC, L INR, D A MOV, RAR, 100 ADI,
ELSE, D A MOV, RAR,
THEN, A D MOV, E A MOV, RAR, A E MOV, DPUSH JMP, >
'FSQRT : DUP LTZ IF "FSQRT ERROR" ERR THEN
DDUP FEQZ IF 0.0 ELSE
DDUP GUESS 3 ( DOVER DOVER F/ F+ 1- ) THEN DUNDER ;
% SINE AND COSINE
'FSIN4 : DDUP DDUP F* DDUP -0.004362469 F* 0.07948765 F+
DOVER F* -0.6459210 F+ F* 1.570795 F+ F* ;
'FCOS : FABS 0.6366198 F* DDUP INTEGER 1+ DUP <L 1 AND IF
FRAC FMINUS 1.0 F+ ELSE FRAC THEN FSIN4 L> 2 AND IF FMINUS THEN ;
'FSIN : 0.6366198 F* DDUP INTEGER DUP <L 1 AND IF
FRAC FMINUS 1.0 F+ ELSE FRAC THEN FSIN4 L> 2 AND IF FMINUS THEN ;
'FSIN : DDUP FLTZ IF FMINUS FSIN FMINUS ELSE FSIN THEN ;
% INVERSE TANGENT
'FATAN : DDUP DDUP F* DDUP 0.0208351 F* -0.0851330 F+
DOVER F* 0.1801410 F+ DOVER F* -0.3302995 F+ F* 0.9998660 F+ F* ;
'FATAN : DDUP 1.0 FGT IF 1.0 DSWAP F/ FATAN FMINUS
1.570796 F+ ELSE FATAN THEN ;
'FATAN : DDUP FLTZ IF FMINUS FATAN FMINUS ELSE FATAN THEN ;
% EXTEND EXPONENT SIGN BIT TO HIGH ORDER BYTE
'EXTB7 CODE< H POP, L A MOV, A ORA, PUSH JP, -1 H MVI, PUSH JMP, >
% LOG BASE 2
'FLOG2 : DDUP FLEZ IF "FLOG ERROR" ERR THEN
EXTB7 FLOAT -ROT 0
DDUP 3.84959 F* -1.42502 F+ DOVER F* -2.42459 F+ DSWAP
DDUP 2.84953 F+ DSWAP F* 0.499939 F+ F/ F+ ;
% LOG BASE E
'FLN : FLOG2 0.693147 F* ;
% LOG BASE 10
'FLOG10 : FLOG2 0.301030 F* ;
% 2.0**
'2.0** : DDUP FRAC
DDUP 0.0135342 F* 0.0520115 F+ DOVER F* 0.241443 F+ DOVER F*
0.693004 F+ F* 1.00000 F+ DSWAP INTEGER 377 AND + ;
% EXPONENTIAL
'FEXP : 0.693147 F/ 2.0** ;
% 10.0**
'10.0** : 0.301030 F/ 2.0** ;
% LINEAR LEAST SQUARES FIT
0.0 'S1 FVARIABLE
0.0 'S2 FVARIABLE
0.0 'S3 FVARIABLE
0.0 'S4 FVARIABLE
0.0 'DET FVARIABLE
0 'NPTS VARIABLE
'<LSQ : 0.0 S1 F! 0.0 S2 F! 0.0 S3 F! 0.0 S4 F! 0 NPTS ! ;
'LSQ : DDUP S2 F+! DOVER F* S3 F+! DDUP S1 F+! DDUP F* S4 F+! NPTS 1+! ;
'LSQ> : NPTS @ FLOAT S4 F@ F* S1 F@ DDUP F* F- DET F!
DET F@ FEQZ IF "LSQ ERROR" ERR THEN
S2 F@ S4 F@ F* S1 F@ S3 F@ F* F- DET F@ F/
NPTS @ FLOAT S3 F@ F* S1 F@ S2 F@ F* F- DET F@ F/ ;
% RANDOM NUMBER GENERATOR
% RETURNS A NUMBER UNIFORMLY DISTRIBUTED BETWEEN 0.0 AND 1.0
32741 'FSEED VARIABLE
'FRAND CODE< NEXT H LXI, T1 4 + SHLD, FSEED LHLD, 16345 D LXI,
MUL CALL, XCHG, FSEED SHLD, 0 B LXI, NORM JMP, >
RADIX !
;F
***EOF***