From: Joel Matthew Rees Date: Thu, 24 Jan 2019 12:38:57 +0000 (+0900) Subject: changing 2 to natwid where appropriate, etc. X-Git-Url: http://git.osdn.net/view?p=fig-forth-6809%2Ffig-forth-6809.git;a=commitdiff_plain;h=766358d63d51872befe0a8ef0eca02920bff9af4 changing 2 to natwid where appropriate, etc. --- diff --git a/fig-forth-auto6809opt.asm b/fig-forth-auto6809opt.asm index 2b39e0a..4b5098f 100644 --- a/fig-forth-auto6809opt.asm +++ b/fig-forth-auto6809opt.asm @@ -479,7 +479,7 @@ NEXT3 ; W is X until you use X for something else. (TOS points back here.) * FCB $83 FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL - FCB $D4 + FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set. FDB 0 ; link of zero to terminate dictionary scan LIT FDB *+NATWID ; Note also that it is meaningless in native code. LDD ,Y++ @@ -622,13 +622,13 @@ ZBYES LDD ,Y++ FDB ZBRAN-10 XLOOP FDB *+NATWID LDD #1 ; Borrowing from BIF-6809. -XLOOPA ADDD 2,S ; Dodge the return address. - STD 2,S - SUBD 4,S +XLOOPA ADDD NATWID,S ; Dodge the return address. + STD NATWID,S + SUBD 2*NATWID,S BLT ZBYES ; signed -XLOOPN LEAY 2,Y +XLOOPN LEAY NATWID,Y LDX ,S ; synthetic return - LEAS 6,S ; Clean up the index and limit. + LEAS 3*NATWID,S ; Clean up the index and limit. JMP ,X * CLRA ; * LDB #1 get set to increment counter by 1 (Clears N.) @@ -656,9 +656,9 @@ XLOOPN LEAY 2,Y XPLOOP FDB *+NATWID ; Borrowing from BIF-6809. LDD ,U++ ; inc val BPL XLOOPA ; Steal plain loop code for forward count. - ADDD 2,S ; Dodge the return address - STD 2,S - SUBD 4,S + ADDD NATWID,S ; Dodge the return address + STD NATWID,S + SUBD 2*NATWID,S BGT ZBYES ; signed BRA XLOOPN ; This path is less time-sensitive. * @@ -783,7 +783,7 @@ I FDB *+NATWID FCB $D4 FDB I-4 DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z - LDD 2,U ; Check the whole thing. + LDD NATWID,U ; Check the whole thing. SUBD #$30 ; ascii zero BMI DIGIT2 IF LESS THAN '0', ILLEGAL CMPD #$A @@ -795,12 +795,12 @@ DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z SUBD #7 translate 'A' thru 'F' DIGIT0 CMPD ,U ; Check the base. BPL DIGIT2 if not less than the base - STD 2,U ; Store converted digit. (High byte known zero.) + STD NATWID,U ; Store converted digit. (High byte known zero.) LDD #1 ; set valid flag DIGIT1 STD ,U ; store the flag RTS NEXT DIGIT2 LDD #0 ; set not valid flag - LEAU 2,U ; pop base + LEAU NATWID,U ; pop base BRA DIGIT1 * TFR S,X ; TSX : * LDA 3,X @@ -856,8 +856,9 @@ DIGIT2 LDD #0 ; set not valid flag FIMMED EQU $40 ; Immediate word flag. FSMUDG EQU $20 ; Smudged => definition not ready. CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte. +* Note that the SMUDGE bit is not masked out. * -* But we really want more: +* But we really want more (Thinking for a new model, need one more byte): * FCOMPI EQU $10 ; Compile-time-only. * FASSEM EQU $08 ; Assembly-language code only. * F4THLV EQU $04 ; Must not be called from assembly language code. @@ -871,7 +872,7 @@ CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte. * name is a pointer to a high-bit bracket string with length head. * vocptr is a pointer to the NFA of the tail-end (LATEST) definition * in the vocabulary to be searched. -* HIDDEN (smudged) definitions are lexically less than their name strings. +* Hidden (SMUDGEd) definitions are lexically not equal to their name strings. FCB $86 FCC '(FIND' ; '(FIND)' FCB $A9 @@ -879,7 +880,7 @@ CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte. PFIND FDB *+NATWID PSHS Y ; Have to track two pointers. * Use the stack and registers instead of temp area N. -PA0 EQU 2 ; pointer to the length byte of name being searched against +PA0 EQU NATWID ; pointer to the length byte of name being searched against PD EQU 0 ; pointer to NFA of dict word being checked * LDX PD,U ; Start in on the vocabulary (NFA). @@ -899,7 +900,7 @@ PFNDLN LDX ,X++ ; Get previous link in vocabulary. BNE PFNDLP ; Continue if link not=0 * * not found : - LEAU 2,U ; Return only false flag. + LEAU NATWID,U ; Return only false flag. LDD #0 STD ,U PULS Y,PC @@ -913,15 +914,16 @@ PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary * * found : * -FOUND LEAX 4,X - STX 2,U +FOUND LEAX 2*NATWID,X + STX NATWID,U TFR A,B CLRA STD ,U - LDB #1 + LDB #1 PSHU A,B PULS Y,PC * +* 6800 model: * NOP ; Probably leftovers from a debugging session. * NOP * PD EQU N ptr to dict word being checked @@ -1023,7 +1025,7 @@ FOUND LEAX 4,X FDB PFIND-9 ENCLOS FDB *+NATWID LDA 1,U ; Delimiter character to match against in A. - LDX 2,U ; Buffer to scan in. + LDX NATWID,U ; Buffer to scan in. CLRB ; Initialize offset. (Buffer < 256 wide!) * Scan to a non-delimiter or a NUL ENCDEL TST B,X ; NUL ? @@ -1238,8 +1240,8 @@ CMOVLE * PULS A,Y,PC ; #2~10 * Yet another way ; takes ( 37+29*count cycles ) * PSHS Y ; #2~7 -* LDX 2,U ; #2~6 -* LDY 4,U ; #3~7 +* LDX NATWID,U ; #2~6 +* LDY NATWID,U ; #3~7 * BRA CMOVLE ; #2~3 * CMOVLP * LDA ,Y+ ; #2~6 @@ -1249,12 +1251,12 @@ CMOVLE * SUBD #1 ; #3~4 * STD ,U ; #2~5 * BPL CMOVLP ; #2~3 -* LEAU 6,U ; #2~5 +* LEAU 3*NATWID,U ; #2~5 * PULS Y,PC ; #2~9 * Yet another way ; takes ( 44+24*odd+33*count/2 cycles ) * PSHS Y ; #2~7 -* LDX 2,U ; #2~6 -* LDY 4,U ; #3~7 +* LDX NATWID,U ; #2~6 +* LDY 2*NATWID,U ; #3~7 * LDD ,U ; #2~5 * BITB #1 ; #2~2 * BEQ CMOVLE ; #2~3 @@ -1272,7 +1274,7 @@ CMOVLE * SUBD #2 ; #3~4 * STD ,U ; #2~5 * BPL CMOVLP ; #2~3 -* LEAU 6,U ; #2~5 +* LEAU 3*NATWID,U ; #2~5 * PULS Y,PC ; #2~9 * From the 6800 model: * CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800 @@ -1311,23 +1313,23 @@ CMOVLE FCB $AA FDB CMOVE-8 USTAR FDB *+NATWID - LEAU -4,U - LDA 5,U ; least - LDB 7,U + LEAU -2*NATWID,U + LDA 2*NATWID+1,U ; least + LDB 3*NATWID+1,U MUL - STD 2,U - LDA 4,U ; most - LDB 6,U + STD NATWID,U + LDA 2*NATWID,U ; most + LDB 3*NATWID,U MUL STD ,U - LDD 5,U ; first inner (u2 lo, u1 hi) + LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi) MUL ADDD 1,U BCC USTAR3 INC ,U USTAR3 STD 1,U - LDA 4,U ; second inner (u2 hi) - LDB 7,U ; (u1 lo) + LDA 2*NATWID,U ; second inner (u2 hi) + LDB 3*NATWID,U ; (u1 lo) MUL ADDD 1,U BCC USTAR4 @@ -1335,8 +1337,10 @@ USTAR3 STD 1,U USTAR4 STD 1,U PULS D,X STD ,U - STX 2,U + STX NATWID,U RTS +* +* from 6800 model: * BSR USTARS * LEAS 1,S ; * LEAS 1,S ; @@ -1384,26 +1388,28 @@ USTAR4 STD 1,U USLASH FDB *+NATWID LDA #17 ; bit ct PSHS A - LDD 2,U ; dividend + LDD NATWID,U ; dividend USLDIV CMPD ,U ; divisor BHS USLSUB ANDCC #~1 ; carry clear BRA USLBIT USLSUB SUBD ,U ORCC #1 ; quotient, (carry set) -USLBIT ROL 5,U ; save it - ROL 4,U +USLBIT ROL 2*NATWID+1,U ; save it + ROL 2*NATWID,U DEC ,S ; more bits? BEQ USLR ROLB ; remainder ROLA BCC USLDIV BRA USLSUB -USLR LEAU 2,U - LDX 2,U - STD 2,U +USLR LEAU NATWID,U + LDX NATWID,U + STD NATWID,U STX ,U PULS A,PC ; Avoiding a LEAS 1,S by discarding A. +* +* from 6800 model: * LDA #17 * PSHS A ; * TFR S,X ; TSX : @@ -1560,8 +1566,10 @@ RPSTOR FDB *+NATWID FCB $D3 FDB RPSTOR-6 SEMIS FDB *+NATWID - PULS D,X - TFR D,PC ; and discard X. + PULS D,Y ; return address in D, and saved IP in Y. + TFR D,PC ; Synthetic return. +* +* Form 6800 model: * LDX RP * LEAX 1,X ; * LEAX 1,X ; @@ -1585,8 +1593,8 @@ SEMIS FDB *+NATWID FCB $C5 FDB SEMIS-5 LEAVE FDB *+NATWID - LDD 2,S ; Dodge the return address. - STD 4,S + LDD NATWID,S ; Dodge the return address. + STD 2*NATWID,S RTS * LDX RP * LDA 2,X @@ -1729,13 +1737,13 @@ PLUS FDB *+NATWID FCB $AB FDB PLUS-4 DPLUS FDB *+NATWID - LDD 6,U - ADDD 2,U - STD 6,U - LDD 4,U + LDD 3*NATWID,U + ADDD NATWID,U + STD 3*NATWID,U + LDD 2*NATWID,U ADCB 1,U ADCA ,U - LEAU 4,U + LEAU 2*NATWID,U STD ,U RTS * TFR S,X ; TSX : @@ -1765,6 +1773,8 @@ MINUS FDB *+NATWID SUBD ,U ; #2~5 STD ,U ; #2~5 RTS ; #1~5 = #8~18 +* +* from 6800 model code: * TFR S,X ; TSX : * NEG 1,X * BCC MINUS2 @@ -1782,8 +1792,8 @@ MINUS FDB *+NATWID FDB MINUS-8 DMINUS FDB *+NATWID LDD #0 ; #3~3 - SUBD 2,U ; #2~7 - STD 2,U ; #2~7 + SUBD NATWID,U ; #2~7 + STD NATWID,U ; #2~7 LDD #0 ; #3~3 SBCB 1,U ; #2~5 SBCA ,U ; #2~4 @@ -1811,7 +1821,7 @@ DMINUS FDB *+NATWID FCB $D2 FDB DMINUS-9 OVER FDB *+NATWID - LDD 2,U + LDD NATWID,U PSHU D RTS * TFR S,X ; TSX : @@ -1827,7 +1837,7 @@ OVER FDB *+NATWID FCB $D0 FDB OVER-7 DROP FDB *+NATWID - LEAU 2,U + LEAU NATWID,U RTS * LEAS 1,S ; * LEAS 1,S ; @@ -1967,9 +1977,9 @@ CAT FDB *+NATWID FCB $A1 FDB CAT-5 STORE FDB *+NATWID - LDD 2,U + LDD NATWID,U STD [,U] - LEAU 4,U + LEAU 2*NATWID,U RTS * TFR S,X ; TSX : * LDX 0,X get address @@ -1988,7 +1998,7 @@ STORE FDB *+NATWID CSTORE FDB *+NATWID LDB 3,U STB [,U] - LEAU 4,U + LEAU 2*NATWID,U RTS * TFR S,X ; TSX : * LDX 0,X get address @@ -2010,7 +2020,9 @@ CSTORE FDB *+NATWID * CREATE a header, * set state to compile, * and compile the call to the trailing native CPU machine code DOCOL. -* *** This would not be hard to flatten to native code. Maybe later. +* +* This would not be hard to flatten to native code. +* But that's not the purpose of a model. FCB $C1 : immediate FCB $BA FDB CSTORE-5 @@ -2031,8 +2043,7 @@ COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE * called it into the IP. DOCOL LDD ,S ; Save the return address. STY ,S ; Nest the old IP. - LEAX 2,X ; W still in X, bump to parameter field. - TFR X,Y ; Load the new IP. + LEAY NATWID,X ; W still in X, bump to parameters, load as new IP. TFR D,PC ; synthetic return to interpret. * DOCOL LDX RP make room in the stack @@ -2076,7 +2087,7 @@ CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE * Characteristic of a CONSTANT. * A CONSTANT simply loads its value from its parameter field * and pushes it on the stack. -DOCON LDD 2,X ; Get the first natural width word of the parameter field. +DOCON LDD NATWID,X ; Get the first natural width word of the parameter field. PSHU D RTS * DOCON LDX W @@ -2084,15 +2095,46 @@ DOCON LDD 2,X ; Get the first natural width word of the parameter field. * LDB 3,X A & B now contain the constant * JMP PUSHBA * +* Not in model, needed for abstraction: +* ( --- NATWID ) +* The byte width of objects on stack. + FCB $86 + FCC 'NATWI' ; 'NATWID' + FCB $C4 + FDB CON-11 +NATWC FDB DOCON +NATWCV FDB NATWID +* +* Not in model, needed for abstraction: +* Note that this is not defined as an INCREMENTER! +* Coded to increment by the exact constant returned by NATWID +* ( n --- n+NATWID ) + FCB $84 + FCC 'NAT' ; 'NAT+' + FCB $AB + FDB NATWC-9 +NATP FDB *+NATWID + LDD ,U + ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative. + STD ,U + RTS +* How this might have been done for 6800 model: +* CLRA ; We know the natural width is less than 255, LOL. +* LDAB NATWCV+1 +* TSX +* ADDB 1,X +* ADCA ,X +* JMP STABX +* * ======>> 50 << * ( init --- ) * { init VARIABLE name } typical input -* CREATE a header and compile the initial value, init, using CONSTANT, -* overwrite the characteristic to point to DOVAR. +* Use CONSTANT to CREATE a header and compile the initial value, init, +* then overwrite the characteristic to point to DOVAR. FCB $88 FCC 'VARIABL' ; 'VARIABLE' FCB $C5 - FDB CON-11 + FDB NATP-7 VAR FDB DOCOL,CON,PSCODE * ( --- vadr ) * Characteristic of a VARIABLE. @@ -2104,7 +2146,7 @@ VAR FDB DOCOL,CON,PSCODE * and immediately ALLOTting the remaining needed space. * VARIABLES are global to all users, * and thus should be hidden in resource monitors, but aren't. -DOVAR LEAX 2,X ; Point to the first natural width word of the parameters. +DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters. PSHU X RTS * DOVAR LDA W @@ -2131,12 +2173,28 @@ USER FDB DOCOL,CON,PSCODE * A USER variable's parameter field contains its offset in the per-user table. DOUSER TFR DP,A ; Make a pointer to the direct page. CLRB - ADDD 2,X ; Add the offset to the per-user variable. +* See Alternative -- alternatives start from this point. + ADDD NATWID,X ; Add it to the offset to the per-user variable. PSHU D + TFR D,X ; Cache the pointer in X for the caller. RTS * Hey, the per-user table could actually be larger than 256 bytes! * But we knew that. It's just not as esthetic to calculate it this way. -* +* Alternative A: +* LDX NATWID,X ; Keep the offset +* EXG D,X ; Prepare for EA +* LEAX D,X +* PSHU X +* RTS +* Alternative B: +* PSHS Y ; Get Y free for calculations. +* TFR D,Y ; Y points to the UP base +* LDD NATWID,X ; Get the offset +* LEAX D,Y ; Leave the pointer cached in X. +* PSHU X +* PULS Y,PC +* +* From the 6800 model: * DOUSER LDX W get offset into user's table * LDA 2,X * LDB 3,X @@ -2159,7 +2217,7 @@ ZERO FDB DOCON FCB $B1 1 FDB ZERO-4 ONE FDB DOCON - FDB 1 +ONEV FDB 1 * * ======>> 54 << * ( --- 2 ) @@ -2167,7 +2225,7 @@ ONE FDB DOCON FCB $B2 2 FDB ONE-4 TWO FDB DOCON - FDB 2 +TWOV FDB 2 * * ======>> 55 << * ( --- 3 ) @@ -2209,6 +2267,7 @@ FIRST FDB DOCON FDB FIRST-8 LIMIT FDB DOCON FDB BUFBAS+BUFSZ +* In 6800 model, was * FDB MEMEND * * ======>> 59 << @@ -2220,6 +2279,7 @@ LIMIT FDB DOCON FDB LIMIT-8 BBUF FDB DOCON FDB SECTSZ +* Hardcoded in 6800 model: * FDB 128 * * ======>> 60 << @@ -2232,6 +2292,7 @@ BBUF FDB DOCON FDB BBUF-8 BSCR FDB DOCON FDB SCRSZ/SECTSZ +* Hardcoded in 6800 model as: * FDB 8 * blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes. * @@ -2325,6 +2386,7 @@ DICTPT FDB DOUSER * ( --- vadr ) ******* Need to check what this is! * Used in maintaining vocabularies. * I think it points to the "parent" vocabulary, but I'm not sure. +* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. ***** FCB $88 FCC 'VOC-LIN' ; 'VOC-LINK' FCB $CB @@ -2336,8 +2398,9 @@ VOCLIN FDB DOUSER * ( --- vadr ) * Disk block being interpreted. * Zero refers to terminal. -* ******** Should be made a 32 bit variable! ******** +* ******** Should be made a 32 bit user variable! ******** * But the base system needs to have full 32 bit support, div and mul, etc. +* before we can do that. FCB $83 FCC 'BL' ; 'BLK' FCB $CB @@ -2489,22 +2552,27 @@ COLUMS FDB DOUSER FDB XCOLUM-UORIG * * ######>> screen 38 << -** Could make an incrementer compiling word: +** +** An INCREMENTER probably should not be defined without a defined CONSTANT? +** +** Make an INCREMENTER compiling word (not in model): ** ( n --- ) ** { n INCREMENTER name } typical input ** CREATE a header and compile the increment constant, ** then overwrite the header with a call to DOINC. -* FCB $84 -* FCC 'INCREMENTE' ; INCREMENTER' +* FCB $8B +* FCC 'INCREMENTE' ; 'INCREMENTER' * FCB $D2 -* FDB COLUMS-9 +* FDB COLUMS-10 * INCR FDB DOCOL,CON,PSCODE ** ( n --- ninc ) ** Characteristic of an INCREMENTER. +** This is too naive: * DOINC LDD ,U -* ADDD 2,X ; Add the increment. +* ADDD NATWID,X ; Add the increment. * STD ,U * RTS +* Compiling word should check that it is compiling a CONSTANT. * * ======>> 83 << * ( n --- n+1 ) @@ -2512,13 +2580,24 @@ COLUMS FDB DOUSER FCC '1' ; '1+' FCB $AB FDB COLUMS-10 -ONEP FDB *+NATWID - LDD ,U - ADDD #1 - STD ,U - RTS -* ONEP FDB DOCOL,ONE,PLUS -* FDB SEMIS +* Using the model keeps things semantically connected for other processors: +ONEP FDB DOCOL,ONE,PLUS + FDB SEMIS +** Greedy alternative: +* ONEP FDB *+NATWID +* LDD ,U +* ADDD ONEV,PCR +* STD ,U +* RTS +* Naive alternative: +* ONEP FDB DOINC +* FDB 1 +* Naive alternative: +* ONEP FDB *+NATWID +* LDD ,U +* ADDD #1 ; It's hard to imagine 1+ being other than 1. +* STD ,U +* RTS * * ======>> 84 << * ( n --- n+2 ) @@ -2526,15 +2605,29 @@ ONEP FDB *+NATWID FCC '2' ; '2+' FCB $AB FDB ONEP-5 -TWOP FDB *+NATWID - LDD ,U - ADDD #2 - STD ,U - RTS -* TWOP FDB DOCOL,TWO,PLUS -* FDB SEMIS +* Using the model keeps things semantically connected for other processors: +TWOP FDB DOCOL,TWO,PLUS + FDB SEMIS +** Greedy alternative: +* TWOP FDB *+NATWID +* LDD ,U +* ADDD TWOV,PCR ; See NAT+ (NATP) +* STD ,U +* RTS +* Naive alternative: +* TWOP FDB DOINC +* FDB 2 +* Naive alternative: +* TWOP FDB *+NATWID +* LDD ,U +* ADDD #2 ; See NAT+ (NATP) +* STD ,U +* RTS * * ======>> 85 << +* ( --- adr ) +* Get the DICTPT allocation, like a USER constant. +* Should check the stack and heap for collision. FCB $84 FCC 'HER' ; 'HERE' FCB $C5 @@ -2543,6 +2636,9 @@ HERE FDB DOCOL,DICTPT,AT FDB SEMIS * * ======>> 86 << +* ( n --- ) +* Increase/decrease heap (add n to DP), +* Should ERROR check stack/heap. FCB $85 FCC 'ALLO' ; 'ALLOT' FCB $D4 @@ -2551,13 +2647,21 @@ ALLOT FDB DOCOL,DICTPT,PSTORE FDB SEMIS * * ======>> 87 << +* ( n --- ) +* Store word n at DP++, +* Should ERROR check stack/heap. FCB $81 ; , (COMMA) FCB $AC FDB ALLOT-8 -COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT +COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT FDB SEMIS +* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT +* FDB SEMIS * * ======>> 88 << +* ( b --- ) +* Store byte b at DP+, +* Should ERROR check stack/heap. FCB $82 FCC 'C' ; 'C,' FCB $AC @@ -2572,7 +2676,7 @@ CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT FCB $AD FDB CCOMM-5 SUB FDB *+NATWID - LDD 2,U ; #2~6 + LDD NATWID,U ; #2~6 SUBD ,U++ ; #2~9 STD ,U ; #2~5 RTS ; #1~5 = #7~25 @@ -2580,6 +2684,8 @@ SUB FDB *+NATWID * FDB SEMIS ; Costs 6 bytes and lots of cycles. * * ======>> 90 << +* ( n1 n2 --- n1==n2 ) +* Return flag true if n1 and n2 are equal, otherwise false. FCB $81 = FCB $BD FDB SUB-4 @@ -2587,27 +2693,40 @@ EQUAL FDB DOCOL,SUB,ZEQU FDB SEMIS * * ======>> 91 << +* ( n1 n2 --- n1> 92 << +* ( n1 n2 --- n1>n2 ) +* Return flag true if n1 is greater than n2, false otherwise. FCB $81 > FCB $BE FDB LESS-4 @@ -2615,14 +2734,25 @@ GREAT FDB DOCOL,SWAP,LESS FDB SEMIS * * ======>> 93 << +* ( n1 n2 n3 --- n2 n3 n1 ) +* Rotate the top three words on stack, +* bringing the third word to the top. FCB $83 FCC 'RO' ; 'ROT' FCB $D4 FDB GREAT-4 -ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP - FDB SEMIS +ROT FDB *+NATWID + PSHS Y + PULU D,X,Y + PSHU D,X + PSHU Y + PULS Y,PC +* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP +* FDB SEMIS * * ======>> 94 << +* ( --- ) +* EMIT a SPACE. FCB $85 FCC 'SPAC' ; 'SPACE' FCB $C5 @@ -2631,99 +2761,207 @@ SPACE FDB DOCOL,BL,EMIT FDB SEMIS * * ======>> 95 << +* ( n0 n1 --- min(n0,n1) ) +* Leave the minimum of the top two integers. +* Being too greedy here, but, whatever. FCB $83 FCC 'MI' ; 'MIN' FCB $CE FDB SPACE-8 -MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN - FDB MIN2-* - FDB SWAP -MIN2 FDB DROP - FDB SEMIS +MIN FDB *+NATWID + PULU D + CMPD ,U + BLE MINX + STD ,U +MINX RTS +* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN +* FDB MIN2-* +* FDB SWAP +* MIN2 FDB DROP +* FDB SEMIS * * ======>> 96 << +* ( n0 n1 --- max(n0,n1) ) +* Leave the maximum of the top two integers. +* Really should leave this as in the model. FCB $83 FCC 'MA' ; 'MAX' FCB $D8 FDB MIN-6 -MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN - FDB MAX2-* - FDB SWAP -MAX2 FDB DROP - FDB SEMIS +MAX FDB *+NATWID + PULU D + CMPD ,U + BLE MAXX + STD ,U +MAXX RTS +* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN +* FDB MAX2-* +* FDB SWAP +* MAX2 FDB DROP +* FDB SEMIS * * ======>> 97 << +* ( 0 --- 0 ) +* ( n --- n n ) +* DUP if non-zero. FCB $84 FCC '-DU' ; '-DUP' FCB $D0 FDB MAX-6 -DDUP FDB DOCOL,DUP,ZBRAN - FDB DDUP2-* - FDB DUP -DDUP2 FDB SEMIS +DDUP FDB *+NATWID + LDD ,U + BEQ DDUPX + PSHU D +DDUPX RTS +* DDUP FDB DOCOL,DUP,ZBRAN +* FDB DDUP2-* +* FDB DUP +* DDUP2 FDB SEMIS * * ######>> screen 39 << +* ======>> 98.1 << +* Supplemental: +* ( n<0 --- -1 ) +* ( n>=~ --- 1 ) +* Change top integer to its sign. + FCB $86 + FCC 'SIGNU' ; 'SIGNUM' + FCB $CD + FDB DDUP-7 +SIGNUM FDB *+NATWID +SIGNUE LDB #1 + LDA ,U + BPL SIGNUP + NEGB +SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead? + STD ,U ; Am I too much of a prude? + RTS +* 6800 model version should be something like this: +* LDB #1 +* CLRA +* TSX +* TST ,X +* BPL SIGNUP +* NEGB +* COMA +* SIGNUP JMP STABX +* * ======>> 98 << +* ( adr1 direction --- adr2 ) +* TRAVERSE the symbol name. +* If direction is 1, find the end. +* If direction is -1, find the beginning. FCB $88 FCC 'TRAVERS' ; 'TRAVERSE' FCB $C5 - FDB DDUP-7 -TRAV FDB DOCOL,SWAP -TRAV2 FDB OVER,PLUS,LIT8 - FCB $7F - FDB OVER,CAT,LESS,ZBRAN - FDB TRAV2-* - FDB SWAP,DROP - FDB SEMIS + FDB SIGNUM-9 +TRAV FDB *+NATWID + BSR SIGNUE ; Convert negative to -, zero or positive to 1. + LDD ,U++ ; Still in D, but we have to pop it anyway. + LDX ,U ; If D is 1 or -1, so is B. + LDA #$7F +TRAVLP LEAX B,X ; Don't look at the one we start at. + CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL. + BCC TRAVLP +TRAVDN STX ,U + RTS +* Doing this in 6809 just because it can be done may be getting too greedy. +* TRAV FDB DOCOL,SWAP +* TRAV2 FDB OVER,PLUS,LIT8 +* FCB $7F +* FDB OVER,CAT,LESS,ZBRAN +* FDB TRAV2-* +* FDB SWAP,DROP +* FDB SEMIS * * ======>> 99 << +* ( --- symptr ) +* Fetch CURRENT as a per-USER constant. FCB $86 FCC 'LATES' ; 'LATEST' FCB $D4 FDB TRAV-11 LATEST FDB DOCOL,CURENT,AT,AT FDB SEMIS +* LATEST FDB *+NATWID +* Getting too greedy: +* Version 1: +* TFR DP,A +* CLRB +* TFR D,X +* LDD CURENT+NATWID,PCR +* LDX [D,X] +* PSHU X ; Leave the address in X. +* RTS +* Version 2: +* LEAX CURENT,PCR +* JSR [,X] +* PULU X +* LDX [,X] +* PSHU X +* RTS +* Too greedy, too many smantic holes to fall through. +* If the address at the CFA is made relative, +* this is part of the code that would be affected +* if it is in native CPU code. * * ======>> 100 << +* Wanted to do these as INCREMENTERs, +* but I need to stick with the model as much as possible, +* (mostly, LOL) adding code only to make the model more clear. +* ( pfa --- lfa ) +* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.) FCB $83 FCC 'LF' ; 'LFA' FCB $C1 FDB LATEST-9 LFA FDB DOCOL,LIT8 - FCB 4 +* FCB 4 + FCB 2*NATWID FDB SUB FDB SEMIS * * ======>> 101 << +* ( pfa --- cfa ) +* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.) FCB $83 FCC 'CF' ; 'CFA' FCB $C1 FDB LFA-6 -CFA FDB DOCOL,TWO,SUB +* CFA FDB DOCOL,TWO,SUB +CFA FDB DOCOL,NATWC,SUB FDB SEMIS * * ======>> 102 << +* ( pfa --- nfa ) +* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.) FCB $83 FCC 'NF' ; 'NFA' FCB $C1 FDB CFA-6 NFA FDB DOCOL,LIT8 - FCB 5 +* FCB 5 + FCB NATWID*2+1 FDB SUB,ONE,MINUS,TRAV FDB SEMIS * * ======>> 103 << +* ( nfa --- pfa ) +* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.) FCB $83 FCC 'PF' ; 'PFA' FCB $C1 FDB NFA-6 PFA FDB DOCOL,ONE,TRAV,LIT8 - FCB 5 +* FCB 5 + FCB NATWID*2+1 FDB PLUS FDB SEMIS * * ######>> screen 40 << * ======>> 104 << +* ( --- ) +* Save the parameter stack pointer in CSP for compiler checks. FCB $84 FCC '!CS' ; '!CSP' FCB $D0 @@ -2732,18 +2970,39 @@ SCSP FDB DOCOL,SPAT,CSP,STORE FDB SEMIS * * ======>> 105 << +* ( 0 n --- ) ( *** ) +* ( true n --- IN BLK ) ( anything *** nothing ) +* If flag is false, do nothing. +* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR. +* Leaves cursor position (IN) +* and currently loading block number (BLK) on stack, for analysis. +* +* This one is too important to be high-level Forth codes. +* When we have an error, we want to disturb as little as possible. FCB $86 FCC '?ERRO' ; '?ERROR' FCB $D2 FDB SCSP-7 -QERR FDB DOCOL,SWAP,ZBRAN - FDB QERR2-* - FDB ERROR,BRAN - FDB QERR3-* -QERR2 FDB DROP -QERR3 FDB SEMIS +QERR FDB *+NATWID + LDD NATWID,U + BEQ QERRNO +****** Fix ?STACK when we've fixed ERROR. + LBRA ERRORE +QERRNO LEAU 2*NATWID,U + RTS +* QERR FDB DOCOL,SWAP,ZBRAN +* FDB QERR2-* +* FDB ERROR,BRAN +* FDB QERR3-* +* QERR2 FDB DROP +* QERR3 FDB SEMIS * * ======>> 106 << +* STATE is compiling: +* ( --- ) ( *** ) +* STATE is compiling: +* ( --- IN BLK ) ( anything *** nothing ) +* ERROR if not compiling. FCB $85 FCC '?COM' ; '?COMP' FCB $D0 @@ -2754,6 +3013,11 @@ QCOMP FDB DOCOL,STATE,AT,ZEQU,LIT8 FDB SEMIS * * ======>> 107 << +* STATE is executing: +* ( --- ) ( *** ) +* STATE is executing: +* ( --- IN BLK ) ( anything *** nothing ) +* ERROR if not executing. FCB $85 FCC '?EXE' ; '?EXEC' FCB $C3 @@ -2764,6 +3028,10 @@ QEXEC FDB DOCOL,STATE,AT,LIT8 FDB SEMIS * * ======>> 108 << +* ( n1 n1 --- ) ( *** ) +* ( n1 n2 --- IN BLK ) ( anything *** nothing ) +* ERROR if top two are unequal. +* MESSAGE says compiled conditionals do not match. FCB $86 FCC '?PAIR' ; '?PAIRS' FCB $D3 @@ -2774,6 +3042,12 @@ QPAIRS FDB DOCOL,SUB,LIT8 FDB SEMIS * * ======>> 109 << +* CSP and parameter stack are balanced (equal): +* ( --- ) ( *** ) +* CSP and parameter stack are not balanced (unequal): +* ( --- IN BLK ) ( anything *** nothing ) +* ERROR if return/control stack is not at same level as last !CSP. +* Usually indicates that a definition has been left incomplete. FCB $84 FCC '?CS' ; '?CSP' FCB $D0 @@ -2784,6 +3058,11 @@ QCSP FDB DOCOL,SPAT,CSP,AT,SUB,LIT8 FDB SEMIS * * ======>> 110 << +* Active BLK input: +* ( --- ) ( *** ) +* No active BLK input: +* ( --- IN BLK ) ( anything *** nothing ) +* ERROR if not loading, i. e., if BLK is zero. FCB $88 FCC '?LOADIN' ; '?LOADING' FCB $C7 @@ -2795,14 +3074,19 @@ QLOAD FDB DOCOL,BLK,AT,ZEQU,LIT8 * * ######>> screen 41 << * ======>> 111 << +* ( --- ) +* Compile an in-line literal value from the instruction stream. FCB $87 FCC 'COMPIL' ; 'COMPILE' FCB $C5 FDB QLOAD-11 -COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA +* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA +COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA FDB SEMIS * * ======>> 112 << +* ( --- ) P +* Clear the compile state bit(s) (shift to interpret). FCB $C1 [ immediate FCB $DB FDB COMPIL-10 @@ -2810,56 +3094,110 @@ LBRAK FDB DOCOL,ZERO,STATE,STORE FDB SEMIS * * ======>> 113 << +* +STCOMP EQU $C0 +* ( --- ) +* Set the compile state bit(s) (shift to compile). FCB $81 ] FCB $DD FDB LBRAK-4 RBRAK FDB DOCOL,LIT8 - FCB $C0 + FCB STCOMP FDB STATE,STORE FDB SEMIS * * ======>> 114 << +* ( --- ) +* Toggle SMUDGE bit of LATEST definition header, +* to hide it until defined or reveal it after definition. FCB $86 FCC 'SMUDG' ; 'SMUDGE' FCB $C5 FDB RBRAK-4 SMUDGE FDB DOCOL,LATEST,LIT8 - FCB $20 + FCB FSMUDG FDB TOGGLE FDB SEMIS * * ======>> 115 << +* ( --- ) +* Set the conversion base to sixteen (b00010000). FCB $83 FCC 'HE' ; 'HEX' FCB $D8 FDB SMUDGE-9 HEX FDB DOCOL FDB LIT8 - FCB 16 + FCB 16 ; decimal sixteen FDB BASE,STORE FDB SEMIS * * ======>> 116 << +* ( --- ) +* Set the conversion base to ten (b00001010). FCB $87 FCC 'DECIMA' ; 'DECIMAL' FCB $CC FDB HEX-6 DEC FDB DOCOL FDB LIT8 - FCB 10 note: hex "A" + FCB 10 ; decimal ten FDB BASE,STORE FDB SEMIS * * ######>> screen 42 << * ======>> 117 << +* ( --- ) ( IP *** ) +* Pop the saved IP and use it to +* compile the latest symbol as a reference to a ;CODE definition; +* overwrite the code field of the symbol found by LATEST +* with the address of the low-level characteristic code +* provided in the defining definition. +* Look closely at where things return, consider the operation of R> and >R . +* +* The machine-level code which follows (;CODE) in the instruction stream +* is not executed by the defining symbol, +* but becomes the characteristic of the defined symbol. +* This is the usual way to generate the characteristics of VARIABLEs, +* CONSTANTs, COLON definitions, etc., when FORTH compiles itself. +* +* Finally, note that, if code shifts from low level back to high +* (native CPU machine code calling into a list of FORTH codes), +* the low level code can't just call a high-level definition. +* Leaf definitions can directly call other leaf definitions, +* but not non-leafs. +* It will need an anonymous list, probably embedded in the low-level code, +* and Y and X will have to be set appropriately before entering the list. FCB $87 FCC '(;CODE' ; '(;CODE)' FCB $A9 FDB DEC-10 -PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE +* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE +PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment. + FDB LATEST,PFA,CFA,STORE FDB SEMIS * * ======>> 118 << +* ( --- ) P +* ?CSP to see if there are loose ends in the defining definition +* before shifting to the assembler, +* compile (;CODE) in the defining definition's instruction stream, +* shift to interpreting, +* make the ASSEMBLER vocabulary current, +* and !CSP to mark the stack +* in preparation for assembling low-level code. +* Note that ;CODE, unlike DOES>, is IMMEDIATE, +* and compiles (;CODE), +* which will do the actual work of changing +* the LATEST definition's characteristic when the defining word runs. +* Assembly is done by the interpreter, rather than the compiler. +* I could have avoided the anomalous three-byte code fields by +* +* Note that the ASSEMBLER is not part of the model (at this time). +* That means that, until the assembler is ready, +* if you want to define low-level words, +* you have to poke (comma) in hand-assembled stuff. +* FCB $C5 immediate FCC ';COD' ; ';CODE' FCB $C5 @@ -2870,6 +3208,23 @@ SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK * * ######>> screen 43 << * ======>> 119 << +* ( --- ) C +* Make the word currently being defined +* build a header for DOES> definitions. +* Actually just compiles a CONSTANT zero +* which can be overwritten later by DOES>. +* Since the fig models were established, this technique has been deprecated. +* +* Note that executes. +* The name > 120 << +* ( --- ) ( IP *** ) C +* Define run-time behavior of definitions compiled/defined +* by a high-level defining definition -- +* the FORTH equivalent of a compiler-compiler. +* DOES> assumes that the LATEST symbol table entry +* has at least one word of parameter field, +* which is also not IMMEDIATE. +* +* When the defining word containing DOES> executes the DOES> icode, +* it overwrites the LATEST symbol's CFA with jsr in the stream +* do not execute at the defining word's run-time. +* +* Examining XDOES in the virtual machine shows +* that the defined word will execute those icodes +* which follow DOES> at its own run-time. +* +* The advantage of this kind of behaviour, +* which you will also note in ;CODE, +* is that the defined word can contain +* both operations and data to be operated on. +* This is how FORTH data objects define their own behavior. +* +* Finally, note that the effective parameter field for DOES> definitions +* starts two NATWID words after the CFA, instead of just one +* (four bytes instead of two in a sixteen-bit addressing Forth). +* +* VOCABULARYs will use this. See definition of word FORTH. FCB $85 FCC 'DOES' ; 'DOES>' FCB $BE FDB BUILDS-10 -DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE +* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE +DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment. + FDB LATEST,PFA,STORE FDB PSCODE -DODOES LDA IP - LDB IP+1 - LDX RP make room on return stack - LEAX -1,X ; - LEAX -1,X ; - STX RP - STA 2,X push return address - STB 3,X - LDX W get addr of pointer to run-time code - LEAX 1,X ; - LEAX 1,X ; - STX N stash it in scratch area - LDX 0,X get new IP - STX IP - CLRA ; get address of parameter - LDB #2 - ADDB N+1 - ADCA N - PSHS B ; and push it on data stack - PSHS A ; - JMP NEXT2 +* +* ( --- PFA+NATWID ) ( *** IP ) +* Characteristic of a DOES> defined word. +* The characteristics of DOES> definitions are written in high-level +* Forth codes rather than native CPU machine level code. +* The first parameter word points to the high-level characteristic. +* This routine's job is to push the IP, +* load the high level characteristic pointer in IP, +* and leave the address following the characteristic pointer on the stack +* so the parameter field can be accessed. +DODOES LDD ,S ; Keep the return address. + STY ,S ; Save/nest the current IP on the return stack. + LDY NATWID,X ; First parameter is new IP. + LEAX 2*NATWID,X ; Address of second parameter. + PSHU X + TFR D,PC ; Synthetic return. +* +* From the 6800 model: +* DODOES LDA IP +* LDB IP+1 +* LDX RP make room on return stack +* LEAX -1,X ; +* LEAX -1,X ; +* STX RP +* STA 2,X push return address +* STB 3,X +* LDX W get addr of pointer to run-time code +* LEAX 1,X ; +* LEAX 1,X ; +* STX N stash it in scratch area +* LDX 0,X get new IP +* STX IP +* CLRA ; get address of parameter +* LDB #2 +* ADDB N+1 +* ADCA N +* PSHS B ; and push it on data stack +* PSHS A ; +* JMP NEXT2 * * ######>> screen 44 << * ======>> 121 << +* ( strptr --- strptr+1 count ) +* Convert counted string to string and count. +* (Fetch the byte at strptr, post-increment.) FCB $85 FCC 'COUN' ; 'COUNT' FCB $D4 @@ -2916,6 +3325,8 @@ COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT FDB SEMIS * * ======>> 122 << +* ( strptr count --- ) +* EMIT count characters at strptr. FCB $84 FCC 'TYP' ; 'TYPE' FCB $C5 @@ -2931,6 +3342,8 @@ TYPE3 FDB DROP TYPE4 FDB SEMIS * * ======>> 123 << +* ( strptr count1 --- strptr count2 ) +* Supress trailing blanks (subtract count of trailing blanks from strptr). FCB $89 FCC '-TRAILIN' ; '-TRAILING' FCB $C7 @@ -2947,15 +3360,22 @@ DTRAL4 FDB XLOOP FDB SEMIS * * ======>> 124 << +* ( --- ) +* TYPE counted string out of instruction stream (updating IP). FCB $84 FCC '(."' ; '(.")' FCB $A9 FDB DTRAIL-12 -PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP +PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP FDB FROMR,PLUS,TOR,TYPE FDB SEMIS * * ======>> 125 << +* ( --- ) P +* { ." something-to-be-printed " } typical input +* Use WORD to parse to trailing quote; +* if compiling, compile XDOTQ and string parsed, +* otherwise, TYPE string. FCB $C2 immediate FCC '.' ; '."' FCB $A2 @@ -2973,13 +3393,26 @@ DOTQ2 FDB SEMIS * * ######>> screen 45 << * ======>> 126 <<== MACHINE DEPENDENT +* ( --- ) ( *** ) +* ( --- IN BLK ) ( anything *** nothing ) +* ERROR if parameter stack out of bounds. +* +* But checking whether the stack is in bounds or not +* really should not use the stack. +* And there really should be a ?RSTACK, as well. ***** FCB $86 FCC '?STAC' ; '?STACK' FCB $CB FDB DOTQ-5 -QSTACK FDB DOCOL,LIT8 - FCB $12 - FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE +* QSTACK FDB DOCOL,LIT8 +* FCB $12 +* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE +* And I'm not sure why that is the initialization constant +* instead of S0 that it's comparing against. +QSTACK FDB *+NATWID + CMPU > screen 46 << * ======>> 128 << @@ -3462,8 +3895,8 @@ STOD FDB DOCOL,DUP,ZLESS,MINUS FCB $AA FDB STOD-7 STAR FDB *+NATWID - JSR [USTAR] - LEAU 2,U ; + JSR [USTAR] ; ******* check this! + LEAU NATWID,U ; RTS * JSR USTARS * LEAS 1,S ;