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 >
Text File  |  1984-04-29  |  11KB  |  309 lines
  1.  
  2.  
  3.  
  4. % ***************************************************************************
  5. % ** COPYRIGHT (C) MASSACHUSETTS INSTITUTE OF TECHNOLOGY AND HARVARD       **
  6. % ** UNIVERSITY, BIOMEDICAL ENGINEERING CENTER 1977.  ALL RIGHTS RESERVED. **
  7. % ***************************************************************************
  8.  
  9. % 8080 FLOATING POINT PACKAGE
  10. % J. SACHS 3/3/77
  11.  
  12. RADIX @ OCTAL
  13.  
  14. % FLOATING COMPARISONS WITH 0.0
  15. 'FLTZ CODE<  H POP,  D POP,  .  H A MOV,  A ORA,  -1PUSH JM,  0PUSH JMP,  >
  16. 'FLEZ CODE<  H POP,  D POP,  D A MOV,  E ORA,  -1PUSH JZ,  JMP,  >
  17. 'FGEZ CODE<  H POP,  D POP,  .  H A MOV,  A ORA,  -1PUSH JP,  0PUSH JMP,  >
  18. 'FGTZ CODE<  H POP,  D POP,  D A MOV,  E ORA,  0PUSH JZ,  JMP,  >
  19. 'FEQZ CODE<  H POP,  D POP,  D A MOV,  E ORA,  -1PUSH JZ,  0PUSH JMP,  >
  20. 'FNEZ CODE<  H POP,  D POP,  D A MOV,  E ORA,  -1PUSH JNZ,  0PUSH JMP,  >
  21.  
  22. % FLOATING LITERAL
  23. 'F() CODE<  .I LHLD,  H INX,  H INX,  M C MOV,  H INX,  M B MOV,  H INX,
  24.   .I SHLD,  M E MOV,  H INX,  M D MOV,  D PUSH,  B PUSH,  NEXT JMP,  >
  25.  
  26. % FLOATING STORE
  27. 'F! CODE<  H POP, . .  D POP,  E M MOV,  H INX,  D M MOV,  D POP,  H INX,
  28.   E M MOV,  H INX,  D M MOV,  NEXT JMP,  >
  29.  
  30. % STORE TOP-1,TOP AT TOP-5,TOP-4
  31. 'D2UNDER CODE<  10 H LXI,  SP DAD,  JMP,  >
  32.  
  33. % STORE TOP-1,TOP AT TOP-7,TOP-6
  34. 'D3UNDER CODE<  14 H LXI,  SP DAD,  JMP,  >
  35.  
  36. % FLOATING LOAD
  37. 'F@ CODE<  H POP,  . . .  M C MOV,  H INX,  M B MOV,  H INX,  M E MOV,
  38.   H INX,  M D MOV,  D PUSH,  B PUSH,  NEXT JMP,  >
  39.  
  40. % FLOATING DEFINE CONSTANT
  41. 'FCONSTANT : CONSTANT , ;CODE<  XCHG,  JMP,  >
  42.  
  43. % LOAD COPY OF TOP-3,TOP-2
  44. 'D2OVER CODE<  10 H LXI,  SP DAD,  JMP,  >
  45.  
  46. % LOAD COPY OF TOP-5,TOP-4
  47. 'D3OVER CODE<  14 H LXI,  SP DAD,  JMP,  >
  48.  
  49. % FLOATING DEFINE VARIABLE
  50. 'FVARIABLE : VARIABLE , ;
  51.  
  52. % FLOATING NEGATE
  53. 'FMINUS CODE<  H POP,  H A MOV,  200 XRI,  A H MOV,  PUSH JMP,  >
  54.  
  55. % FLOATING ABSOLUTE VALUE
  56. 'FABS CODE<  H POP,  0 H MVI,  PUSH JMP,  >
  57.  
  58. % PUSH H, PUSH B, AND RETURN
  59. . ASSEMBLER<
  60.   H PUSH,  B PUSH,  T1 4 + LHLD,  PCHL,  >
  61. 'FRET CONSTANT
  62.  
  63. % NORMALIZE EXIT
  64. . ASSEMBLER<
  65.   H A MOV,  L ORA,  IFZ,  H A MOV,  . <L  A ORA,  IFM,  E A MOV,  RAL,
  66.   A E MOV,  D A MOV,  RAL,  A D MOV,  L A MOV,  RAL,  A L MOV,  H A MOV,
  67.   RAL,  A H MOV,  C DCR,  L> JMP,  THEN,  D A MOV,  A ORA,  FRET JP,  H INX,
  68.   H A MOV,  L ORA,  FRET JNZ,  100000 H LXI,  C INR,  FRET JMP,  THEN,
  69.   0 B LXI,  FRET JMP,  >
  70. 'NORM CONSTANT
  71.  
  72. % CONVERT FROM INTERGER TO FLOATING POINT
  73. . ASSEMBLER<
  74.   H POP,  T1 4 + SHLD,  H POP,  H A MOV,  A ORA,  0 B MVI,  IFP,  200 B MVI,
  75.   -HL CALL,  THEN,  20 C MVI,  0 D LXI,  NORM JMP,  >
  76. '(FLOAT) CONSTANT
  77.  
  78. 'FLOAT CODE<  (FLOAT) CALL,  NEXT JMP,  >
  79.  
  80. % RETURN FRACTION PART
  81. . ASSEMBLER<
  82.   H POP,  T1 4 + SHLD,  B POP,  H POP, C A MOV,  1 CPI,  FRET JM,  20 CPI,
  83.   IFP,  .  A ORA,  L A MOV,  RAL,  A L MOV,  H A MOV,  RAL,  A H MOV,
  84.   C DCR,  JNZ,  NORM JMP,  THEN,  0 H LXI,  0 B LXI,  FRET JMP,  >
  85. '(FRAC) CONSTANT
  86.  
  87. 'FRAC CODE<  (FRAC) CALL,  NEXT JMP,  >
  88.  
  89. % CONVERT FROM FLOATING POINT TO INTEGER
  90. . <L  "INT OVERFLOW" S,
  91. . ASSEMBLER<
  92.   H POP,  T1 4 + SHLD,  D POP,  H POP,  E A MOV,  1 CPI,  IFM,  20 CPI,
  93.   IFP,  20 A MVI,  E SUB,  A E MOV,  .  A ORA,  H A MOV,  RAR,  A H MOV,
  94.   L A MOV,  RAR,  A L MOV,  E DCR,  JNZ,  D A MOV,  A ORA,  -HL CM,
  95.   H PUSH,  T1 4 + LHLD,  PCHL,  THEN,  L> H LXI,  ERROR JMP,  THEN,
  96.   0 H LXI,  H PUSH,  T1 4 + LHLD,  PCHL,  >
  97. '(INTEGER) CONSTANT
  98.  
  99. 'INTEGER CODE<  (INTEGER) CALL,  NEXT JMP,  >
  100.  
  101. % FLOATING MULTIPLY
  102. . ASSEMBLER<
  103.   H POP,  T1 4 + SHLD,  H POP,  T1 2 + SHLD,  D POP,  H POP,  T1 SHLD,
  104.   H POP,  MUL CALL,  T1 LDA,  A C MOV,  T1 2 + LDA,  C ADD,  A C MOV,
  105.   T1 1+ LDA,  A B MOV,  T1 3 + LDA,  B XRA,  A B MOV,  NORM JMP,  >
  106. '(F*) CONSTANT
  107.  
  108. 'F* CODE<  (F*) CALL,  NEXT JMP,  >
  109.  
  110. % FLOATING DIVIDE
  111. . <L  "ZERO DIVIDE" S,
  112. . ASSEMBLER<
  113.   H POP,  T1 4 + SHLD,  H POP,  T1 2 + SHLD,  B POP,  H POP,  T1 SHLD,  H POP,
  114.   B A MOV,  C ORA,  IFZ,  0 D LXI,  H A MOV,  A ORA,  RAR,  A H MOV,
  115.   L A MOV,  RAR,  A L MOV,  D A MOV,  RAR,  A D MOV,  B PUSH,  DIV CALL,
  116.   B POP,  D PUSH,  0 D LXI,  DIV CALL,  H POP,  T1 2+ LDA,  A C MOV,
  117.   T1 LDA,  C SUB,  A INR,  A C MOV,  T1 1+ LDA,  A B MOV,  T1 3 + LDA,
  118.   B XRA,  A B MOV,  NORM JMP,  THEN,  L> H LXI,  ERROR JMP,  >
  119. '(F/) CONSTANT
  120.  
  121. 'F/ CODE<  (F/) CALL,  NEXT JMP,  >
  122.  
  123. % FLOATING ADD
  124. . ASSEMBLER<
  125.   H POP,  T1 4 + SHLD,  H POP,  T1 2 + SHLD,  D POP,  H POP,  T1 SHLD,
  126.   H POP,  H A MOV,  L ORA,  IFZ,  D A MOV,  E ORA,  IFZ,  . <L  T1 LDA,
  127.   A C MOV,  T1 2 + LDA,  C SUB,  IFZ,  IFM,  XCHG,  T1 2 + LDA,  A B MOV,
  128.   T1 LDA,  T1 2 + STA,  B A MOV,  T1 STA,  T1 3 + LDA,  A B MOV,  T1 1+ LDA,
  129.   T1 3 + STA,  B A MOV,  T1 1+ STA,  L> JMP,  THEN,  20 CPI,  IFP,  A B MOV,
  130.   .  A ORA,  D A MOV,  RAR,  A D MOV,  E A MOV,  RAR,  A E MOV,  B INR,  JNZ,
  131.   IFNC,  D INX,  THEN,  SWAP THEN,  T1 1+ LDA,  A B MOV,  T1 3 + LDA,
  132.   B CMP,  IFNZ,  D DAD,  FRET JNC,  H A MOV,  RAR,  A H MOV,  L A MOV,  RAR,
  133.   A L MOV,  IFNC,  H INX,  THEN,  C INR,  FRET JMP,  THEN,  A ORA,  IFM,
  134.   XCHG,  THEN,  L A MOV,  E SUB,  A L MOV,  H A MOV,  D SBB,  A H MOV,
  135.   IFNC,  200 B MVI,  -HL CALL,  ELSE,  0 B MVI,  THEN,  0 D LXI,  NORM JMP,
  136.   THEN,  THEN,  XCHG,  T1 LHLD,  . <L  H B MOV,  L C MOV,  XCHG,  FRET JMP,
  137.   THEN,  T1 2 + LHLD,  L> JMP,  >
  138. '(F+) CONSTANT
  139.  
  140. 'F+ CODE<  (F+) CALL,  NEXT JMP,  >
  141.  
  142. % FLOATING SUBTRACT
  143. . ASSEMBLER<
  144.   H POP,  T1 4 + SHLD,  H POP,  H A MOV,  200 XRI,  A H MOV,  (F+) 5 + JMP,  >
  145. '(F-) CONSTANT
  146.  
  147. 'F- CODE<  (F-) CALL,  NEXT JMP,  >
  148.  
  149. % FLOATING COMPARISONS
  150. 'FLT : F- FLTZ ;
  151. 'FLE : F- FLEZ ;
  152. 'FGT : F- FGTZ ;
  153. 'FGE : F- FGEZ ;
  154. 'FEQ : F- FEQZ ;
  155. 'FNE : F- FNEZ ;
  156.  
  157. % FLOATING MOD OPERATOR
  158. 'FMOD : DSWAP DOVER F/ FRAC F* ;
  159.  
  160. % FLOATING ADD TO MEMORY
  161. 'F+! : DUP <L F@ F+ L> F! ;
  162.  
  163. % FLOATING LITERAL PROCESSOR
  164. . ASSEMBLER<
  165.   T1 6 + LHLD,  M A MOV,  H INX,  T1 6 + SHLD,  RET,  >
  166. 'LITG CONSTANT
  167.  
  168. 'FLITERAL CODE<
  169.   H POP,  H INX,  T1 6 + SHLD,  0 H LXI,  T1 10 + SHLD,  T1 12 + SHLD,
  170.   T1 14 + SHLD,  T1 20 + SHLD,  H PUSH,  H PUSH,  LITG CALL,  53 CPI,
  171.   IFZ,  55 CPI,  IFNZ,  -1 H LXI,  T1 10 + SHLD,  . <L . <L . <L  SWAP THEN,
  172.   LITG CALL,  THEN,  56 CPI,  IFNZ,  -1 H LXI,  T1 20 + SHLD,  L> JMP,
  173.   THEN,  A ORA,  IFZ,  105 CPI,  IFZ,  60 CPI,  IFM,  72 CPI,  IFP,  60 SUI,
  174.   A L MOV,  0 H MVI,  T1 16 + SHLD,  120000 H LXI,  H PUSH,  4 H LXI,
  175.   H PUSH,  (F*) CALL,  T1 16 + LHLD,  H PUSH,  (FLOAT) CALL,  (F+) CALL,
  176.   T1 20 + LHLD,  H A MOV,  L ORA,  L> JZ,  T1 12 + LHLD,  H DCX,
  177.   T1 12 + SHLD,  L> JMP,  THEN,  THEN,  . <L . <L  H POP,  H POP,  0PUSH JMP,
  178.   THEN,  0 H LXI,  T1 16 + SHLD,  LITG CALL,  53 CPI,  IFZ,  55 CPI,  IFNZ,
  179.   -1 H LXI,  T1 14 + SHLD,  SWAP THEN,  . <L  LITG CALL,  THEN,  A ORA,
  180.   IFZ,  60 CPI,  L> L> JM,  72 CPI,  L> JP, <L  60 SUI,  PSW PUSH,
  181.   T1 16 + LHLD,  12 D LXI,  MUL CALL,  PSW POP,  A L MOV,  0 H MVI,  D DAD,
  182.   T1 16 + SHLD,  L> JMP,  THEN,  T1 16 + LHLD,  H PUSH,  T1 14 + LHLD,
  183.   H A MOV,  L ORA,  H POP,  -HL CM,  XCHG,  T1 12 + LHLD,  D DAD,
  184.   T1 12 + SHLD,  THEN,  T1 20 + LHLD,  H A MOV,  A ORA,  IFNZ,  H POP,
  185.   H POP,  0PUSH JMP,  THEN,  T1 12 + LHLD,  H A MOV,  A ORA,  IFM,  . <L
  186.   T1 12 + LHLD,  H A MOV,  L ORA,  IFZ,  H DCX,  T1 12 + SHLD,  120000 H LXI,
  187.   H PUSH,  4 H LXI,  H PUSH,  (F*) CALL,  L> JMP,  SWAP THEN,  . <L
  188.   T1 12 + LHLD,  H A MOV,  L ORA,  IFZ,  H INX,  T1 12 + SHLD,  120000 H LXI,
  189.   H PUSH,  4 H LXI,  H PUSH,  (F/) CALL,  L> JMP,  THEN, THEN,  T1 10 + LHLD,
  190.   H A MOV,  L ORA,  -1PUSH JZ,  H POP,  H A MOV,  200 XRI,  A H MOV,  H PUSH,
  191.   -1PUSH JMP,  >
  192.  
  193. % CAUSE COMPILER TO PROCESS FLOATING POINT LITERALS
  194. 'FLIT : // LIT @ C, // IF
  195.   -1 ELSE . FLITERAL IF () F() C, C, C, -1 ELSE 0 THEN THEN ;
  196. () FLIT LIT !
  197.  
  198. 3.14159 'PI FCONSTANT
  199.  
  200. % FLOATING POINT PRINT
  201. 0 'EXP VARIABLE
  202.  
  203. 'FSCL : 3 EXP !
  204.   BEGIN DDUP 10000.0 FGE IF EXP 1+! 10.0 F/ REPEAT
  205.   BEGIN DDUP  1000.0 FLT IF EXP 1-! 10.0 F* REPEAT
  206.   ;
  207.  
  208. 'FPRINT : RADIX @ <L DECIMAL
  209.   INTEGER <# # # # 56 #PUT # #> TYPE
  210.   105 TYO EXP @ DUP LTZ IF MINUS 55 ELSE 53 THEN TYO
  211.   <# # # #> TYPE SPACE
  212.   L> RADIX ! ;
  213.  
  214. 'F= : DDUP FEQZ IF 2DROP " 0.000E+00 " MSG ELSE
  215.   DDUP FLTZ IF FMINUS 55 ELSE 40 THEN TYO
  216.   FSCL FPRINT THEN ;
  217.  
  218. 'F? : F@ F= ;
  219.  
  220. % SQUARE ROOT
  221. 'GUESS CODE<  H POP,  D POP,
  222.   L A MOV,  RAL,  L A MOV,  RAR,  A L MOV,  CMC,
  223.   IFC,  L INR,  D A MOV,  RAR,  100 ADI,
  224.   ELSE,  D A MOV,  RAR,
  225.   THEN,  A D MOV,  E A MOV,  RAR,  A E MOV,  DPUSH JMP,  >
  226.  
  227. 'FSQRT : DUP LTZ IF "FSQRT ERROR" ERR THEN
  228.   DDUP FEQZ IF 0.0 ELSE
  229.   DDUP GUESS 3 ( DOVER DOVER F/ F+ 1- ) THEN DUNDER ;
  230.  
  231. % SINE AND COSINE
  232. 'FSIN4 : DDUP DDUP F* DDUP -0.004362469 F* 0.07948765 F+
  233.   DOVER F* -0.6459210 F+ F* 1.570795 F+ F* ;
  234.  
  235. 'FCOS : FABS 0.6366198 F* DDUP INTEGER 1+ DUP <L 1 AND IF
  236.   FRAC FMINUS 1.0 F+ ELSE FRAC THEN FSIN4 L> 2 AND IF FMINUS THEN ;
  237.  
  238. 'FSIN : 0.6366198 F* DDUP INTEGER DUP <L 1 AND IF
  239.   FRAC FMINUS 1.0 F+ ELSE FRAC THEN FSIN4 L> 2 AND IF FMINUS THEN ;
  240.  
  241. 'FSIN : DDUP FLTZ IF FMINUS FSIN FMINUS ELSE FSIN THEN ;
  242.  
  243. % INVERSE TANGENT
  244. 'FATAN : DDUP DDUP F* DDUP 0.0208351 F* -0.0851330 F+
  245.   DOVER F* 0.1801410 F+ DOVER F* -0.3302995 F+ F* 0.9998660 F+ F* ;
  246.  
  247. 'FATAN : DDUP 1.0 FGT IF 1.0 DSWAP F/ FATAN FMINUS
  248.   1.570796 F+ ELSE FATAN THEN ;
  249.  
  250. 'FATAN : DDUP FLTZ IF FMINUS FATAN FMINUS ELSE FATAN THEN ;
  251.  
  252. % EXTEND EXPONENT SIGN BIT TO HIGH ORDER BYTE
  253. 'EXTB7 CODE<  H POP,  L A MOV,  A ORA,  PUSH JP,  -1 H MVI,  PUSH JMP,  >
  254.  
  255. % LOG BASE 2
  256. 'FLOG2 : DDUP FLEZ IF "FLOG ERROR" ERR THEN
  257.   EXTB7 FLOAT -ROT 0
  258.   DDUP 3.84959 F* -1.42502 F+ DOVER F* -2.42459 F+ DSWAP
  259.   DDUP 2.84953 F+ DSWAP F* 0.499939 F+ F/ F+ ;
  260.  
  261. % LOG BASE E
  262. 'FLN : FLOG2 0.693147 F* ;
  263.  
  264. % LOG BASE 10
  265. 'FLOG10 : FLOG2 0.301030 F* ;
  266.  
  267. % 2.0**
  268. '2.0** : DDUP FRAC
  269.   DDUP 0.0135342 F* 0.0520115 F+ DOVER F* 0.241443 F+ DOVER F*
  270.   0.693004 F+ F* 1.00000 F+ DSWAP INTEGER 377 AND + ;
  271.  
  272. % EXPONENTIAL
  273. 'FEXP : 0.693147 F/ 2.0** ;
  274.  
  275. % 10.0**
  276. '10.0** : 0.301030 F/ 2.0** ;
  277.  
  278. % LINEAR LEAST SQUARES FIT
  279. 0.0 'S1 FVARIABLE
  280. 0.0 'S2 FVARIABLE
  281. 0.0 'S3 FVARIABLE
  282. 0.0 'S4 FVARIABLE
  283. 0.0 'DET FVARIABLE
  284. 0 'NPTS VARIABLE
  285.  
  286. '<LSQ : 0.0 S1 F! 0.0 S2 F! 0.0 S3 F! 0.0 S4 F! 0 NPTS ! ;
  287.  
  288. 'LSQ : DDUP S2 F+! DOVER F* S3 F+! DDUP S1 F+! DDUP F* S4 F+! NPTS 1+! ;
  289.  
  290. 'LSQ> : NPTS @ FLOAT S4 F@ F* S1 F@ DDUP F* F- DET F!
  291.   DET F@ FEQZ IF "LSQ ERROR" ERR THEN
  292.   S2 F@ S4 F@ F* S1 F@ S3 F@ F* F- DET F@ F/
  293.   NPTS @ FLOAT S3 F@ F* S1 F@ S2 F@ F* F- DET F@ F/ ;
  294.  
  295. % RANDOM NUMBER GENERATOR
  296. % RETURNS A NUMBER UNIFORMLY DISTRIBUTED BETWEEN 0.0 AND 1.0
  297. 32741 'FSEED VARIABLE
  298. 'FRAND CODE<  NEXT H LXI,  T1 4 + SHLD,  FSEED LHLD,  16345 D LXI,
  299.   MUL CALL,  XCHG,  FSEED SHLD,  0 B LXI,  NORM JMP,  >
  300.  
  301. RADIX !
  302. ;F
  303.  
  304.  
  305.  
  306. ***EOF***
  307.  
  308.  
  309.