double.f

   1 \\r
   2 \ DOUBLE.F\r
   3 \ Double wordset words for hForth\r
   4 \\r
   5 \ Worning: Not fully tested yet. Maybe contains some bugs.\r
   6 \\r
   7 \ 1997. 2. 28.\r
   8 \       Facelift to be used with other CPUs.\r
   9 \ 1996. 7. 19.\r
  10 \       Fix 'M+'. Thanks M. Edward Borasky.\r
  11 \r
  12 BASE @\r
  13 CHAR " PARSE model" ENVIRONMENT? DROP\r
  14 CHAR " PARSE ROM Model" COMPARE 0=\r
  15 [IF] RAM/ROM@ [THEN]\r
  16 GET-ORDER  GET-CURRENT\r
  17 \r
  18 FORTH-WORDLIST SET-CURRENT\r
  19 \r
  20 \   2LITERAL    Compilation: ( x1 x2 -- )       \ DOUBLE\r
  21 \               Run-time: ( -- x1 x2 )\r
  22 \               Append the run-time semantics below to the current definition.\r
  23 \               On run-time, place cell pair x1 x2 on the stack.\r
  24 : 2LITERAL   SWAP POSTPONE LITERAL POSTPONE LITERAL ; IMMEDIATE COMPILE-ONLY\r
  25 \r
  26 \   2CONSTANT   ( x1 x2 '<spaces>name' -- )     \ DOUBLE\r
  27 \               name Execution: ( -- x1 x2 )\r
  28 \               Create a definition for name with the execution semantics.\r
  29 CHAR " PARSE model" ENVIRONMENT? DROP\r
  30 CHAR " PARSE ROM Model" COMPARE 0=\r
  31 CHAR " PARSE model" ENVIRONMENT? DROP\r
  32 CHAR " PARSE RAM Model" COMPARE 0= OR\r
  33 [IF]\r
  34   CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  35   [IF]\r
  36     : 2CONSTANT   CREATE SWAP , , DOES> DUP @ SWAP CELL+ @ ;\r
  37   [ELSE] DROP\r
  38     : 2CONSTANT   CREATE SWAP , , DOES>\r
  39                   ;CODE\r
  40                     0 [BX] PUSH,\r
  41                     1 CELLS [BX] BX MOV,\r
  42                     NEXT,\r
  43                   END-CODE\r
  44   [THEN]\r
  45 [THEN]\r
  46 CHAR " PARSE model" ENVIRONMENT? DROP\r
  47 CHAR " PARSE EXE Model" COMPARE 0=\r
  48 [IF]\r
  49   :NONAME   EXECUTE POSTPONE 2LITERAL ;\r
  50   CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  51   [IF]\r
  52     : 2CONSTANT   CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
  53   [ELSE] DROP\r
  54     : 2CONSTANT   CREATE SWAP , , compiles> DOES>\r
  55                   ;CODE\r
  56                     0 [BX] PUSH,\r
  57                     1 CELLS [BX] BX MOV,\r
  58                     NEXT,\r
  59                   END-CODE\r
  60   [THEN]\r
  61 [THEN]\r
  62 \r
  63 \   2VARIABLE   ( '<spaces>name' -- )           \ DOUBLE\r
  64 \               name Execution: ( -- a_addr )\r
  65 \               Create a definition for name with the execution semantics.\r
  66 : 2VARIABLE   CREATE 2 CELLS ALLOT ;\r
  67 \r
  68 \   D+          ( d1|ud1 d2|ud2 -- d3|ud3 )     \ DOUBLE\r
  69 \               Add two double numbers, giving the double sum.\r
  70 \\r
  71 \ Already defined in .ASM source.\r
  72 \r
  73 \   D-          ( d1|ud1 d2|ud2 -- d3|ud3 )     \ DOUBLE\r
  74 \               Subtract d2|ud2 from d1|ud1, giving the difference d3|ud3.\r
  75 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
  76 [IF]\r
  77   : D-   DNEGATE D+ ;\r
  78 [ELSE] DROP\r
  79   CODE D-\r
  80       BX DX MOV,\r
  81       AX POP,\r
  82       BX POP,\r
  83       CX POP,\r
  84       AX CX SUB,\r
  85       CX PUSH,\r
  86       DX BX SBB,\r
  87       NEXT,\r
  88   END-CODE\r
  89 [THEN]\r
  90 \r
  91 \   D.          ( d -- )                        \ DOUBLE\r
  92 \               Display d in free field format followed by a space.\r
  93 \\r
  94 \ Already defined in .ASM source.\r
  95 \r
  96 \   D.R         ( d n -- )                      \ DOUBLE\r
  97 \               Display d right-justified in field of width n.\r
  98 \\r
  99 \ Already defined in OPTIONAL.F .\r
 100 \r
 101 \   D0<         ( d -- flag )                   \ DOUBLE\r
 102 \               flag is true if and only if d is less than 0.\r
 103 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 104 [IF]\r
 105   : D0<   NIP 0< ;\r
 106 [ELSE] DROP\r
 107   CODE D0<\r
 108       CX POP,\r
 109       BX AX MOV,\r
 110       CWD,\r
 111       DX BX MOV,\r
 112       NEXT,\r
 113   END-CODE\r
 114 [THEN]\r
 115 \r
 116 \   D0=         ( xd -- flag )                  \ DOUBLE\r
 117 \               flag is true if and only if d is 0.\r
 118 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 119 [IF]\r
 120   : D0=   OR 0= ;\r
 121 [ELSE] DROP\r
 122   CODE D0=\r
 123       CX POP,\r
 124       CX BX OR,\r
 125       -1 # BX MOV,\r
 126       1 L# JZ,\r
 127       BX INC,\r
 128   1 L:\r
 129       NEXT,\r
 130   END-CODE\r
 131 [THEN]\r
 132 \r
 133 \   D2*         ( xd1 -- xd2 )                  \ DOUBLE\r
 134 \               xd2 is the result of shifting xd1 one bit toward the\r
 135 \               most-significant bit, filling the vacated least-significant\r
 136 \               bit with zero.\r
 137 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 138 [IF]\r
 139   : D2*   2DUP D+ ;\r
 140 [ELSE] DROP\r
 141   CODE D2*\r
 142       AX POP,\r
 143       AX 1 SHL,\r
 144       BX 1 RCL,\r
 145       AX PUSH,\r
 146       NEXT,\r
 147   END-CODE\r
 148 [THEN]\r
 149 \r
 150 \   D2/         ( xd1 -- xd2 )                  \ DOUBLE\r
 151 \               xd2 is the result of shifting xd1 one bit toward the least-\r
 152 \               significant bit, leaving the most-significant bit unchanged.\r
 153 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 154 [IF]\r
 155   : D2/   >R 1 RSHIFT R@ 1 AND IF TRUE 1 RSHIFT INVERT OR THEN R> 2/ ; \ by W. Baden\r
 156 [ELSE] DROP\r
 157   CODE D2/\r
 158       AX POP,\r
 159       BX 1 SAR,\r
 160       AX 1 RCR,\r
 161       AX PUSH,\r
 162       NEXT,\r
 163   END-CODE\r
 164 [THEN]\r
 165 \r
 166 \   D<          ( d1 d2 --- flag )              \ DOUBLE\r
 167 \               flag is true if and only if d1 is less than d2.\r
 168 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 169 [IF]\r
 170   : D<   ROT  2DUP = IF  2DROP U<  EXIT THEN\r
 171          2SWAP 2DROP  > ;\r
 172 [ELSE] DROP\r
 173   CODE D<\r
 174       CX POP,\r
 175       DX POP,\r
 176       AX POP,\r
 177       BX DX CMP,\r
 178       0 # BX MOV,\r
 179       1 L# JZ,\r
 180       2 L# JGE,\r
 181       BX DEC,\r
 182       NEXT,\r
 183   1 L:\r
 184       CX AX CMP,\r
 185       2 L# JAE,\r
 186       BX DEC,\r
 187   2 L:\r
 188       NEXT,\r
 189   END-CODE\r
 190 [THEN]\r
 191 \r
 192 \   D=          ( xd1 xd2 --- flag )            \ DOUBLE\r
 193 \               flag is true if and only if xd1 is bit-for-bit the same as xd2.\r
 194 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 195 [IF]\r
 196   : D=   D- OR 0= ;\r
 197 [ELSE] DROP\r
 198   CODE D=\r
 199       CX POP,\r
 200       DX POP,\r
 201       AX POP,\r
 202       BX DX CMP,\r
 203       0 # BX MOV,\r
 204       1 L# JNZ,\r
 205       CX AX CMP,\r
 206       1 L# JNZ,\r
 207       BX DEC,\r
 208   1 L:\r
 209       NEXT,\r
 210   END-CODE\r
 211 [THEN]\r
 212 \r
 213 \   D>S         ( d -- n )                      \ DOUBLE\r
 214 \               n is the equivalent of d.  An ambiguous condition exists if\r
 215 \               d lies outside the range of a signed single-cell number.\r
 216 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 217 [IF]\r
 218   : D>S   OVER S>D NIP <> IF -11 THROW THEN ;     \ result out of range\r
 219 [ELSE] DROP\r
 220   CODE D>S\r
 221       AX POP,\r
 222       CWD,\r
 223       BX DX CMP,\r
 224       1 L# JNE,\r
 225       AX BX MOV,\r
 226       NEXT,\r
 227   1 L:\r
 228       -11 # BX MOV,       \ result out of range\r
 229       ' THROW # JMP,\r
 230   END-CODE\r
 231 [THEN]\r
 232 \r
 233 \   DABS        ( d --- ud )                    \ DOUBLE\r
 234 \               ud is the absolute value of d.\r
 235 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 236 [IF]\r
 237   : DABS   DUP 0< IF  DNEGATE  THEN ;\r
 238 [ELSE] DROP\r
 239   CODE DABS\r
 240       BX BX OR,\r
 241       1 L# JNS,\r
 242       AX POP,\r
 243       AX NEG,\r
 244       0 # BX ADC,\r
 245       BX NEG,\r
 246       AX PUSH,\r
 247   1 L:\r
 248       NEXT,\r
 249   END-CODE\r
 250 [THEN]\r
 251 \r
 252 \   DMAX        ( d1 d2 --- d3 )                \ DOUBLE\r
 253 \               d3 is the greater of d1 and d2.\r
 254 : DMAX   2OVER 2OVER D< IF  2SWAP  THEN  2DROP ;\r
 255 \r
 256 \   DMIN       ( d1 d2 --- d3 )                 \ DOUBLE\r
 257 \              d3 is the lesser of d1 and d2.\r
 258 : DMIN   2OVER 2OVER D< 0= IF  2SWAP  THEN  2DROP ;\r
 259 \r
 260 \   DNEGATE       ( d1 --- d2 )                 \ DOUBLE\r
 261 \                 d2 is the negation of d1.\r
 262 \ Already defined in .ASM source.\r
 263 \r
 264 \   M*/           ( d1 n1 +n2 --- d2 )          \ DOUBLE\r
 265 \                 Multiply d1 by n1 producing the triple-cell intermediate\r
 266 \                 result t. Divide t by +n2 giving the double-cell quotient d2.\r
 267 \                 An ambiguous condition exists if +n2 is zero or negative, or\r
 268 \                 the quotient lies outside of the range of a double-precision\r
 269 \                 signed integer.\r
 270 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 271 [IF]\r
 272   \ by Wil Baden\r
 273   : T*    TUCK UM* 2SWAP UM* SWAP >R 0 D+ R> ROT ROT ;  ( u . u -- u . . )\r
 274   : T/    DUP >R UM/MOD ROT ROT R> UM/MOD NIP SWAP ;    ( u . . u -- u . )\r
 275   : M*/   >R T*  R> T/ ;                                ( u . u u -- u . )\r
 276 [ELSE] DROP\r
 277   CODE M*/\r
 278       BX BX OR,\r
 279       1 L# JZ,\r
 280       2 L# JS,\r
 281       CX POP,     \ n1\r
 282       DI POP,     \ high significant part of d1\r
 283       AX POP,     \ low significant part of d1\r
 284       DI DX MOV,\r
 285       CX DX XOR,\r
 286       DX PUSH,    \ save sign of the result\r
 287       BX PUSH,    \ save n2\r
 288       CX CX OR,\r
 289       3 L# JNS,\r
 290       CX NEG,     \ ABS(n1)\r
 291   3 L:\r
 292       DI DI OR,\r
 293       4 L# JNS,\r
 294       AX NEG,     \ DABS(d1)\r
 295       0 # DI ADC,\r
 296       DI NEG,\r
 297   4 L:\r
 298       CX MUL,     \ lower partial product DX:AX\r
 299       AX DI XCHG, \ lower partial product DX:DI\r
 300       DX BX MOV,  \ lower partial product BX:DI\r
 301       CX MUL,     \ lower partial product BX:DI, upper partial product DX:AX\r
 302       BX AX ADD,\r
 303       0 # DX ADC, \ intermediate product DX:AX:DI\r
 304       BX POP,     \ restore n2\r
 305       BX DX CMP,\r
 306       5 L# JAE,\r
 307       BX DIV,\r
 308       AX DI XCHG, \ upper part of the quotient in DI\r
 309       BX DIV,     \ quotient DI:AX\r
 310       DI DI OR,\r
 311       5 L# JS,    \ DI:AX does not fit in double signed integer\r
 312       CX POP,     \ restore sign of the result\r
 313       CX CX OR,\r
 314       6 L# JNS,\r
 315       AX NEG,     \ DNEGATE\r
 316       0 # DI ADC,\r
 317       DI NEG,\r
 318   6 L:\r
 319       AX PUSH,\r
 320       DI BX MOV,\r
 321       NEXT,\r
 322   5 L:\r
 323       -11 # BX MOV,       \ result out of range\r
 324       ' THROW # JMP,\r
 325   2 L:\r
 326       -12 # BX MOV,       \ argument type mismatch\r
 327       ' THROW # JMP,\r
 328   1 L:\r
 329       -10 # BX MOV,       \ divide by zero\r
 330       ' THROW # JMP,\r
 331   END-CODE\r
 332 [THEN]\r
 333 \r
 334 \   M+            ( d1|ud1 n --- d2|ud2 )       \ DOUBLE\r
 335 \                 Add n to d1|ud1, giving the sum d2|ud2.\r
 336 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 337 [IF]\r
 338   : M+   S>D D+ ;\r
 339 [ELSE] DROP\r
 340   CODE M+\r
 341       BX AX MOV,        \ move stack top to AX for sign-extend\r
 342       CWD,              \ DX:AX now has 32-bit value\r
 343       BX POP,           \ upper half of second argument\r
 344       CX POP,           \ lower half of second argument\r
 345       AX CX ADD,        \ add lower halves\r
 346       DX BX ADC,        \ add upper halves with carry - sum now in BX:CX\r
 347       CX PUSH,          \ push lower half of result to stack\r
 348       NEXT,             \ finished\r
 349   END-CODE\r
 350 [THEN]\r
 351 \r
 352 \   2ROT        ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )      \ DOUBLE EXT\r
 353 \               Rotate the top three cell pairs on the stack bringing cell\r
 354 \               pair x1 x2 to the top of the stack.\r
 355 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 356 [IF]\r
 357   : 2ROT   2>R 2SWAP 2R> 2SWAP ;\r
 358 [ELSE] DROP\r
 359   CODE 2ROT\r
 360       CX POP,\r
 361       DX POP,\r
 362       AX POP,\r
 363       SP DI MOV,\r
 364       1 CELLS [DI] AX XCHG,\r
 365       0 [DI] DX XCHG,\r
 366       CX PUSH,\r
 367       BX PUSH,\r
 368       AX PUSH,\r
 369       DX BX MOV,\r
 370       NEXT,\r
 371   END-CODE\r
 372 [THEN]\r
 373 \r
 374 \   DU<         ( ud1 ud2 --- flag )                            \ DOUBLE EXT\r
 375 \               flag is true if and only if ud1 is less than ud2.\r
 376 CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
 377 [IF]\r
 378   : DU<   ROT  2DUP = IF  2DROP U<  EXIT THEN\r
 379           2SWAP 2DROP  U> ;\r
 380 [ELSE] DROP\r
 381   CODE DU<\r
 382       CX POP,\r
 383       DX POP,\r
 384       AX POP,\r
 385       BX DX CMP,\r
 386       0 # BX MOV,\r
 387       1 L# JZ,\r
 388       2 L# JAE,\r
 389       BX DEC,\r
 390       NEXT,\r
 391   1 L:\r
 392       CX AX CMP,\r
 393       2 L# JAE,\r
 394       BX DEC,\r
 395   2 L:\r
 396       NEXT,\r
 397   END-CODE\r
 398 [THEN]\r
 399 \r
 400 envQList SET-CURRENT\r
 401 -1 CONSTANT DOUBLE\r
 402 -1 CONSTANT DOUBLE-EXT\r
 403 \r
 404 SET-CURRENT  SET-ORDER\r
 405 \r
 406 CHAR " PARSE model" ENVIRONMENT? DROP\r
 407 CHAR " PARSE ROM Model" COMPARE 0=\r
 408 [IF] RAM/ROM! [THEN]\r
 409 BASE !\r
 410 \r
 411 CHAR " PARSE FILE" ENVIRONMENT?\r
 412 [IF]\r
 413   0= [IF] << CON [THEN]\r
 414 [ELSE] << CON\r
 415 [THEN]\r