*
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++
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.)
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.
*
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
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
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.
* 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
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).
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
*
* 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
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 ?
* 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
* 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
* 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
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
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 ;
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 :
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 ;
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
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 :
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
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
FCB $D2
FDB DMINUS-9
OVER FDB *+NATWID
- LDD 2,U
+ LDD NATWID,U
PSHU D
RTS
* TFR S,X ; TSX :
FCB $D0
FDB OVER-7
DROP FDB *+NATWID
- LEAU 2,U
+ LEAU NATWID,U
RTS
* LEAS 1,S ;
* LEAS 1,S ;
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
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
* 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
* 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
* 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
* 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.
* 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
* 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
FCB $B1 1
FDB ZERO-4
ONE FDB DOCON
- FDB 1
+ONEV FDB 1
*
* ======>> 54 <<
* ( --- 2 )
FCB $B2 2
FDB ONE-4
TWO FDB DOCON
- FDB 2
+TWOV FDB 2
*
* ======>> 55 <<
* ( --- 3 )
FDB FIRST-8
LIMIT FDB DOCON
FDB BUFBAS+BUFSZ
+* In 6800 model, was
* FDB MEMEND
*
* ======>> 59 <<
FDB LIMIT-8
BBUF FDB DOCON
FDB SECTSZ
+* Hardcoded in 6800 model:
* FDB 128
*
* ======>> 60 <<
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.
*
* ( --- 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
* ( --- 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
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 )
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 )
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
FDB SEMIS
*
* ======>> 86 <<
+* ( n --- )
+* Increase/decrease heap (add n to DP),
+* Should ERROR check stack/heap.
FCB $85
FCC 'ALLO' ; 'ALLOT'
FCB $D4
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
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
* 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
FDB SEMIS
*
* ======>> 91 <<
+* ( n1 n2 --- n1<n2 )
+* Return flag true if n1 is less than n2, otherwise false.
FCB $81 <
FCB $BC
FDB EQUAL-4
LESS FDB *+NATWID
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- CMPA 0,X
- LEAS 1,S ;
- BGT LESST
- BNE LESSF
- CMPB 1,X
- BHI LESST
-LESSF CLRB ;
- BRA LESSX
-LESST LDB #1
-LESSX CLRA ;
- LEAS 1,S ;
- JMP PUSHBA
+ LDD NATWID,U
+ SUBD ,U++
+ BGE FALSE
+TRUE LDD #1
+ STD ,U
+ RTS
+FALSE LDD #0
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* CMPA 0,X
+* LEAS 1,S ;
+* BGT LESST
+* BNE LESSF
+* CMPB 1,X ; Why not sub, sbc, bge?
+* BHI LESST
+* LESSF CLRB ;
+* BRA LESSX
+* LESST LDB #1
+* LESSX CLRA ;
+* LEAS 1,S ;
+* JMP PUSHBA
*
* ======>> 92 <<
+* ( n1 n2 --- n1>n2 )
+* Return flag true if n1 is greater than n2, false otherwise.
FCB $81 >
FCB $BE
FDB LESS-4
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
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
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
FDB SEMIS
*
* ======>> 107 <<
+* STATE is executing:
+* ( --- ) ( *** )
+* STATE is executing:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not executing.
FCB $85
FCC '?EXE' ; '?EXEC'
FCB $C3
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
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
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
*
* ######>> 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
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
*
* ######>> 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 <BUILDS is not IMMEDIATE,
+* and therefore executes during a definition's run-time,
+* rather than its compile-time.
+* It is not intended to be used directly,
+* but rather so that one definition word can build another.
+* Also, note that nothing particularly special happens
+* in the defining definition until DOES> executes.
+* The name <BUILDS is intended to be a reminder of what is about to occur.
+*
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
FCB $87
FCC '<BUILD' ; '<BUILDS'
FCB $D3
FDB SEMIS
*
* ======>> 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 <BUILDS provides.
+* Note that DOES> is also not IMMEDIATE.
+*
+* When the defining word containing DOES> executes the DOES> icode,
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
+* overwrites the first word of that symbol's parameter field with its own IP,
+* and pops the previous IP from the return stack.
+* The icodes which follow DOES> 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
FDB SEMIS
*
* ======>> 122 <<
+* ( strptr count --- )
+* EMIT count characters at strptr.
FCB $84
FCC 'TYP' ; 'TYPE'
FCB $C5
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
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
*
* ######>> 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 <XSPZER
+
+ FDB SPAT,LESS,ONE
FDB QERR
* prints 'empty stack'
*
FCB $80
FDB PLUS,LESS,ZBRAN
FDB QSTAC3-*
- FDB TWO
+ FDB TWO ; NOT the NATWID constant!
FDB QERR
* prints 'full stack'
*
* FDB QSTACK-9
*QFREE FDB DOCOL,SPAT,HERE,LIT8
* FCB $80
-* FDB PLUS,LESS,TWO,QERR,SEMIS
+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
*
* ######>> screen 46 <<
* ======>> 128 <<
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 ;
OSDN Git Service
