kernel.fs (22660B) - raw
1 \ This is the i386 Dusk kernel. It is called when the bootloader has finished 2 \ loading this binary as well as the Forth boot code following it in memory. 3 \ We're in protected mode and all segments have been initialized. 4 \ ESP=RSP ESI=PSP EBX=A EAX=W. They begin uninitialized. 5 \ HAL operand structure is similar to the asm/i386 opmod structure. 6 \ Registers preserved/destroyed by words usually don't matter much: as an API, 7 \ we must assume that all registers are destroyed. However, some words within 8 \ the kernel refer to other words with register preservation assumptions. In 9 \ these cases, the word itself mentions which registers are preserved. 10 11 \ HAL operand structure (very close to i386 structure) 12 \ b2:0 src regid 13 \ b5:3 dst regid 14 \ b7:6 mod ( displacement in bank if present ) 15 \ b8 0=8b 1=32/16b 16 \ b15:9 zeroes 17 \ b16 "&)" flag 18 \ b17 16b? 19 \ b18 immediate? ( value in bank ) 20 \ b19 "<>)" flag 21 \ b23:20 Number bank index 22 \ b24 Has number in bank 23 \ b31:25 zeroes 24 ?f<< /asm/i386.fs 25 ?f<< /xcomp/tools.fs 26 27 \ Macros 28 : xnip, si CELLSZ i) add, ; 29 : xdrop, ax si 0 d) mov, xnip, ; 30 : xgrow, si CELLSZ i) sub, ; 31 : xdup, xgrow, si 0 d) ax mov, ; 32 : xlit, ( n -- ) xdup, ax swap i) mov, ; 33 : absjmp, abs>rel jmp, ; 34 : abscall, abs>rel call, ; 35 : wcall, xwordlbl abscall, ; 36 : wjmp, xwordlbl absjmp, ; 37 : xconst ( n -- ) xcode xdup, ax swap i) mov, ret, ; 38 0 value lblintnoop 39 : idtgen ( entrycount -- ) for 40 lblintnoop $ffff and 16b le, $08 16b le, 0 c, $8e c, 41 lblintnoop 16 rshift 16b le, next ; 42 43 \ Constants and labels 44 0 to realmode 45 : values ( n -- ) for 0 value next ; 46 28 values lblmainalias lblbootptr lblnextword lblcurword lblnextmeta lblret 47 lblsysdict lblhere lbl[rcnt] lblhbank lblhbankidx lblmod 48 lblparsec lblparseh lblparseud lblerrmsg 49 lblfind lblcompiling lblidt 50 lblwriterange lblrelwr lblcallwr 51 lblnewbankedop lblbankedop@ 52 lblmodrmwr lblderef lblregularwr lblariwr 53 54 $8000 const HERESTART 55 $500 to binstart 56 $2000 const STACKSZ 57 $7c00 const RSTOP 58 $80000 const PSTOP 59 PSTOP STACKSZ - const HEREMAX 60 $100 const HAL8B 61 $20000 const HAL16B 62 $40000 const HALIMM 63 $10000 const HALDEREF 64 $80000 const HALINV 65 $1000000 const HALHASBANK 66 $10 const HBANKSZ 67 68 : _ dx lblhere m) mov, dx 0 d) swap mov, ; 69 : cwrite, ( opmod -- ) _ lblhere m) inc, ; \ Destroys dx 70 : wwrite, ( opmod -- ) _ lblhere m) 2 i) add, ; \ Destroys dx 71 : dwrite, ( opmod -- ) _ lblhere m) 4 i) add, ; \ Destroys dx 72 : movewrite, ( a u ) cx swap i) mov, di swap i) mov, lblwriterange abscall, ; 73 : reg!, ( r 8bitoperand -- ) dup $c7 i) and, swap 7 and 3 lshift i) or, ; 74 : modrm!, ( mod r 8bop -- ) 75 dup $38 i) and, rot> 7 and swap 6 lshift or i) or, ; 76 77 \ Let's go! 78 here# to org 79 forward16 jmp, to L1 80 pc to lblintnoop iret, 81 \ Interrupt Descriptor Table 82 alignhere pc to L2 $100 idtgen 83 pc to lblidt 84 $100 8 * 1- 16b le, L2 le, 85 L1 forward! 86 lblidt m) lidt, sti, 87 forward16 jmp, to L1 88 89 L2 xconst IDT 90 9 xconst DOESSZ 91 5 xconst BRSZ 92 93 HERESTART xconst herestart 94 pc HEREMAX le, xconst HEREMAX 95 pc to lblhere HERESTART le, 96 lblhere xconst HERE 97 8 allot0 pc to lblsysdict 0 le, 98 lblsysdict xconst sysdict 99 pc to lblmod 0 le, 100 lblmod xconst MOD 101 pc to lbl[rcnt] 0 le, 102 lbl[rcnt] xconst [rcnt] 103 pc to lblnextword 0 le, 104 lblnextword xconst NEXTWORD 105 pc to lblcurword $20 allot0 106 lblcurword xconst curword 107 pc to lblnextmeta 0 le, 108 lblnextmeta xconst nextmeta 109 110 pc to lblcompiling 0 le, 111 xcode compiling 112 xdup, ax lblcompiling m) mov, ret, 113 114 xcode quit 115 cld, 116 lblmod m) 0 i) mov, 117 sp RSTOP i) mov, 118 lblcompiling m) 0 i) mov, 119 forward jmp, to lblmainalias 120 121 xcode (abort) 122 L1 forward! 123 si PSTOP i) mov, 124 wjmp, quit 125 126 xcode rtype wjmp, (abort) 127 128 \ During early boot, it's better to halt the machine than to go back to the 129 \ mainloop because the mainloop likely sends us to an infinite error loop 130 \ through boot<. 131 pc ," boot failure" 132 xcode abort 133 si 0 d) swap ( pc ) i) mov, 134 ax 12 i) mov, 135 wcall, rtype 136 0 jmp, 137 138 xcode dbg 0 jmp, 139 140 \ HAL operands 141 $100 xconst W) 142 $103 xconst A) 143 $106 xconst PSP) 144 $104 xconst RSP) 145 $4 xconst Z) 146 $5 xconst NZ) 147 $2 xconst <) $3 xconst >=) $6 xconst <=) $7 xconst >) 148 $c xconst s<) $d xconst s>=) $e xconst s<=) $f xconst s>) 149 150 alignhere 151 pc to lblhbank HBANKSZ CELLSZ * allot0 152 pc to lblhbankidx 0 le, 153 154 xcode hbank' ( slot -- a ) \ preserves DX and DI 155 ax $f i) and, ax 2 i) shl, 156 ax lblhbank i) add, 157 ret, 158 159 xcode hbank! ( n -- slot ) \ Preserves DI 160 dx ax mov, 161 ax lblhbankidx m) mov, 162 ax $f i) and, 163 ax push, 164 lblhbankidx m) inc, 165 wcall, hbank' 166 ax 0 d) dx mov, 167 ax pop, 168 ret, 169 170 xcode hbank@ ( slot -- n ) 171 wcall, hbank' 172 ax ax 0 d) mov, 173 ret, 174 175 \ Create a new "banked" operand from n 176 pc to lblnewbankedop ( n -- operand ) \ preserves DI 177 wcall, hbank! 178 ax 20 i) shl, 179 ax HALHASBANK i) or, 180 ret, 181 182 \ Get banked value from operand 183 pc to lblbankedop@ ( operand -- n ) 184 ax 20 i) shr, 185 wjmp, hbank@ 186 187 xcode m) ( a -- operand ) 188 lblnewbankedop abscall, 189 ax $105 i) or, 190 ret, 191 192 xcode i) ( n -- operand ) 193 lblnewbankedop abscall, 194 ax HALIMM i) or, 195 ret, 196 197 \ If operand's mod is 1 (disp8) and that n >= $100, upgrade mod to 2 (disp32) 198 pc to L2 ( operand -- operand ) \ di=n 199 di $ffffff00 i) test, forward8 jnz, ret, forward! 200 cl al mov, cl $c0 i) and, cl $40 i) cmp, forward8 jz, ret, forward! 201 \ upgrade needed 202 al $40 i) add, 203 ret, 204 205 \ When the operation already has a banked op, add to it instead of replacing it. 206 pc to L1 ( operand n -- operand ) 207 ax push, xdrop, ax push, 208 ax 20 i) shr, 209 wcall, hbank' 210 dx pop, ( operand ) cx pop, ( n ) 211 ax 0 d) cx add, 212 di ax 0 d) mov, 213 ax dx mov, 214 L2 absjmp, 215 216 xcode +) ( operand n -- operand ) 217 ax ax test, forward8 jnz, xdrop, ret, forward! 218 si 0 d) HALHASBANK i) test, L1 abs>rel jnz, 219 di ax mov, \ save for L2 220 lblnewbankedop abscall, 221 dx si 0 d) mov, xnip, 222 ax dx or, 223 ax $40 i) or, \ disp8 mode 224 L2 absjmp, 225 226 xcode 8b) ( operand -- operand ) 227 ax HAL8B ^ i) and, ret, 228 229 xcode 16b) ( operand -- operand ) 230 ax HAL16B i) or, ret, 231 232 xcode 32b) ( operand -- operand ) 233 ax HAL8B i) or, ax HAL16B ^ i) and, ret, 234 235 xcode A>) ( operand -- operand ) 236 ax $18 i) or, ret, \ dst=bx (3<<3) 237 238 xcode &) ( operand -- operand ) 239 dx ax mov, dl $c7 i) and, dl $05 i) cmp, forward8 jnz, \ is m)? make it i) 240 0 0 al modrm!, ax HALIMM i) or, ret, forward! 241 ax HALDEREF i) or, ret, 242 243 xcode <>) ( operand -- operand ) 244 ax HALINV i) or, ret, 245 246 \ Write routines 247 xcode pushret, ret, 248 xcode popret, ret, 249 250 pc to lblcallwr \ di=abs addr 251 $e8 i) cwrite, 252 pc to lblrelwr \ di=abs addr 253 di lblhere m) sub, \ displacement 254 di 4 i) sub, \ ... from *after* call op 255 di dwrite, 256 pc to lblret 257 ret, 258 259 pc to lblwriterange \ di=addr cx=u. destroys cx and di 260 si push, 261 si di mov, 262 di lblhere m) mov, 263 lblhere m) cx add, 264 rep, movsb, 265 si pop, 266 ret, 267 268 \ Assembler words 269 pc to L3 ( operand -- ) \ disp32 270 lblbankedop@ abscall, 271 ax dwrite, 272 xdrop, ret, 273 pc to L2 ( operand -- ) \ disp8 274 lblbankedop@ abscall, 275 al cwrite, 276 xdrop, ret, 277 278 \ Write modrm in AL, with disp8/disp32/SIB if appropriate. 279 \ When mod<>0 (or modrm=mem), add disp8 or disp32 280 \ When targeting ESP, mangle op appropriately to add SIB byte. 281 pc to lblmodrmwr ( operand -- ) 282 al cwrite, 283 dx ax mov, dl $7 i) and, dl $4 i) cmp, forward8 jnz, 284 dx ax mov, dl $c0 i) and, dl $c0 i) cmp, forward8 jz, 285 $24 i) cwrite, forward! forward! \ mod=3 and rm=SP? write SIB 286 dl al mov, dl $c0 i) and, \ dl=mod 287 dl $40 i) cmp, L2 abs>rel jz, \ disp8 288 dl $80 i) cmp, L3 abs>rel jz, \ disp32 289 dl al mov, 0 dl reg!, 290 dl $05 i) cmp, L3 abs>rel jz, \ m) means disp32 291 xdrop, ret, 292 293 \ If HALDEREF flag is set operate the necessary changes in opmod to dereference 294 \ it. If a LEA is necessary, write it to CX, then mangle operand to reference 295 \ it. 296 pc to lblderef ( operand -- operand ) 297 ax HALDEREF i) test, forward8 jnz, ret, forward! 298 ax HALDEREF ^ i) and, 299 ax $c0 i) test, \ mod 300 forward8 jnz, \ mod=0, set to mod=3 301 ax $c0 i) or, ret, forward! 302 \ TODO: HAL error on mod=3 303 \ Write LEA to CX 304 xdup, cx al reg!, 305 $8d i) cwrite, lblmodrmwr abscall, \ lea, 306 3 cx al modrm!, 307 ret, 308 309 \ Write "regular" operation, that is, a modrm op with b0=8b and b1=direction 310 \ Opcode is in b15:8 and modrm in b7:0. 311 \ Add 16b prefix when 16b flag is set. 312 \ If the HALINV flag is set, invert direction bit from instruction. 313 pc to lblregularwr ( operand -- ) 314 lblderef abscall, 315 ax HAL16B i) test, forward8 jz, $66 i) cwrite, forward! 316 ax HALINV i) test, forward8 jz, ax $0200 i) xor, forward! \ inv dir bit 317 ah cwrite, 318 lblmodrmwr absjmp, 319 320 pc to L3 ( operand -- ) \ immediate 321 al 3 i) shr, al 7 i) and, al $b8 i) or, 322 al cwrite, 323 lblbankedop@ abscall, 324 ax dwrite, 325 xdrop, ret, 326 pc to L2 ( operand -- ) \ 16b or 8b, movzx 327 ax HAL16B ^ i) and, \ don't put 16b prefix with movzx 328 $0f i) cwrite, 329 ax $b600 i) or, lblregularwr absjmp, 330 xcode @, ( operand -- ) \ ax operand mov, 331 ax HALIMM i) test, L3 abs>rel jnz, 332 ax HALINV i) test, forward8 jnz, \ inverted? no movzx! 333 ax HAL16B i) test, L2 abs>rel jnz, 334 ax HAL8B i) test, L2 abs>rel jz, 335 forward! 336 ax $8a00 i) or, lblregularwr absjmp, 337 338 xcode !, ( operand -- ) 339 wcall, <>) 340 wjmp, @, 341 342 xcode @!, ( operand -- ) \ operand ax xchg, 343 ax $8600 i) or, lblregularwr absjmp, 344 345 xcode +n, ( n operand -- ) \ operand n i) add, 346 0 al reg!, 347 si 0 d) 1 i) cmp, forward8 jnz, 348 xnip, ax $fe00 i) or, lblregularwr absjmp, forward! 349 si 0 d) -1 i) cmp, forward8 jnz, 350 xnip, ax $fe08 i) or, lblregularwr absjmp, forward! 351 ax $8000 i) or, ax push, lblregularwr abscall, ( n -- ) 352 dx pop, 353 dx HAL8B i) test, forward8 jnz, al cwrite, xdrop, ret, forward! 354 dx HAL16B i) test, forward8 jz, ax wwrite, xdrop, ret, forward! 355 ax dwrite, xdrop, ret, 356 357 xcode rs+, ( n -- ) 358 lbl[rcnt] m) ax add, 359 wcall, RSP) 360 wcall, &) 361 wjmp, +n, 362 363 xcode ps+, ( n -- ) 364 wcall, PSP) 365 wcall, &) 366 wjmp, +n, 367 368 \ Before writing the operand MUL/DIV operation, we check if the operand is 369 \ immediate. If it is, we load that immediate in CX and mangle the operand so 370 \ that the source becomes CX. 371 pc to L2 ( operand -- ) 372 ax HALIMM i) test, forward8 jnz, ret, forward! \ not an immediate 373 ax push, 374 $b9 i) cwrite, lblbankedop@ abscall, ax dwrite, \ cx i) mov, 375 ax pop, 376 ax HALIMM ^ i) and, \ remove imm flag 377 al $c1 i) or, \ src=CX 378 ret, 379 380 xcode *, ( operand -- ) 381 lblderef abscall, 382 L2 abscall, 383 xdup, 384 ax HALINV i) test, forward8 jz, \ inverted, save AX to DI 385 ax HALINV ^ i) and, 386 $c789 i) wwrite, forward! \ di ax mov, 387 dx ax mov, dl $38 i) and, dl $18 i) cmp, forward8 jnz, \ reg=BX (A>) 388 $93 i) cwrite, ax al reg!, forward! \ ax bx xchg, 389 ax $f720 i) or, lblregularwr abscall, \ MUL 390 dx ax mov, dl $38 i) and, dl $18 i) cmp, forward8 jnz, \ reg=BX (A>) 391 $93 i) cwrite, forward! \ ax bx xchg, 392 ax HALINV i) test, forward8 jz, \ inverted, save AX to src. 393 ax al reg!, \ regid=AX 394 wcall, @, 395 $f889 i) wwrite, 396 ret, forward! \ ax di mov, 397 xdrop, 398 ret, 399 400 xcode /mod, ( operand -- ) 401 lblderef abscall, 402 L2 abscall, 403 ax HALINV i) test, forward8 jz, \ unlike with *, order is important here 404 ax HALINV ^ i) and, xdup, wcall, @!, forward! 405 $d231 i) wwrite, \ dx dx xor, 406 ax $f730 i) or, lblregularwr abscall, \ DIV 407 $d389 i) wwrite, \ bx dx mov, 408 ret, 409 410 xcode @+, ( operand -- ) 411 xdup, wcall, @, 412 ax HALINV ^ i) and, 413 wcall, &) 414 xgrow, 415 si 0 d) 4 i) mov, 416 ax HAL16B i) test, forward8 jz, si 0 d) 2 i) mov, forward! 417 ax HAL8B i) test, forward8 jnz, si 0 d) 1 i) mov, forward! 418 wcall, 32b) 419 wjmp, +n, 420 421 xcode !+, ( operand -- ) 422 wcall, <>) 423 wjmp, @+, 424 425 xcode -@, ( operand -- ) 426 xdup, 427 ax HALINV ^ i) and, 428 wcall, &) 429 xgrow, 430 si 0 d) -4 i) mov, 431 ax HAL16B i) test, forward8 jz, si 0 d) -2 i) mov, forward! 432 ax HAL8B i) test, forward8 jnz, si 0 d) -1 i) mov, forward! 433 wcall, 32b) 434 wcall, +n, 435 wjmp, @, 436 437 xcode -!, ( operand -- ) 438 wcall, <>) 439 wjmp, -@, 440 441 \ When the operation is 16-bit or 8-bit *and* that it's not inverted (if it's 442 \ inverted, we can perform the 16-bit/8-bit operation directly), we want to load 443 \ operand's src in a register so that the operation is upscaled to 32-bit. 444 pc to L2 ( operand -- ) \ dx=index 445 dx push, xdup, 446 dx al reg!, \ reg=DX 447 wcall, @, ( op ) 448 dx pop, 449 ax $ff i) and, 450 3 dx al modrm!, 451 dl 3 i) shl, dl inc, dl inc, \ dl=opcode 452 ah dl mov, 453 ah 1 i) or, \ 32bit 454 lblregularwr absjmp, 455 456 \ Write arithmetic operand with specified index, handling the imm/register 457 \ complexity. opcodes are supplied as 2 bytes: b15:8 is the "not imm" opcode 458 \ and b5:3 is the "/reg" argument to supply to the $81 immediate operation. 459 pc to lblariwr ( operand -- ) \ dx=index 460 ax HALIMM i) test, forward8 jnz, \ not an imm 461 ax HALINV i) test, forward8 jnz, 462 ax HAL16B i) test, L2 abs>rel jnz, 463 ax HAL8B i) test, L2 abs>rel jz, forward! 464 dx 11 i) shl, dx $200 i) add, ax dx or, lblregularwr absjmp, forward! 465 \ mod becomes 3, reg moves to rm and dx is orred into modrm 466 al 3 i) shr, al 7 i) and, al $c0 i) or, dl 3 i) shl, al dl or, 467 $81 i) cwrite, al cwrite, 468 lblbankedop@ abscall, ax dwrite, 469 xdrop, ret, 470 471 xcode +, ( operand -- ) 472 dx 0 i) mov, lblariwr absjmp, 473 474 xcode -, ( operand -- ) 475 dx 5 i) mov, lblariwr absjmp, 476 477 xcode &, ( operand -- ) 478 dx 4 i) mov, lblariwr absjmp, 479 480 xcode |, ( operand -- ) 481 dx 1 i) mov, lblariwr absjmp, 482 483 xcode ^, ( operand -- ) 484 dx 6 i) mov, lblariwr absjmp, 485 486 xcode compare, ( operand -- ) 487 dx 7 i) mov, lblariwr absjmp, 488 489 \ Write SHL or SHR 490 pc to L1 ( operand -- ) \ dx=SHL/SHR regid 491 ax HALIMM i) test, forward jnz, \ not an immediate 492 ax HALINV i) test, forward8 jz, \ inverted, dst is going to CX 493 xdup, 3 cx al modrm!, 494 dx push, wcall, 32b) wcall, !, dx pop, \ mov cx, dst 495 ax HALINV ^ i) and, 0 al reg!, al dl or, 496 ax $d300 i) or, lblregularwr absjmp, forward! 497 xdup, cx al reg!, \ target CX 498 dx push, wcall, @, dx pop, 499 \ mod becomes 3, reg moves to rm and DL is orred into modrm 500 al 3 i) shr, al 7 i) and, al $c0 i) or, al dl or, 501 $d3 i) cwrite, al cwrite, 502 xdrop, ret, 503 forward! \ immediate 504 \ mod becomes 3, reg moves to rm and DL is orred into modrm 505 al 3 i) shr, al 7 i) and, al $c0 i) or, al dl or, 506 $c1 i) cwrite, al cwrite, 507 lblbankedop@ abscall, al cwrite, xdrop, 508 ret, 509 510 xcode <<, ( operand -- ) 511 dx $20 i) mov, L1 absjmp, 512 513 xcode >>, ( operand -- ) 514 dx $28 i) mov, L1 absjmp, 515 516 xcode dup, 517 -4 xlit, wcall, ps+, 518 wcall, PSP) 519 wjmp, !, 520 521 xcode litn 522 wcall, dup, 523 $b8 i) cwrite, ax dwrite, \ ax XX i) mov, 524 xdrop, ret, 525 526 pc 3 nc, $5f $ff $d7 \ di pop, di call, 527 xcode yield ximm 528 ( pc ) 3 movewrite, ret, 529 530 xcode branchR, 531 di ax mov, xdrop, 532 lblcallwr absjmp, 533 534 xcode exit, 535 $c3 ( ret ) i) cwrite, 536 ret, 537 538 xcode -W, ( -- ) \ ax neg, 539 $d8f7 i) wwrite, ret, 540 541 pc 6 nc, $b8 0 0 0 0 $0f \ ax 0 i) mov, al setXX, 542 xcode C>W, ( cond -- ) 543 ( pc ) 6 movewrite, 544 ax $c090 i) or, ax wwrite, 545 xdrop, ret, 546 547 xcode branch, ( a -- a ) 548 $e9 ( jmp ) i) cwrite, 549 pc to L1 550 di ax mov, 551 lblrelwr abscall, 552 ax lblhere m) mov, 553 ax 4 i) sub, 554 ret, 555 556 \ we always encode the long form. 557 xcode branchC, ( a cond -- a ) 558 ax $f80 i) or, al ah xchg, ax wwrite, 559 xdrop, L1 absjmp, 560 561 xcode branchA, $e3ff i) wwrite, ret, \ bx jmp, 562 563 xcode branch! ( tgt a -- ) 564 di si 0 d) mov, xnip, \ ax=a di=tgt 565 di ax sub, \ displacement 566 di 4 i) sub, \ ... from *after* call/jmp op 567 ax 0 d) di mov, 568 xdrop, 569 ret, 570 571 \ Regular words 572 xcode pc@ ( port -- n8 ) 573 dx ax mov, 574 ax ax xor, 575 al dx in, 576 ret, 577 578 xcode pc! ( n8 port -- ) 579 dx ax mov, xdrop, 580 al dx out, xdrop, 581 ret, 582 583 xcode pw@ ( port -- n16 ) 584 dx ax mov, 585 ax ax xor, 586 ax 16b) dx in, 587 ret, 588 589 xcode pw! ( n16 port -- ) 590 dx ax mov, xdrop, 591 ax 16b) dx out, xdrop, 592 ret, 593 594 xcode p@ ( port -- n32 ) 595 dx ax mov, 596 ax ax xor, 597 ax dx in, 598 ret, 599 600 xcode p! ( n32 port -- ) 601 dx ax mov, xdrop, 602 ax dx out, xdrop, 603 ret, 604 605 xcode move ( src dst u -- ) 606 si push, 607 cx ax mov, 608 di si 0 d) mov, 609 si si 4 d) mov, 610 rep, movsb, 611 si pop, 612 xnip, xnip, xdrop, 613 ret, 614 615 xcode []= ( a1 a2 u -- f ) 616 si push, 617 di si 0 d) mov, 618 si si 4 d) mov, 619 cx ax mov, 620 ax ax xor, 621 repz, cmpsb, 622 si pop, 623 al setz, 624 xnip, xnip, 625 ret, 626 627 xcode cidx ( c a u -- ?idx f ) 628 cx ax mov, 629 dx ax mov, 630 di si 0 d) mov, xnip, 631 ax si 0 d) mov, 632 repnz, scasb, 633 forward8 jz, xnip, ax ax xor, ret, forward! \ no match 634 dx dec, 635 dx cx sub, 636 si 0 d) dx mov, 637 ax 1 i) mov, 638 ret, 639 640 \ Interpret loop 641 642 alignhere pc to lblbootptr 0 le, 643 xcode boot< 644 dx lblbootptr m) mov, 645 xdup, ax dx 0 d) 8b) movzx, 646 lblbootptr m) inc, 647 ret, 648 649 \ where "word" feeds itself 650 xcode in< wjmp, boot< 651 3 allot \ that last jump is a rel8, we need more space. 652 653 pc to L1 ( word_eof ) 654 ax ax xor, ret, 655 656 pc \ we have a nonzero lblnextword 657 si push, 658 si lblnextword m) mov, 659 lblnextword m) 0 i) mov, 660 cx cx xor, 661 cl si 0 d) mov, 662 cl inc, 663 di lblcurword i) mov, 664 rep, movsb, 665 si pop, 666 ax lblcurword i) mov, 667 ret, 668 669 xcode maybeword ( -- str-or-0 ) 670 xdup, \ reserve wiggle room on PS. 671 lblnextword m) -1 i) test, 672 ( pc ) abs>rel jnz, 673 pc ( loop1 ) 674 wcall, in< xnip, 675 ax ax test, 676 L1 ( word_eof ) abs>rel js, 677 ax SPC 1+ i) cmp, \ is ws? 678 ( pc ) abs>rel jc, ( loop1 ) 679 dx lblcurword 1+ i) mov, 680 pc ( loop2 ) 681 dx 0 d) al mov, 682 dx inc, 683 dx push, 684 wcall, in< xnip, 685 dx pop, 686 ax ax test, 687 forward js, to L1 ( stoploop ) 688 ax SPC 1+ i) cmp, \ is ws? 689 ( loop2 ) abs>rel jnc, 690 L1 forward! ( stoploop ) 691 dx lblcurword 1+ i) sub, 692 lblcurword m) dl mov, 693 ax lblcurword i) mov, 694 ret, 695 696 pc ," word expected" 697 xcode word 698 wcall, maybeword 699 ax ax test, 700 lblret abs>rel jnz, 701 cx 13 i) mov, 702 di swap ( pc ) i) mov, 703 pc to lblerrmsg \ ecx=sl edi=sa 704 xdup, ax di mov, xdup, ax cx mov, 705 wcall, rtype 706 wjmp, abort 707 708 xcode find ( str 'dict -- word-or-0 ) 709 di ax mov, xdrop, 710 pc to lblfind \ ax=str di='dict 711 cx ax 0 d) 8b) movzx, \ cx=sz 712 ax inc, 713 si push, 714 pc ( loop ) 715 dl di -5 d) mov, \ entry len 716 dl $3f i) and, \ 3f instead of 7f? we reserve space for another flag. 717 dl cl cmp, 718 forward jnz, to L1 ( skip1 ) 719 \ same length 720 di push, 721 di 5 i) sub, 722 di cx sub, \ beginning of name range 723 si ax mov, 724 repz, cmpsb, 725 di pop, 726 forward jnz, to L2 ( skip2 ) 727 \ same contents 728 si pop, 729 di 4 i) add, \ word 730 ax di mov, 731 ret, 732 L2 forward! ( skip2 ) 733 cl dl mov, 734 L1 forward! ( skip1 ) 735 di di 0 d) mov, 736 di di test, 737 ( pc ) abs>rel jnz, ( loop ) 738 \ not found 739 si pop, 740 ax ax xor, 741 ret, 742 743 pc ," word not found" 744 xcode (wnf) 745 xdup, ax lblcurword 1+ i) mov, 746 xdup, ax lblcurword m) 8b) movzx, 747 wcall, rtype 748 cx 15 i) mov, 749 di swap ( pc ) i) mov, 750 lblerrmsg absjmp, 751 752 alignhere pc to L1 \ parse unsuccessful 753 ax ax xor, 754 ret, 755 756 alignhere pc to lblparsec ( str -- n? f ) \ eax=sa ecx=sl 757 cx 3 i) cmp, 758 L1 abs>rel jnz, \ fail 759 ax 2 d) 8b) ''' i) cmp, 760 L1 abs>rel jnz, \ fail 761 ax ax 1 d) 8b) movzx, 762 xdup, 763 ax 1 i) mov, 764 ret, 765 766 alignhere pc to lblparseh ( str -- n? f ) \ eax=sa ecx=sl 767 cx 2 i) cmp, 768 L1 abs>rel jc, \ fail 769 ax inc, \ skip $ 770 cx dec, 771 di di xor, \ res 772 dx dx xor, 773 pc ( loop ) 774 dl ax 0 d) mov, 775 dl $20 i) or, 776 dl '0' i) sub, 777 L1 abs>rel jc, \ fail 778 dl 10 i) cmp, 779 forward jc, to L2 \ parse ok, under 10 780 dl 'a' '0' - i) sub, 781 L1 abs>rel jc, \ fail 782 dl 10 i) add, 783 dl 16 i) cmp, 784 L1 abs>rel jnc, \ fail 785 L2 forward! \ parse ok 786 di 4 i) shl, \ res*16 787 di dx add, 788 ax inc, 789 ( pc ) abs>rel loop, ( loop ) 790 xgrow, 791 si 0 d) di mov, 792 ax 1 i) mov, 793 ret, 794 795 alignhere pc to lblparseud ( str -- n? f ) \ eax=sa ecx=sl 796 cx cx test, 797 L1 abs>rel jz, \ fail 798 di ax mov, \ di=str 799 ax ax xor, \ ax=res 800 pc ( loop ) 801 dx 10 i) mov, 802 dx mul, 803 dx di 0 d) 8b) movzx, 804 dl '0' i) sub, 805 L1 abs>rel jc, \ fail 806 dl 10 i) cmp, 807 L1 abs>rel jnc, \ fail 808 ax dx add, 809 di inc, 810 ( pc ) abs>rel loop, ( loop ) 811 xdup, ax 1 i) mov, 812 ret, 813 814 xcode parse ( str -- n? f ) 815 cx ax 0 d) 8b) movzx, 816 ax inc, 817 ax 0 d) 8b) ''' i) cmp, 818 lblparsec abs>rel jz, 819 ax 0 d) 8b) '$' i) cmp, 820 lblparseh abs>rel jz, 821 ax 0 d) 8b) '-' i) cmp, 822 lblparseud abs>rel jnz, 823 ax inc, 824 cx dec, 825 lblparseud abscall, 826 ax ax test, 827 L1 abs>rel jz, \ fail 828 si 0 d) neg, 829 ret, 830 831 pc ," stack underflow" 832 xcode stack? 833 si PSTOP i) cmp, 834 lblret abs>rel jna, 835 cx 15 i) mov, 836 di swap ( pc ) i) mov, 837 lblerrmsg absjmp, 838 839 xcode findmeta ( id ll -- ll-or-0 ) \ Preserves dx 840 di si 0 d) mov, xnip, 841 pc to L1 \ di=id 842 ax ax test, 843 lblret abs>rel jz, 844 di ax 4 d) cmp, 845 lblret abs>rel jz, 846 ax ax 0 d) mov, 847 L1 absjmp, 848 849 pc to L2 \ mod not found, restore dx 850 ax dx mov, ret, 851 xcode findmod ( w -- w ) 852 lblmod m) -1 i) test, 853 lblret abs>rel jz, 854 dx ax mov, 855 ax ax -8 d) mov, 856 di lblmod m) mov, 857 L1 abscall, \ findmeta 858 ax ax test, 859 L2 abs>rel jz, 860 lblmod m) 0 i) mov, 861 ax 8 i) add, 862 ret, 863 864 pc to L2 ( -- w ) \ find in sys dict 865 xdup, 866 ax lblcurword i) mov, 867 di lblsysdict m) mov, 868 lblfind abscall, 869 ax ax test, 870 xwordlbl (wnf) abs>rel jz, 871 ret, 872 873 pc to L1 \ execute imm word 874 wcall, findmod 875 di ax mov, 876 xdrop, 877 di call, 878 wjmp, stack? 879 880 xcode compword ( str -- ) 881 wcall, parse 882 di ax mov, xdrop, 883 di di test, 884 xwordlbl litn abs>rel jnz, \ literal: jump to litn 885 \ not a literal, find and compile 886 L2 abscall, \ ax=w 887 ax -9 d) 8b) $80 i) test, 888 L1 abs>rel jnz, \ immediate? execute 889 \ compile word 890 wcall, findmod 891 wjmp, branchR, 892 893 xcode [ ximm 894 lblcompiling m) 0 i) mov, 895 ret, 896 897 xcode ] 898 lblcompiling m) 1 i) mov, 899 pc 900 wcall, word 901 wcall, compword 902 lblcompiling m) -1 i) test, 903 ( pc ) abs>rel jnz, 904 ret, 905 906 xcode ; ximm 907 wcall, exit, 908 wjmp, [ 909 910 xcode runword ( str -- ) pc w>e lblsysdict pc>addr ! 911 wcall, parse 912 di ax mov, xdrop, 913 di di test, 914 lblret abs>rel jnz, \ literal: nothing to do 915 \ not a literal, find and execute 916 L2 abscall, 917 L1 absjmp, 918 919 \ Entry creation 920 xcode entry ( 'dict s -- ) 921 di ax mov, \ di=s 922 cx di 0 d) 8b) movzx, \ cx=len 923 di inc, 924 ax cx mov, 925 ax inc, 926 ax lblhere m) add, 927 ax 3 i) and, 928 forward8 jz, 929 lblhere m) ax sub, 930 lblhere m) 4 i) add, 931 forward! 932 xdrop, \ ( 'dict -- ) 933 cx push, lblwriterange abscall, cx pop, 934 cl cwrite, 935 di lblnextmeta m) mov, di dwrite, 936 lblnextmeta m) 0 i) mov, 937 di ax 0 d) mov, \ ax='dict di=dict 938 dx lblhere m) mov, 939 ax 0 d) dx mov, xdrop, ( -- ) 940 di dwrite, 941 lbl[rcnt] m) 0 i) mov, 942 ret, 943 944 xcode code 945 wcall, sysdict 946 wcall, word 947 wjmp, entry 948 949 pc to L1 \ di=meta-id 950 cx lblsysdict m) mov, 951 bp lblhere m) mov, 952 bp cx -4 d) xchg, 953 bp dwrite, di dwrite, 954 ret, 955 956 xcode code16b di EMETA_16B i) mov, L1 absjmp, 957 xcode code8b di EMETA_8B i) mov, L1 absjmp, 958 959 \ Constants that override compile-time constant names and must come last 960 PSTOP xconst PSTOP 961 RSTOP xconst RSTOP 962 963 xcode main 964 lblmainalias forward! 965 pc ( loop ) 966 wcall, word 967 wcall, runword 968 ( pc ) absjmp, 969 970 pc lblbootptr pc>addr !