Garth, I just noticed that F83 uses a "fudge-factored" index that ensures that
LOOP and
+LOOP are finished if and only if the
overflow flag is set during the index update. This greatly simplifies those two words, at the expense of a bit more work in
DO and
IHave you considered trying this modification with your 32-bit versions? If not, I don't mind giving it a try and letting you know how it goes. I've already completed the 65m32 versions (untested until I can get my simulator up and running):
Code:
| 429 ;-------------------------------------------------------------
00000182:0000017a| 430 HEAD not_imm, '(DO)'
00000183:8428444f| 430
00000184:29000000| 430
| 431 XDO: ; ( n1|u1 n2|u2 -- R: -- sys1 sys2 ) (DO)
| 432 ; '83 and ANSI standard loops terminate when the boundary
| 433 ; of limit-1 and limit is crossed, in either direction.
| 434 ; This can be conveniently implemented by making the limit
| 435 ; $80000000, so that arithmetic overflow logic can detect
| 436 ; crossing. This trick is from Laxen & Perry F83.
| 437 ; Fudge-factor = $80000000 - limit, to be added to the
| 438 ; start value. The fudge-factor is stored in place of
| 439 ; limit on the rstack, and is used by I and J to retrieve
| 439 ; the unmodified index values.
00000185:00000186| 440 .dw .+1
00000186:50000000| 441 tab ; Save initial index in b
00000187:40070000| 442 lda #$80000000 ; Get limit from 2OS and
00000188:80000000| 442
00000189:1a020000| 443 sub ,x+ ; transform it into "fudge-factor"
0000018a:62020000| 444 pda ,x+ ; Push it on rstack in place of limit
0000018b:f10c0000| 445 adb ,s ; Modified index = index + fudge
0000018c:b30c0000| 446 phb ; Push modified index on rstack
0000018d:5c0ffebf| 447 bra _next
| 448 ;-------------------------------------------------------------
0000018e:00000183| 449 HEAD not_imm, '(LOOP)'
0000018f:86284c4f| 449
00000190:4f502900| 449
| 450 XLOOP: ; ( R: sys1 sys2 -- | sys1 sys2 ) (LOOP)
| 451 ; Run-time code for LOOP. Add 1 to index, loop until
| 452 ; "fudge-factored" overflow, clean up rstack on exit
00000191:00000192| 453 .dw .+1
00000192:a3020000| 454 sta ,-x
00000193:40060001| 455 lda #1
00000194:5c0e0004| 456 bra XPLOOP+1
| 457 ;-------------------------------------------------------------
00000195:0000018f| 458 HEAD not_imm, '(+LOOP)'
00000196:87282b4c| 458
00000197:4f4f5029| 458
| 459 XPLOOP: ; ( n -- R: sys1 sys2 -- | sys1 sys2 ) (+LOOP)
| 460 ; Run-time code for +LOOP. Add n to index, loop until
| 461 ; "fudge-factored" overflow, clean up rstack on exit
00000198:00000199| 462 .dw .+1
00000199:110c0000| 463 add ,s ; index += TOS, set V if done
0000019a:a10c0000| 464 sta ,s
0000019b:62020000| 465 lda ,x+ ; Get new TOS
0000019c:5c8fffda| 466 bvc BRANCH+1 ; Not done: loop
0000019d:dc0c0002| 467 inc #2,s ; Done: clean up rstack
0000019e:5c0fffe1| 468 bra _bump ; and skip the loop branch offset
| 469 ;-------------------------------------------------------------
0000019f:00000196| 470 HEAD not_imm, 'I'
000001a0:81490000| 470
| 471 I: ; ( -- n R: sys1 sys2 -- sys1 sys2 ) I
| 472 ; Copy innermost loop index from rstack
000001a1:000001a2| 473 .dw .+1
000001a2:a3020000| 474 sta ,-x ; Make room in TOS
000001a3:410c0000| 475 lda ,s ; Get fudged index from rstack
000001a4:190c0001| 476 sub 1,s ; Un-fudge it
000001a5:5c0ffea7| 477 bra _next
| 478 ;-------------------------------------------------------------
000001a6:000001a0| 479 HEADER not_imm, 'J'
000001a7:814a0000| 479
| 480 JJ: ; ( -- n R: 4*sys -- 4*sys ) J
| 481 ; Get the second loop index from rstack
000001a8:000001a9| 482 .dw .+1
000001a9:a3020000| 483 sta ,-x ; Make room in TOS
000001aa:410c0002| 484 lda 2,s ; Get fudged index from rstack
000001ab:190c0003| 485 sub 3,s ; Un-fudge it
000001ac:5c0ffea0| 486 bra _next
| 487 ;-------------------------------------------------------------
000001ad:000001a7| 488 HEADER not_imm, 'UNLOOP'
000001ae:86554e4c| 488
000001af:4f4f5000| 488
| 489 UNLOOP: ; ( -- R: sys1 sys2 -- ) Drop loop parms UNLOOP
000001b0:000001b1| 490 .dw .+1
000001b1:dc0c0002| 491 inc #2,s ; Done: clean up rstack
000001b2:5c0ffe9a| 492 bra _next
| 156 ;-------------------------------------------------------------
Mike
Login
Register
FAQ
Search
