Implementing figFORTH on SH3 assembler
| Révision | deab3b82bdeda15f36b40adf7a9e29e5471a6203 |
|---|---|
| Taille | 70,364 octets |
| l'heure | 2014-03-17 21:13:31 |
| Auteur | Joel Matthew Rees |
| Message de Log | Through ?STACK.
|
reiisi
Fork* OPT PRT
* fig-FORTH FOR 6800
* ASSEMBLY SOURCE LISTING
* RELEASE 1
* MAY 1979
* WITH COMPILER SECURITY
* AND VARIABLE LENGTH NAMES
* RELEASE 1.00.01
* May 2013
* Modified for Joe Allen's EXORSIM, JMR
* This public domain publication is provided
* through the courtesy of:
* FORTH
* INTEREST
* GROUP
* fig
* P.O. Box 8231 - San Jose, CA 95155 - (408) 277-0668
* Further distribution must include this notice.
PAGE
NAM Copyright:FORTH Interest Group
OPT GEN,PAG
* filename FTH7.21
* === FORTH-6800 06-06-79 21:OO
* The following constitutes the original license:
*=====================LICENSE====================
* This listing is in the PUBLIC DOMAIN and
* may be freely copied or published with the
* restriction that a credit line is printed
* with the material, crediting the
* authors and the FORTH INTEREST GROUP.
* === by Dave Lion,
* === with help from
* === Bob Smith,
* === LaFarr Stuart,
* === The Forth Interest Group
* === PO Box 1105
* === San Carlos, CA 94070
* === and
* === Unbounded Computing
* === 1134-K Aster Ave.
* === Sunnyvale, CA 94086
*===================END-LICENSE==================
* Note that the assertion of attribution terms contradicts with a
* pure assignment to the public domain.
* Because of the terms, copyright should be understood
* to be asserted by the authors.
* Attribution, according to the above, should be understood
* to be required.
*
* === Modifications for Joe Allen's EXORSIM by Joel Rees, Reiisi Kenkyuu
* Modifications copyright Joel Rees, 2013.
* Permission to use, modify, distribute, and publish the modifications
* is extended under the attribution terms given above,
* with the explicitly affirmed obligation to retain intact
* all authorship and copyright notices, and license notices.
*
* Note that, under my (Joel Rees) recollection and understanding of the
* legal/political context of the original context of publication,
* right to use source code in one's possession was not considered
* deniable in any practical or meaningful sense.
* (Laws such as the DMCA had been proposed by certain advocates for
* the concept of intellectual property under other names,
* but were considered unenforceable and impracticable,
* thus contrary to the purpose of law,
* a waste of resources, and the height of discourtesy
* by the general community of software practicioners at the time,
* to the best of my understanding and recollection.)
* Thus, the lack of explicit mention of a right to use in the terms of
* the effective license should in no wise be considered to imply a
* witholding thereof.
* ===
*
* This version was developed on an AMI EVK 300 PROTO
* system using an ACIA for the I/O. All terminal 1/0
* is done in three subroutines:
* PEMIT ( word # 182 )
* PKEY ( 183 )
* PQTERM ( 184 )
*
* The FORTH words for disc related I/O follow the model
* of the FORTH Interest Group, but have not been
* tested using a real disc.
*
* Addresses in this implementation reflect the fact that,
* on the development system, it was convenient to
* write-protect memory at hex 1000, and leave the first
* 4K bytes write-enabled. As a consequence, code from
* location $1000 to lable ZZZZ could be put in ROM.
* Minor deviations from the model were made in the
* initialization and words ?STACK and FORGET
* in order to do this.
*
*
NBLK EQU 4 # of disc buffer blocks for virtual memory
* MEMEND EQU 132*NBLK+$3000 end of ram
MEMEND EQU 132*NBLK+$4000+132 end of ram with some breathing room
* each block is 132 bytes in size,
* holding 128 characters
*
* MEMTOP EQU $3FFF absolute end of all ram
MEMTOP EQU $7FFF putative absolute end of all ram
* ACIAC EQU $FBCE the ACIA control address and
ACIAC EQU $FCF4 the ACIA control address and
ACIAD EQU ACIAC+1 data address for PROTO
PAGE
* MEMORY MAP for this (not) 16K system:
* ( positioned so that systems with 4k byte write-
* protected segments can write protect FORTH )
*
* addr. contents pointer init by
* **** ******************************* ******* ******
* 3FFF (6FFF) HI
* substitute for disc mass memory
* 3210 (5294) LO,MEMEND
* 320F (5293)
* 4 buffer sectors of VIRTUAL MEMORY
* 3000 (5084) FIRST
* >>>>>> memory from here up must be RAM <<<<<<
*
* 27FF (37FF, but 38XX, with debugging code included the the "ROMable" image.)
* 6k of romable "FORTH" <== IP ABORT
* <== W
* the VIRTUAL FORTH MACHINE
*
* 1004 <<< WARM START ENTRY >>> (2004)
* 1000 <<< COLD START ENTRY >>> (2000)
*
* >>>>>> memory from here down must be RAM <<<<<<
* FFE (1FF0) RETURN STACK base <== RP RINIT
*
* FB4 (less than 1EB4)
* INPUT LINE BUFFER
* holds up to 132 characters
* and is scanned upward by IN
* starting at TIB
* F30 (1E00) <== IN TIB
* F2F (1DF0) DATA STACK <== SP SP0,SINIT
* | grows downward from F2F
* v
* - -
* |
* I DICTIONARY grows upward
*
* 183 (183) end of ram-dictionary. <== DP DPINIT
* "TASK"
*
* 150 (150) "FORTH" ( a word ) <=, <== CONTEXT
* `==== CURRENT
* 148 (148) start of ram-dictionary.
*
* 100 (100) user #l table of variables <= UP DPINIT
* F0 (B0) registers & pointers for the virtual machine
* scratch area used by various words
* E0 (A0) lowest address used by FORTH
*
* 0000
PAGE
***
*
* CONVENTIONS USED IN THIS PROGRAM ARE AS FOLLOWS :
*
* IP points to the current instruction ( pre-increment mode )
* RP points to second free byte (first free word) in return stack
* SP (hardware SP) points to first free byte in data stack
*
* when A and B hold one 16 bit FORTH data word,
* A contains the high byte, B, the low byte.
***
* ORG $E0 variables
ORG $A0 variables
N RMB 10 used as scratch by (FIND),ENCLOSE,CMOVE,EMIT,KEY,
* SP@,SWAP,DOES>,COLD
* These locations are used by the TRACE routine :
TRLIM RMB 1 the count for tracing without user intervention
TRACEM RMB 1 non-zero = trace mode
BRKPT RMB 2 the breakpoint address at which
* the program will go into trace mode
VECT RMB 2 vector to machine code
* (only needed if the TRACE routine is resident)
* Registers used by the FORTH virtual machine:
* Starting at $OOFO ($00B0):
W RMB 2 the instruction register points to 6800 code
IP RMB 2 the instruction pointer points to pointer to 6800 code
RP RMB 2 the return stack pointer
UP RMB 2 the pointer to base of current user's 'USER' table
* ( altered during multi-tasking )
*
* For the tracer:
RMB 4
TRASP RMB 2
TRAVEC RMB 2
TRAA RMB 1
TRAB RMB 1
*
PAGE
* This system is shown with one user, but additional users
* may be added by allocating additional user tables:
* UORIG2 RMB 64 data table for user #2
*
*
* Some of this stuff gets initialized during
* COLD start and WARM start:
* [ names correspond to FORTH words of similar (no X) name ]
*
ORG $100
* ORG $1100
UORIG RMB 6 3 reserved variables
XSPZER RMB 2 initial top of data stack for this user
XRZERO RMB 2 initial top of return stack
XTIB RMB 2 start of terminal input buffer
XWIDTH RMB 2 name field width
XWARN RMB 2 warning message mode (0 = no disc)
XFENCE RMB 2 fence for FORGET
XDP RMB 2 dictionary pointer
XVOCL RMB 2 vocabulary linking
XBLK RMB 2 disc block being accessed
XIN RMB 2 scan pointer into the block
XOUT RMB 2 cursor position
XSCR RMB 2 disc screen being accessed ( O=terminal )
XOFSET RMB 2 disc sector offset for multi-disc
XCONT RMB 2 last word in primary search vocabulary
XCURR RMB 2 last word in extensible vocabulary
XSTATE RMB 2 flag for 'interpret' or 'compile' modes
XBASE RMB 2 number base for I/O numeric conversion
XDPL RMB 2 decimal point place
XFLD RMB 2
XCSP RMB 2 current stack position, for compile checks
XRNUM RMB 2
XHLD RMB 2
XDELAY RMB 2 carriage return delay count
XCOLUM RMB 2 carriage width
IOSTAT RMB 2 last acia status from write/read
RMB 2 ( 4 spares! )
RMB 2
RMB 2
RMB 2
*
*
* end of user table, start of common system variables
*
*
*
XUSE RMB 2
XPREV RMB 2
RMB 4 ( spares )
PAGE
* These things, up through the lable 'REND', are overwritten
* at time of cold load and should have the same contents
* as shown here:
*
FCB $C5 immediate
FCC 4,FORTH
FCB $C8
FDB NOOP-7
FORTH FDB DODOES,DOVOC,$81A0,TASK-7
FDB 0
*
FCC "(C) Forth Interest Group, 1979"
FCB $84
FCC 3,TASK
FCB $CB
FDB FORTH-8
TASK FDB DOCOL,SEMIS
*
REND EQU * ( first empty location in dictionary )
PAGE
* The FORTH program ( address $1000 ($2000) to $27FF (37FF?) ) is written
* so that it can be in a ROM, or write-protected if desired
ORG $2000
* ######>> screen 3 <<
*
***************************
** C O L D E N T R Y **
***************************
ORIG NOP
JMP CENT
***************************
** W A R M E N T R Y **
***************************
NOP
JMP WENT warm-start code, keeps current dictionary intact
*
******* startup parmeters **************************
*
FDB $6800,0000 cpu & revision
FDB 0 topmost word in FORTH vocabulary
BACKSP FDB $7F backspace character for editing
UPINIT FDB UORIG initial user area
*SINIT FDB ORIG-$D0 initial top of data stack
SINIT FDB ORIG-$210 initial top of data stack
*RINIT FDB ORIG-2 initial top of return stack
RINIT FDB ORIG-$10 initial top of return stack
* FDB ORIG-$D0 terminal input buffer
FDB ORIG-$200 terminal input buffer
FDB 31 initial name field width
FDB 0 initial warning mode (0 = no disc)
FENCIN FDB REND initial fence
DPINIT FDB REND cold start value for DP
VOCINT FDB FORTH+8
COLINT FDB 132 initial terminal carriage width
DELINT FDB 4 initial carriage return delay
****************************************************
*
PAGE
*
* ######>> screen 13 <<
PULABX PUL A 24 cycles until 'NEXT'
PUL B
STABX STA A 0,X 16 cycles until 'NEXT'
STA B 1,X
BRA NEXT
GETX LDA A 0,X 18 cycles until 'NEXT'
LDA B 1,X
PUSHBA PSH B 8 cycles until 'NEXT'
PSH A
*
* "NEXT" takes 38 cycles if TRACE is removed,
*
* and 95 cycles if NOT tracing.
*
* = = = = = = = t h e v i r t u a l m a c h i n e = = = = =
* =
NEXT LDX IP
INX pre-increment mode
INX
STX IP
NEXT2 LDX 0,X get W which points to CFA of word to be done
NEXT3 STX W
LDX 0,X get VECT which points to executable code
* =
* The next instruction could be patched to JMP TRACE =
* if a TRACE routine is available: =
* =
* Or add the TRACE routine in-line, since we are assembling it.
TST TRACEM
BEQ NEXTGO
STX TRAVEC
TSX ; So the funn 6800 stack doesn't beach us.
STX TRASP
LDA A #':'
JSR PEMIT
LDA A #' '
JSR PEMIT
LDX W
DEX
DEX ; allocation link
DEX ; last char
LDA A #31
NAMTST DEX ; length byte?
LDA B 0,X
BMI NAMTDN
DEC A
BNE NAMTST
NAMTDN AND B #31 ; It's the length byte whether it wants to be or not.
NAMSHW INX
LDA A 0,X
JSR PEMIT
DEC B
BNE NAMSHW
* show the virtual registers
LDA A #' '
JSR PEMIT
LDA A #'@'
LDX #TRAVEC
JSR PHEX4F
LDA A #'W'
LDX #W
JSR PHEX4F
LDA A #'I'
JSR PHEX4F
LDA A #'R'
JSR PHEX4F
LDA A #'U'
JSR PHEX4F
LDA A #'S'
LDX #TRASP
BSR PHEX4F
LDA A #'>'
TSX
BSR PHEX4F
LDA A #' '
BSR PHEX4F
*
JSR PCR
LDX TRAVEC
*
NEXTGO JMP 0,X
NOP
* JMP TRACE ( an alternate for the above )
* =
*DBG
PHEX4F JSR PEMIT
BSR PHEXX2
BSR PHEXX2
LDA A #' '
JSR PEMIT
RTS
PHEXX2 LDA A 0,X
LSR A
LSR A
LSR A
LSR A
JSR PHEXD
LDA A 0,X
JSR PHEXD
INX
RTS
PHEXD AND A #$0F
CMP A #10
BLO PHEXDH
ADD A #7 ; 'A'-'9'+1
PHEXDH ADD A #'0'
JSR PEMIT
RTS
*DBG
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
PAGE
*
* ======>> 1 <<
FCB $83
FCC 2,LIT NOTE: this is different from LITERAL
FCB $D4
FDB 0 link of zero to terminate dictionary scan
LIT FDB *+2
LDX IP
INX
INX
STX IP
LDA A 0,X
LDA B 1,X
JMP PUSHBA
*
* ######>> screen 14 <<
* ======>> 2 <<
*DBG
FCB $85
FCC 4,XCLIT ; for debugging
FCB $D4
FDB LIT-6 ; should never link
*DBG
CLITER FDB *+2 (this is an invisible word, with no header)
LDX IP
INX
STX IP
CLR A
LDA B 1,X
JMP PUSHBA
*
* ======>> 3 <<
FCB $87
FCC 6,EXECUTE
FCB $C5
FDB LIT-6
EXEC FDB *+2
TSX
LDX 0,X get code field address (CFA)
INS pop stack
INS
JMP NEXT3
*
* ######>> screen 15 <<
* ======>> 4 <<
FCB $86
FCC 5,BRANCH
FCB $C8
FDB EXEC-10
BRAN FDB ZBYES Go steal code in ZBRANCH
*
* ======>> 5 <<
FCB $87
FCC 6,0BRANCH
FCB $C8
FDB BRAN-9
ZBRAN FDB *+2
PULA
PULB
ABA
BNE ZBNO
BCS ZBNO
ZBYES LDX IP Note: code is shared with BRANCH, (+LOOP), (LOOP)
LDA B 3,X
LDA A 2,X
ADD B IP+1
ADC A IP
STA B IP+1
STA A IP
JMP NEXT
ZBNO LDX IP no branch. This code is shared with (+LOOP), (LOOP).
INX jump over branch delta
INX
STX IP
JMP NEXT
*
* ######>> screen 16 <<
* ======>> 6 <<
FCB $86
FCC 5,(LOOP)
FCB $A9
FDB ZBRAN-10
XLOOP FDB *+2
CLR A
LDA B #1 get set to increment counter by 1
BRA XPLOP2 go steal other guy's code!
*
* ======>> 7 <<
FCB $87
FCC 6,(+LOOP)
FCB $A9
FDB XLOOP-9
XPLOOP FDB *+2 Note: +LOOP has an un-signed loop counter
PUL A get increment
PUL B
XPLOP2 TST A
BPL XPLOF forward looping
BSR XPLOPS
SEC
SBC B 5,X
SBC A 4,X
BPL ZBYES
BRA XPLONO fall through
*
* the subroutine :
XPLOPS LDX RP
ADD B 3,X add it to counter
ADC A 2,X
STA B 3,X store new counter value
STA A 2,X
RTS
*
XPLOF BSR XPLOPS
SUB B 5,X
SBC A 4,X
BMI ZBYES
*
XPLONO INX done, don't branch back
INX
INX
INX
STX RP
BRA ZBNO use ZBRAN to skip over unused delta
*
* ######>> screen 17 <<
* ======>> 8 <<
FCB $84
FCC 3,(DO)
FCB $A9
FDB XPLOOP-10
XDO FDB *+2 This is the RUNTIME DO, not the COMPILING DO
LDX RP
DEX
DEX
DEX
DEX
STX RP
PUL A
PUL B
STA A 2,X
STA B 3,X
PUL A
PUL B
STA A 4,X
STA B 5,X
JMP NEXT
*
* ======>> 9 <<
FCB $81 I
FCB $C9
FDB XDO-7
I FDB *+2
LDX RP
INX
INX
JMP GETX
*
* ######>> screen 18 <<
* ======>> 10 <<
FCB $85
FCC 4,DIGIT
FCB $D4
FDB I-4
DIGIT FDB *+2 NOTE: legal input range is 0-9, A-Z
TSX
LDA A 3,X
SUB A #$30 ascii zero
BMI DIGIT2 IF LESS THAN '0', ILLEGAL
CMP A #$A
BMI DIGIT0 IF '9' OR LESS
CMP A #$11
BMI DIGIT2 if less than 'A'
CMP A #$2B
BPL DIGIT2 if greater than 'Z'
SUB A #7 translate 'A' thru 'F'
DIGIT0 CMP A 1,X
BPL DIGIT2 if not less than the base
LDA B #1 set flag
STA A 3,X store digit
DIGIT1 STA B 1,X store the flag
JMP NEXT
DIGIT2 CLR B
INS
INS pop bottom number
TSX
STA B 0,X make sure both bytes are 00
BRA DIGIT1
*
* ######>> screen 19 <<
*
* The word format in the dictionary is:
*
* char-count + $80 lowest address
* char 1
* char 2
*
* char n + $80
* link high byte \___point to previous word
* link low byte /
* CFA high byte \___pnt to 6800 code
* CFA low byte /
* parameter fields
* "
* "
* "
*
* ======>> 11 <<
FCB $86
FCC 5,(FIND)
FCB $A9
FDB DIGIT-8
PFIND FDB *+2
NOP
NOP
PD EQU N ptr to dict word being checked
PA0 EQU N+2
PA EQU N+4
PC EQU N+6
LDX #PD
LDA B #4
PFIND0 PUL A loop to get arguments
STA A 0,X
INX
DEC B
BNE PFIND0
*
LDX PD
PFIND1 LDA B 0,X get count dict count
STA B PC
AND B #$3F
INX
STX PD update PD
LDX PA0
LDA A 0,X get count from arg
INX
STX PA intialize PA
CBA compare lengths
BNE PFIND4
PFIND2 LDX PA
LDA A 0,X
INX
STX PA
LDX PD
LDA B 0,X
INX
STX PD
TST B is dict entry neg. ?
BPL PFIND8
AND B #$7F clear sign
CBA
BEQ FOUND
PFIND3 LDX 0,X get new link
BNE PFIND1 continue if link not=0
*
* not found :
*
CLR A
CLR B
JMP PUSHBA
PFIND8 CBA
BEQ PFIND2
PFIND4 LDX PD
PFIND9 LDA B 0,X scan forward to end of this name
INX
BPL PFIND9
BRA PFIND3
*
* found :
*
FOUND LDA A PD compute CFA
LDA B PD+1
ADD B #4
ADC A #0
PSH B
PSH A
LDA A PC
PSH A
CLR A
PSH A
LDA B #1
JMP PUSHBA
*
PSH A
CLR A
PSH A
LDA B #1
JMP PUSHBA
*
* ######>> screen 20 <<
* ======>> 12 <<
FCB $87
FCC 6,ENCLOSE
FCB $C5
FDB PFIND-9
* NOTE :
* FC means offset (bytes) to First Character of next word
* EW " " to End of Word
* NC " " to Next Character to start next enclose at
ENCLOS FDB *+2
INS
PUL B now, get the low byte, for an 8-bit delimiter
TSX
LDX 0,X
CLR N
* wait for a non-delimiter or a NUL
ENCL2 LDA A 0,X
BEQ ENCL6
CBA CHECK FOR DELIM
BNE ENCL3
INX
INC N
BRA ENCL2
* found first character. Push FC
ENCL3 LDA A N found first char.
PSH A
CLR A
PSH A
* wait for a delimiter or a NUL
ENCL4 LDA A 0,X
BEQ ENCL7
CBA ckech for delim.
BEQ ENCL5
INX
INC N
BRA ENCL4
* found EW. Push it
ENCL5 LDA B N
CLR A
PSH B
PSH A
* advance and push NC
INC B
JMP PUSHBA
* found NUL before non-delimiter, therefore there is no word
ENCL6 LDA B N found NUL
PSH B
PSH A
INC B
BRA ENCL7+2
* found NUL following the word instead of SPACE
ENCL7 LDA B N
PSH B save EW
PSH A
ENCL8 LDA B N save NC
JMP PUSHBA
PAGE
*
* ######>> screen 21 <<
* The next 4 words call system dependant I/O routines
* which are listed after word "-->" ( lable: "arrow" )
* in the dictionary.
*
* ======>> 13 <<
FCB $84
FCC 3,EMIT
FCB $D4
FDB ENCLOS-10
EMIT FDB *+2
PUL A
PUL A
JSR PEMIT
LDX UP
INC XOUT+1-UORIG,X
BNE *+4
INC XOUT-UORIG,X
JMP NEXT
*
* ======>> 14 <<
FCB $83
FCC 2,KEY
FCB $D9
FDB EMIT-7
KEY FDB *+2
JSR PKEY
PSH A
CLR A
PSH A
JMP NEXT
*
* ======>> 15 <<
FCB $89
FCC 8,?TERMINAL
FCB $CC
FDB KEY-6
QTERM FDB *+2
JSR PQTER
CLR B
JMP PUSHBA stack the flag
*
* ======>> 16 <<
FCB $82
FCC 1,CR
FCB $D2
FDB QTERM-12
CR FDB *+2
JSR PCR
JMP NEXT
*
* ######>> screen 22 <<
* ======>> 17 <<
FCB $85
FCC 4,CMOVE source, destination, count
FCB $C5
FDB CR-5
CMOVE FDB *+2 takes ( 43+47*count cycles )
LDX #N
LDA B #6
CMOV1 PUL A
STA A 0,X move parameters to scratch area
INX
DEC B
BNE CMOV1
CMOV2 LDA A N
LDA B N+1
SUB B #1
SBC A #0
STA A N
STA B N+1
BCS CMOV3
LDX N+4
LDA A 0,X
INX
STX N+4
LDX N+2
STA A 0,X
INX
STX N+2
BRA CMOV2
CMOV3 JMP NEXT
*
* ######>> screen 23 <<
* ======>> 18 <<
FCB $82
FCC 1,U*
FCB $AA
FDB CMOVE-8
USTAR FDB *+2
BSR USTARS
INS
INS
JMP PUSHBA
*
* The following is a subroutine which
* multiplies top 2 words on stack,
* leaving 32-bit result: high order word in A,B
* low order word in 2nd word of stack.
*
USTARS LDA A #16 bits/word counter
PSH A
CLR A
CLR B
TSX
USTAR2 ROR 5,X shift multiplier
ROR 6,X
DEC 0,X done?
BMI USTAR4
BCC USTAR3
ADD B 4,X
ADC A 3,X
USTAR3 ROR A
ROR B shift result
BRA USTAR2
USTAR4 INS dump counter
RTS
*
* ######>> screen 24 <<
* ======>> 19 <<
FCB $82
FCC 1,U/
FCB $AF
FDB USTAR-5
USLASH FDB *+2
LDA A #17
PSH A
TSX
LDA A 3,X
LDA B 4,X
USL1 CMP A 1,X
BHI USL3
BCS USL2
CMP B 2,X
BCC USL3
USL2 CLC
BRA USL4
USL3 SUB B 2,X
SBC A 1,X
SEC
USL4 ROL 6,X
ROL 5,X
DEC 0,X
BEQ USL5
ROL B
ROL A
BCC USL1
BRA USL3
USL5 INS
INS
INS
INS
INS
JMP SWAP+4 reverse quotient & remainder
*
* ######>> screen 25 <<
* ======>> 20 <<
FCB $83
FCC 2,AND
FCB $C4
FDB USLASH-5
AND FDB *+2
PUL A
PUL B
TSX
AND B 1,X
AND A 0,X
JMP STABX
*
* ======>> 21 <<
FCB $82
FCC 1,OR
FCB $D2
FDB AND-6
OR FDB *+2
PUL A
PUL B
TSX
ORA B 1,X
ORA A 0,X
JMP STABX
*
* ======>> 22 <<
FCB $83
FCC 2,XOR
FCB $D2
FDB OR-5
XOR FDB *+2
PUL A
PUL B
TSX
EOR B 1,X
EOR A 0,X
JMP STABX
*
* ######>> screen 26 <<
* ======>> 23 <<
FCB $83
FCC 2,SP@
FCB $C0
FDB XOR-6
SPAT FDB *+2
TSX
STX N scratch area
LDX #N
JMP GETX
*
* ======>> 24 <<
FCB $83
FCC 2,SP!
FCB $A1
FDB SPAT-6
SPSTOR FDB *+2
LDX UP
LDX XSPZER-UORIG,X
TXS watch it ! X and S are not equal.
JMP NEXT
* ======>> 25 <<
FCB $83
FCC 2,RP!
FCB $A1
FDB SPSTOR-6
RPSTOR FDB *+2
LDX RINIT initialize from rom constant
STX RP
JMP NEXT
*
* ======>> 26 <<
FCB $82
FCC 1,;S
FCB $D3
FDB RPSTOR-6
SEMIS FDB *+2
LDX RP
INX
INX
STX RP
LDX 0,X get address we have just finished.
JMP NEXT+2 increment the return address & do next word
*
* ######>> screen 27 <<
* ======>> 27 <<
FCB $85
FCC 4,LEAVE
FCB $C5
FDB SEMIS-5
LEAVE FDB *+2
LDX RP
LDA A 2,X
LDA B 3,X
STA A 4,X
STA B 5,X
JMP NEXT
*
* ======>> 28 <<
FCB $82
FCC 1,>R
FCB $D2
FDB LEAVE-8
TOR FDB *+2
LDX RP
DEX
DEX
STX RP
PUL A
PUL B
STA A 2,X
STA B 3,X
JMP NEXT
*
* ======>> 29 <<
FCB $82
FCC 1,R>
FCB $BE
FDB TOR-5
FROMR FDB *+2
LDX RP
LDA A 2,X
LDA B 3,X
INX
INX
STX RP
JMP PUSHBA
*
* ======>> 30 <<
FCB $81 R
FCB $D2
FDB FROMR-5
R FDB *+2
LDX RP
INX
INX
JMP GETX
*
* ######>> screen 28 <<
* ======>> 31 <<
FCB $82
FCC 1,0=
FCB $BD
FDB R-4
ZEQU FDB *+2
TSX
CLR A
CLR B
LDX 0,X
BNE ZEQU2
INC B
ZEQU2 TSX
JMP STABX
*
* ======>> 32 <<
FCB $82
FCC 1,0<
FCB $BC
FDB ZEQU-5
ZLESS FDB *+2
TSX
LDA A #$80 check the sign bit
AND A 0,X
BEQ ZLESS2
CLR A if neg.
LDA B #1
JMP STABX
ZLESS2 CLR B
JMP STABX
*
* ######>> screen 29 <<
* ======>> 33 <<
FCB $81 '+'
FCB $AB
FDB ZLESS-5
PLUS FDB *+2
PUL A
PUL B
TSX
ADD B 1,X
ADC A 0,X
JMP STABX
*
* ======>> 34 <<
FCB $82
FCC 1,D+
FCB $AB
FDB PLUS-4
DPLUS FDB *+2
TSX
CLC
LDA B #4
DPLUS2 LDA A 3,X
ADC A 7,X
STA A 7,X
DEX
DEC B
BNE DPLUS2
INS
INS
INS
INS
JMP NEXT
*
* ======>> 35 <<
FCB $85
FCC 4,MINUS
FCB $D3
FDB DPLUS-5
MINUS FDB *+2
TSX
NEG 1,X
BCC MINUS2
NEG 0,X
BRA MINUS3
MINUS2 COM 0,X
MINUS3 JMP NEXT
*
* ======>> 36 <<
FCB $86
FCC 5,DMINUS
FCB $D3
FDB MINUS-8
DMINUS FDB *+2
TSX
COM 0,X
COM 1,X
COM 2,X
NEG 3,X
BNE DMINX
INC 2,X
BNE DMINX
INC 1,X
BNE DMINX
INC 0,X
DMINX JMP NEXT
*
* ######>> screen 30 <<
* ======>> 37 <<
FCB $84
FCC 3,OVER
FCB $D2
FDB DMINUS-9
OVER FDB *+2
TSX
LDA A 2,X
LDA B 3,X
JMP PUSHBA
*
* ======>> 38 <<
FCB $84
FCC 3,DROP
FCB $D0
FDB OVER-7
DROP FDB *+2
INS
INS
JMP NEXT
*
* ======>> 39 <<
FCB $84
FCC 3,SWAP
FCB $D0
FDB DROP-7
SWAP FDB *+2
PUL A
PUL B
TSX
LDX 0,X
INS
INS
PSH B
PSH A
STX N
LDX #N
JMP GETX
*
* ======>> 40 <<
FCB $83
FCC 2,DUP
FCB $D0
FDB SWAP-7
DUP FDB *+2
PUL A
PUL B
PSH B
PSH A
JMP PUSHBA
*
* ######>> screen 31 <<
* ======>> 41 <<
FCB $82
FCC 1,+!
FCB $A1
FDB DUP-6
PSTORE FDB *+2
TSX
LDX 0,X
INS
INS
PUL A get stack data
PUL B
ADD B 1,X add & store low byte
STA B 1,X
ADC A 0,X add & store hi byte
STA A 0,X
JMP NEXT
*
* ======>> 42 <<
FCB $86
FCC 5,TOGGLE
FCB $C5
FDB PSTORE-5
TOGGLE FDB DOCOL,OVER,CAT,XOR,SWAP,CSTORE
FDB SEMIS
*
* ######>> screen 32 <<
* ======>> 43 <<
FCB $81 @
FCB $C0
FDB TOGGLE-9
AT FDB *+2
TSX
LDX 0,X get address
INS
INS
JMP GETX
*
* ======>> 44 <<
FCB $82
FCC 1,C@
FCB $C0
FDB AT-4
CAT FDB *+2
TSX
LDX 0,X
CLR A
LDA B 0,X
INS
INS
JMP PUSHBA
*
* ======>> 45 <<
FCB $81
FCB $A1
FDB CAT-5
STORE FDB *+2
TSX
LDX 0,X get address
INS
INS
JMP PULABX
*
* ======>> 46 <<
FCB $82
FCC 1,C!
FCB $A1
FDB STORE-4
CSTORE FDB *+2
TSX
LDX 0,X get address
INS
INS
INS
PUL B
STA B 0,X
JMP NEXT
PAGE
*
* ######>> screen 33 <<
* ======>> 47 <<
FCB $C1 : immediate
FCB $BA
FDB CSTORE-5
COLON FDB DOCOL,QEXEC,SCSP,CURENT,AT,CONTXT,STORE
FDB CREATE,RBRAK
FDB PSCODE
* Here is the IP pusher for allowing
* nested words in the virtual machine:
* ( ;S is the equivalent un-nester )
DOCOL LDX RP make room in the stack
DEX
DEX
STX RP
LDA A IP
LDA B IP+1
STA A 2,X Store address of the high level word
STA B 3,X that we are starting to execute
LDX W Get first sub-word of that definition
JMP NEXT+2 and execute it
*
* ======>> 48 <<
FCB $C1 ; imnediate code
FCB $BB
FDB COLON-4
SEMI FDB DOCOL,QCSP,COMPIL,SEMIS,SMUDGE,LBRAK
FDB SEMIS
*
* ######>> screen 34 <<
* ======>> 49 <<
FCB $88
FCC 7,CONSTANT
FCB $D4
FDB SEMI-4
CON FDB DOCOL,CREATE,SMUDGE,COMMA,PSCODE
DOCON LDX W
LDA A 2,X
LDA B 3,X A & B now contain the constant
JMP PUSHBA
*
* ======>> 50 <<
FCB $88
FCC 7,VARIABLE
FCB $C5
FDB CON-11
VAR FDB DOCOL,CON,PSCODE
DOVAR LDA A W
LDA B W+1
ADD B #2
ADC A #0 A,B now contain the address of the variable
JMP PUSHBA
*
* ======>> 51 <<
FCB $84
FCC 3,USER
FCB $D2
FDB VAR-11
USER FDB DOCOL,CON,PSCODE
DOUSER LDX W get offset into user's table
LDA A 2,X
LDA B 3,X
ADD B UP+1 add to users base address
ADC A UP
JMP PUSHBA push address of user's variable
*
* ######>> screen 35 <<
* ======>> 52 <<
FCB $81
FCB $B0 0
FDB USER-7
ZERO FDB DOCON
FDB 0000
*
* ======>> 53 <<
FCB $81
FCB $B1 1
FDB ZERO-4
ONE FDB DOCON
FDB 1
*
* ======>> 54 <<
FCB $81
FCB $B2 2
FDB ONE-4
TWO FDB DOCON
FDB 2
*
* ======>> 55 <<
FCB $81
FCB $B3 3
FDB TWO-4
THREE FDB DOCON
FDB 3
*
* ======>> 56 <<
FCB $82
FCC 1,BL
FCB $CC
FDB THREE-4
BL FDB DOCON ascii blank
FDB $20
*
* ======>> 57 <<
FCB $85
FCC 4,FIRST
FCB $D4
FDB BL-5
FIRST FDB DOCON
FDB MEMEND-528 (132 * NBLK)
*
* ======>> 58 <<
FCB $85
FCC 4,LIMIT ( the end of memory +1 )
FCB $D4
FDB FIRST-8
LIMIT FDB DOCON
FDB MEMEND
*
* ======>> 59 <<
FCB $85
FCC 4,B/BUF (bytes/buffer)
FCB $C6
FDB LIMIT-8
BBUF FDB DOCON
FDB 128
*
* ======>> 60 <<
FCB $85
FCC 4,B/SCR (blocks/screen)
FCB $D2
FDB BBUF-8
BSCR FDB DOCON
FDB 8
* blocks/screen = 1024 / "B/BUF" = 8
*
* ======>> 61 <<
FCB $87
FCC 6,+ORIGIN
FCB $CE
FDB BSCR-8
PORIG FDB DOCOL,LIT,ORIG,PLUS
FDB SEMIS
*
* ######>> screen 36 <<
* ======>> 62 <<
FCB $82
FCC 1,S0
FCB $B0
FDB PORIG-10
SZERO FDB DOUSER
FDB XSPZER-UORIG
*
* ======>> 63 <<
FCB $82
FCC 1,R0
FCB $B0
FDB SZERO-5
RZERO FDB DOUSER
FDB XRZERO-UORIG
*
* ======>> 64 <<
FCB $83
FCC 2,TIB
FCB $C2
FDB RZERO-5
TIB FDB DOUSER
FDB XTIB-UORIG
*
* ======>> 65 <<
FCB $85
FCC 4,WIDTH
FCB $C8
FDB TIB-6
WIDTH FDB DOUSER
FDB XWIDTH-UORIG
*
* ======>> 66 <<
FCB $87
FCC 6,WARNING
FCB $C7
FDB WIDTH-8
WARN FDB DOUSER
FDB XWARN-UORIG
*
* ======>> 67 <<
FCB $85
FCC 4,FENCE
FCB $C5
FDB WARN-10
FENCE FDB DOUSER
FDB XFENCE-UORIG
*
* ======>> 68 <<
FCB $82
FCC 1,DP points to first free byte at end of dictionary
FCB $D0
FDB FENCE-8
DP FDB DOUSER
FDB XDP-UORIG
*
* ======>> 68.5 <<
FCB $88
FCC 7,VOC-LINK
FCB $CB
FDB DP-5
VOCLIN FDB DOUSER
FDB XVOCL-UORIG
*
* ======>> 69 <<
FCB $83
FCC 2,BLK
FCB $CB
FDB VOCLIN-11
BLK FDB DOUSER
FDB XBLK-UORIG
*
* ======>> 70 <<
FCB $82
FCC 1,IN scan pointer for input line buffer
FCB $CE
FDB BLK-6
IN FDB DOUSER
FDB XIN-UORIG
*
* ======>> 71 <<
FCB $83
FCC 2,OUT
FCB $D4
FDB IN-5
OUT FDB DOUSER
FDB XOUT-UORIG
*
* ======>> 72 <<
FCB $83
FCC 2,SCR
FCB $D2
FDB OUT-6
SCR FDB DOUSER
FDB XSCR-UORIG
* ######>> screen 37 <<
*
* ======>> 73 <<
FCB $86
FCC 5,OFFSET
FCB $D4
FDB SCR-6
OFSET FDB DOUSER
FDB XOFSET-UORIG
*
* ======>> 74 <<
FCB $87
FCC 6,CONTEXT points to pointer to vocab to search first
FCB $D4
FDB OFSET-9
CONTXT FDB DOUSER
FDB XCONT-UORIG
*
* ======>> 75 <<
FCB $87
FCC 6,CURRENT points to ptr. to vocab being extended
FCB $D4
FDB CONTXT-10
CURENT FDB DOUSER
FDB XCURR-UORIG
*
* ======>> 76 <<
FCB $85
FCC 4,STATE 1 if compiling, 0 if not
FCB $C5
FDB CURENT-10
STATE FDB DOUSER
FDB XSTATE-UORIG
*
* ======>> 77 <<
FCB $84
FCC 3,BASE number base for all input & output
FCB $C5
FDB STATE-8
BASE FDB DOUSER
FDB XBASE-UORIG
*
* ======>> 78 <<
FCB $83
FCC 2,DPL
FCB $CC
FDB BASE-7
DPL FDB DOUSER
FDB XDPL-UORIG
*
* ======>> 79 <<
FCB $83
FCC 2,FLD
FCB $C4
FDB DPL-6
FLD FDB DOUSER
FDB XFLD-UORIG
*
* ======>> 80 <<
FCB $83
FCC 2,CSP
FCB $D0
FDB FLD-6
CSP FDB DOUSER
FDB XCSP-UORIG
*
* ======>> 81 <<
FCB $82
FCC 1,R#
FCB $A3
FDB CSP-6
RNUM FDB DOUSER
FDB XRNUM-UORIG
*
* ======>> 82 <<
FCB $83
FCC 2,HLD
FCB $C4
FDB RNUM-5
HLD FDB DOCON
FDB XHLD
*
* ======>> 82.5 <<== SPECIAL
FCB $87
FCC 6,COLUMNS line width of terminal
FCB $D3
FDB HLD-6
COLUMS FDB DOUSER
FDB XCOLUM-UORIG
*
* ######>> screen 38 <<
* ======>> 83 <<
FCB $82
FCC 1,1+
FCB $AB
FDB COLUMS-10
ONEP FDB DOCOL,ONE,PLUS
FDB SEMIS
*
* ======>> 84 <<
FCB $82
FCC 1,2+
FCB $AB
FDB ONEP-5
TWOP FDB DOCOL,TWO,PLUS
FDB SEMIS
*
* ======>> 85 <<
FCB $84
FCC 3,HERE
FCB $C5
FDB TWOP-5
HERE FDB DOCOL,DP,AT
FDB SEMIS
*
* ======>> 86 <<
FCB $85
FCC 4,ALLOT
FCB $D4
FDB HERE-7
ALLOT FDB DOCOL,DP,PSTORE
FDB SEMIS
*
* ======>> 87 <<
FCB $81 ; , (COMMA)
FCB $AC
FDB ALLOT-8
COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
FDB SEMIS
*
* ======>> 88 <<
FCB $82
FCC 1,C,
FCB $AC
FDB COMMA-4
CCOMM FDB DOCOL,HERE,CSTORE,ONE,ALLOT
FDB SEMIS
*
* ======>> 89 <<
FCB $81 ; -
FCB $AD
FDB CCOMM-5
SUB FDB DOCOL,MINUS,PLUS
FDB SEMIS
*
* ======>> 90 <<
FCB $81 =
FCB $BD
FDB SUB-4
EQUAL FDB DOCOL,SUB,ZEQU
FDB SEMIS
*
* ======>> 91 <<
FCB $81 <
FCB $BC
FDB EQUAL-4
LESS FDB *+2
PUL A
PUL B
TSX
CMP A 0,X
INS
BGT LESST
BNE LESSF
CMP B 1,X
BHI LESST
LESSF CLR B
BRA LESSX
LESST LDA B #1
LESSX CLR A
INS
JMP PUSHBA
*
* ======>> 92 <<
FCB $81 >
FCB $BE
FDB LESS-4
GREAT FDB DOCOL,SWAP,LESS
FDB SEMIS
*
* ======>> 93 <<
FCB $83
FCC 2,ROT
FCB $D4
FDB GREAT-4
ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
FDB SEMIS
*
* ======>> 94 <<
FCB $85
FCC 4,SPACE
FCB $C5
FDB ROT-6
SPACE FDB DOCOL,BL,EMIT
FDB SEMIS
*
* ======>> 95 <<
FCB $83
FCC 2,MIN
FCB $CE
FDB SPACE-8
MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
FDB MIN2-*
FDB SWAP
MIN2 FDB DROP
FDB SEMIS
*
* ======>> 96 <<
FCB $83
FCC 2,MAX
FCB $D8
FDB MIN-6
MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
FDB MAX2-*
FDB SWAP
MAX2 FDB DROP
FDB SEMIS
*
* ======>> 97 <<
FCB $84
FCC 3,-DUP
FCB $D0
FDB MAX-6
DDUP FDB DOCOL,DUP,ZBRAN
FDB DDUP2-*
FDB DUP
DDUP2 FDB SEMIS
*
* ######>> screen 39 <<
* ======>> 98 <<
FCB $88
FCC 7,TRAVERSE
FCB $C5
FDB DDUP-7
TRAV FDB DOCOL,SWAP
TRAV2 FDB OVER,PLUS,CLITER
FCB $7F
FDB OVER,CAT,LESS,ZBRAN
FDB TRAV2-*
FDB SWAP,DROP
FDB SEMIS
*
* ======>> 99 <<
FCB $86
FCC 5,LATEST
FCB $D4
FDB TRAV-11
LATEST FDB DOCOL,CURENT,AT,AT
FDB SEMIS
*
* ======>> 100 <<
FCB $83
FCC 2,LFA
FCB $C1
FDB LATEST-9
LFA FDB DOCOL,CLITER
FCB 4
FDB SUB
FDB SEMIS
*
* ======>> 101 <<
FCB $83
FCC 2,CFA
FCB $C1
FDB LFA-6
CFA FDB DOCOL,TWO,SUB
FDB SEMIS
*
* ======>> 102 <<
FCB $83
FCC 2,NFA
FCB $C1
FDB CFA-6
NFA FDB DOCOL,CLITER
FCB 5
FDB SUB,ONE,MINUS,TRAV
FDB SEMIS
*
* ======>> 103 <<
FCB $83
FCC 2,PFA
FCB $C1
FDB NFA-6
PFA FDB DOCOL,ONE,TRAV,CLITER
FCB 5
FDB PLUS
FDB SEMIS
*
* ######>> screen 40 <<
* ======>> 104 <<
FCB $84
FCC 3,!CSP
FCB $D0
FDB PFA-6
SCSP FDB DOCOL,SPAT,CSP,STORE
FDB SEMIS
*
* ======>> 105 <<
FCB $86
FCC 5,?ERROR
FCB $D2
FDB SCSP-7
QERR FDB DOCOL,SWAP,ZBRAN
FDB QERR2-*
FDB ERROR,BRAN
FDB QERR3-*
QERR2 FDB DROP
QERR3 FDB SEMIS
*
* ======>> 106 <<
FCB $85
FCC 4,?COMP
FCB $D0
FDB QERR-9
QCOMP FDB DOCOL,STATE,AT,ZEQU,CLITER
FCB $11
FDB QERR
FDB SEMIS
*
* ======>> 107 <<
FCB $85
FCC 4,?EXEC
FCB $C3
FDB QCOMP-8
QEXEC FDB DOCOL,STATE,AT,CLITER
FCB $12
FDB QERR
FDB SEMIS
*
* ======>> 108 <<
FCB $86
FCC 5,?PAIRS
FCB $D3
FDB QEXEC-8
QPAIRS FDB DOCOL,SUB,CLITER
FCB $13
FDB QERR
FDB SEMIS
*
* ======>> 109 <<
FCB $84
FCC 3,?CSP
FCB $D0
FDB QPAIRS-9
QCSP FDB DOCOL,SPAT,CSP,AT,SUB,CLITER
FCB $14
FDB QERR
FDB SEMIS
*
* ======>> 110 <<
FCB $88
FCC 7,?LOADING
FCB $C7
FDB QCSP-7
QLOAD FDB DOCOL,BLK,AT,ZEQU,CLITER
FCB $16
FDB QERR
FDB SEMIS
*
* ######>> screen 41 <<
* ======>> 111 <<
FCB $87
FCC 6,COMPILE
FCB $C5
FDB QLOAD-11
COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
FDB SEMIS
*
* ======>> 112 <<
FCB $C1 [ immediate
FCB $DB
FDB COMPIL-10
LBRAK FDB DOCOL,ZERO,STATE,STORE
FDB SEMIS
*
* ======>> 113 <<
FCB $81 ]
FCB $DD
FDB LBRAK-4
RBRAK FDB DOCOL,CLITER
FCB $C0
FDB STATE,STORE
FDB SEMIS
*
* ======>> 114 <<
FCB $86
FCC 5,SMUDGE
FCB $C5
FDB RBRAK-4
SMUDGE FDB DOCOL,LATEST,CLITER
FCB $20
FDB TOGGLE
FDB SEMIS
*
* ======>> 115 <<
FCB $83
FCC 2,HEX
FCB $D8
FDB SMUDGE-9
HEX FDB DOCOL
FDB CLITER
FCB 16
FDB BASE,STORE
FDB SEMIS
*
* ======>> 116 <<
FCB $87
FCC 6,DECIMAL
FCB $CC
FDB HEX-6
DEC FDB DOCOL
FDB CLITER
FCB 10 note: hex "A"
FDB BASE,STORE
FDB SEMIS
*
* ######>> screen 42 <<
* ======>> 117 <<
FCB $87
FCC 6,(;CODE)
FCB $A9
FDB DEC-10
PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
FDB SEMIS
*
* ======>> 118 <<
FCB $C5 immediate
FCC 4,;CODE
FCB $C5
FDB PSCODE-10
SEMIC FDB DOCOL,QCSP,COMPIL,PSCODE,SMUDGE,LBRAK,QSTACK
FDB SEMIS
* note: "QSTACK" will be replaced by "ASSEMBLER" later
*
* ######>> screen 43 <<
* ======>> 119 <<
FCB $87
FCC 6,<BUILDS
FCB $D3
FDB SEMIC-8
BUILDS FDB DOCOL,ZERO,CON
FDB SEMIS
*
* ======>> 120 <<
FCB $85
FCC 4,DOES>
FCB $BE
FDB BUILDS-10
DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
FDB PSCODE
DODOES LDA A IP
LDA B IP+1
LDX RP make room on return stack
DEX
DEX
STX RP
STA A 2,X push return address
STA B 3,X
LDX W get addr of pointer to run-time code
INX
INX
STX N stash it in scratch area
LDX 0,X get new IP
STX IP
CLR A get address of parameter
LDA B #2
ADD B N+1
ADC A N
PSH B and push it on data stack
PSH A
JMP NEXT2
*
* ######>> screen 44 <<
* ======>> 121 <<
FCB $85
FCC 4,COUNT
FCB $D4
FDB DOES-8
COUNT FDB DOCOL,DUP,ONEP,SWAP,CAT
FDB SEMIS
*
* ======>> 122 <<
FCB $84
FCC 3,TYPE
FCB $C5
FDB COUNT-8
TYPE FDB DOCOL,DDUP,ZBRAN
FDB TYPE3-*
FDB OVER,PLUS,SWAP,XDO
TYPE2 FDB I,CAT,EMIT,XLOOP
FDB TYPE2-*
FDB BRAN
FDB TYPE4-*
TYPE3 FDB DROP
TYPE4 FDB SEMIS
*
* ======>> 123 <<
FCB $89
FCC 8,-TRAILING
FCB $C7
FDB TYPE-7
DTRAIL FDB DOCOL,DUP,ZERO,XDO
DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
FDB SUB,ZBRAN
FDB DTRAL3-*
FDB LEAVE,BRAN
FDB DTRAL4-*
DTRAL3 FDB ONE,SUB
DTRAL4 FDB XLOOP
FDB DTRAL2-*
FDB SEMIS
*
* ======>> 124 <<
FCB $84
FCC 3,(.")
FCB $A9
FDB DTRAIL-12
PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
FDB FROMR,PLUS,TOR,TYPE
FDB SEMIS
*
* ======>> 125 <<
FCB $C2 immediate
FCC 1,."
FCB $A2
FDB PDOTQ-7
DOTQ FDB DOCOL
FDB CLITER
FCB $22 ascii quote
FDB STATE,AT,ZBRAN
FDB DOTQ1-*
FDB COMPIL,PDOTQ,WORD
FDB HERE,CAT,ONEP,ALLOT,BRAN
FDB DOTQ2-*
DOTQ1 FDB WORD,HERE,COUNT,TYPE
DOTQ2 FDB SEMIS
*
* ######>> screen 45 <<
* ======>> 126 <<== MACHINE DEPENDENT
FCB $86
FCC 5,?STACK
FCB $CB
FDB DOTQ-5
QSTACK FDB DOCOL,CLITER
FCB $12
FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
FDB QERR
* prints 'empty stack'
*
QSTAC2 FDB SPAT
* Here, we compare with a value at least 128
* higher than dict. ptr. (DP)
FDB HERE,CLITER
FCB $80
FDB PLUS,LESS,ZBRAN
FDB QSTAC3-*
FDB TWO
FDB QERR
* prints 'full stack'
*
QSTAC3 FDB SEMIS
*
* ======>> 127 << this word's function
* is done by ?STACK in this version
* FCB $85
* FCC 4,?FREE
* FCB $C5
* FDB QSTACK-9
*QFREE FDB DOCOL,SPAT,HERE,CLITER
* FCB $80
* FDB PLUS,LESS,TWO,QERR,SEMIS
*
* ######>> screen 46 <<
* ======>> 128 <<
FCB $86
FCC 5,EXPECT
FCB $D4
FDB QSTACK-9
EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO
EXPEC2 FDB KEY,DUP,CLITER
FCB $0E
FDB PORIG,AT,EQUAL,ZBRAN
FDB EXPEC3-*
FDB DROP,CLITER
FCB 8 ( backspace character to emit )
FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
FDB TOR,SUB,BRAN
FDB EXPEC6-*
EXPEC3 FDB DUP,CLITER
FCB $D ( carriage return )
FDB EQUAL,ZBRAN
FDB EXPEC4-*
FDB LEAVE,DROP,BL,ZERO,BRAN
FDB EXPEC5-*
EXPEC4 FDB DUP
EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
EXPEC6 FDB EMIT,XLOOP
FDB EXPEC2-*
FDB DROP
FDB SEMIS
*
* ======>> 129 <<
FCB $85
FCC 4,QUERY
FCB $D9
FDB EXPECT-9
QUERY FDB DOCOL,TIB,AT,COLUMS
FDB AT,EXPECT,ZERO,IN,STORE
*DBG
* FDB MNOP
*DBG
FDB SEMIS
*
* ======>> 130 <<
FCB $C1 immediate < carriage return >
FCB $80
FDB QUERY-8
NULL FDB DOCOL,BLK,AT,ZBRAN
FDB NULL2-*
FDB ONE,BLK,PSTORE
FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
FDB ZEQU
* check for end of screen
FDB ZBRAN
FDB NULL1-*
FDB QEXEC,FROMR,DROP
NULL1 FDB BRAN
FDB NULL3-*
NULL2 FDB FROMR,DROP
NULL3 FDB SEMIS
*
* ######>> screen 47 <<
* ======>> 133 <<
FCB $84
FCC 3,FILL
FCB $CC
FDB NULL-4
FILL FDB DOCOL,SWAP,TOR,OVER,CSTORE,DUP,ONEP
FDB FROMR,ONE,SUB,CMOVE
FDB SEMIS
*
* ======>> 134 <<
FCB $85
FCC 4,ERASE
FCB $C5
FDB FILL-7
ERASE FDB DOCOL,ZERO,FILL
FDB SEMIS
*
* ======>> 135 <<
FCB $86
FCC 5,BLANKS
FCB $D3
FDB ERASE-8
BLANKS FDB DOCOL,BL,FILL
FDB SEMIS
*
* ======>> 136 <<
FCB $84
FCC 3,HOLD
FCB $C4
FDB BLANKS-9
HOLD FDB DOCOL,LIT,$FFFF,HLD,PSTORE,HLD,AT,CSTORE
FDB SEMIS
*
* ======>> 137 <<
FCB $83
FCC 2,PAD
FCB $C4
FDB HOLD-7
PAD FDB DOCOL,HERE,CLITER
FCB $44
FDB PLUS
FDB SEMIS
*
* ######>> screen 48 <<
* ======>> 138 <<
FCB $84
FCC 3,WORD
FCB $C4
FDB PAD-6
WORD FDB DOCOL,BLK,AT,ZBRAN
FDB WORD2-*
FDB BLK,AT,BLOCK,BRAN
FDB WORD3-*
WORD2 FDB TIB,AT
WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,CLITER
FCB 34
FDB BLANKS,IN,PSTORE,OVER,SUB,TOR,R,HERE
FDB CSTORE,PLUS,HERE,ONEP,FROMR,CMOVE
FDB SEMIS
*
* ######>> screen 49 <<
* ======>> 139 <<
FCB $88
FCC 7,(NUMBER)
FCB $A9
FDB WORD-7
PNUMB FDB DOCOL
PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
FDB PNUMB4-*
FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
FDB PNUMB3-*
FDB ONE,DPL,PSTORE
PNUMB3 FDB FROMR,BRAN
FDB PNUMB2-*
PNUMB4 FDB FROMR
FDB SEMIS
*
* ======>> 140 <<
FCB $86
FCC 5,NUMBER
FCB $D2
FDB PNUMB-11
NUMB FDB DOCOL,ZERO,ZERO,ROT,DUP,ONEP,CAT,CLITER
FCC "-" minus sign
FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
FDB ZBRAN
FDB NUMB2-*
FDB DUP,CAT,CLITER
FCC "."
FDB SUB,ZERO,QERR,ZERO,BRAN
FDB NUMB1-*
NUMB2 FDB DROP,FROMR,ZBRAN
FDB NUMB3-*
FDB DMINUS
NUMB3 FDB SEMIS
*
* ======>> 141 <<
FCB $85
FCC 4,-FIND
FCB $C4
FDB NUMB-9
DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
*DBG
FDB MNOP
*DBG
FDB PFIND
*DBG
FDB MNOP
*DBG
FDB DUP,ZEQU,ZBRAN
FDB DFIND2-*
FDB DROP,HERE,LATEST,PFIND
DFIND2 FDB SEMIS
*
* ######>> screen 50 <<
* ======>> 142 <<
FCB $87
FCC 6,(ABORT)
FCB $A9
FDB DFIND-8
PABORT FDB DOCOL,ABORT
FDB SEMIS
*
* ======>> 143 <<
FCB $85
FCC 4,ERROR
FCB $D2
FDB PABORT-10
ERROR FDB DOCOL,WARN,AT,ZLESS
FDB ZBRAN
* note: WARNING is -1 to abort, 0 to print error #
* and 1 to print error message from disc
FDB ERROR2-*
FDB PABORT
ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
FCB 4,7 ( bell )
FCC " ? "
FDB MESS,SPSTOR,IN,AT,BLK,AT,QUIT
FDB SEMIS
*
* ======>> 144 <<
FCB $83
FCC 2,ID.
FCB $AE
FDB ERROR-8
IDDOT FDB DOCOL,PAD,CLITER
FCB 32
FDB CLITER
FCB $5F ( underline )
FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
FDB SWAP,CMOVE,PAD,COUNT,CLITER
FCB 31
FDB AND,TYPE,SPACE
FDB SEMIS
*
* ######>> screen 51 <<
* ======>> 145 <<
FCB $86
FCC 5,CREATE
FCB $C5
FDB IDDOT-6
CREATE FDB DOCOL,DFIND,ZBRAN
FDB CREAT2-*
FDB DROP,PDOTQ
FCB 8
FCB 7 ( bel )
FCC "redef: "
FDB NFA,IDDOT,CLITER
FCB 4
FDB MESS,SPACE
CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
FDB ONEP,ALLOT,DUP,CLITER
FCB $A0
FDB TOGGLE,HERE,ONE,SUB,CLITER
FCB $80
FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
FDB HERE,TWOP,COMMA
FDB SEMIS
*
* ######>> screen 52 <<
* ======>> 146 <<
FCB $C9 immediate
FCC 8,[COMPILE]
FCB $DD
FDB CREATE-9
BCOMP FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,CFA,COMMA
FDB SEMIS
*
* ======>> 147 <<
FCB $C7 immediate
FCC 6,LITERAL
FCB $CC
FDB BCOMP-12
LITER FDB DOCOL,STATE,AT,ZBRAN
FDB LITER2-*
FDB COMPIL,LIT,COMMA
LITER2 FDB SEMIS
*
* ======>> 148 <<
FCB $C8 immediate
FCC 7,DLITERAL
FCB $CC
FDB LITER-10
DLITER FDB DOCOL,STATE,AT,ZBRAN
FDB DLITE2-*
FDB SWAP,LITER,LITER
DLITE2 FDB SEMIS
*
* ######>> screen 53 <<
* ======>> 149 <<
FCB $89
FCC 8,INTERPRET
FCB $D4
FDB DLITER-11
INTERP FDB DOCOL
INTER2 FDB DFIND
*DBG
* FDB MNOP
* FDB OVER,OVER,HEX,DOT,DOT,DEC
*DBG
FDB ZBRAN
FDB INTER5-*
FDB STATE,AT,LESS
FDB ZBRAN
FDB INTER3-*
FDB CFA,COMMA,BRAN
FDB INTER4-*
INTER3 FDB CFA,EXEC
INTER4 FDB BRAN
FDB INTER7-*
INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
FDB INTER6-*
FDB DLITER,BRAN
FDB INTER7-*
INTER6 FDB DROP,LITER
INTER7 FDB QSTACK,BRAN
FDB INTER2-*
* FDB SEMIS never executed
*
* ######>> screen 54 <<
* ======>> 150 <<
FCB $89
FCC 8,IMMEDIATE
FCB $C5
FDB INTERP-12
IMMED FDB DOCOL,LATEST,CLITER
FCB $40
FDB TOGGLE
FDB SEMIS
*
* ======>> 151 <<
FCB $8A
FCC 9,VOCABULARY
FCB $D9
FDB IMMED-12
VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
DOVOC FDB TWOP,CONTXT,STORE
FDB SEMIS
*
* ======>> 152 <<
*
* Note: FORTH does not go here in the rom-able dictionary,
* since FORTH is a type of variable.
*
*
* ======>> 153 <<
FCB $8B
FCC 10,DEFINITIONS
FCB $D3
FDB VOCAB-13
DEFIN FDB DOCOL,CONTXT,AT,CURENT,STORE
FDB SEMIS
*
* ======>> 154 <<
FCB $C1 immediate (
FCB $A8
FDB DEFIN-14
PAREN FDB DOCOL,CLITER
FCC ")"
FDB WORD
FDB SEMIS
*
* ######>> screen 55 <<
* ======>> 155 <<
FCB $84
FCC 3,QUIT
FCB $D4
FDB PAREN-4
QUIT FDB DOCOL,ZERO,BLK,STORE
FDB LBRAK
*
* Here is the outer interpretter
* which gets a line of input, does it, prints " OK"
* then repeats :
QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
FDB ZBRAN
FDB QUIT3-*
FDB PDOTQ
FCB 3
FCC 3, OK
QUIT3 FDB BRAN
FDB QUIT2-*
* FDB SEMIS ( never executed )
*
* ======>> 156 <<
FCB $85
FCC 4,ABORT
FCB $D4
FDB QUIT-7
ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
FCB 8
FCC "Forth-68"
FDB FORTH,DEFIN
*DBG
* FDB TRCON
* FDB LIT
* FDB ABORT-8
* FDB IDDOT
* FDB LIT
* FDB NULL-4
* FDB IDDOT
* FDB LIT
* FDB MNOP-7
* FDB IDDOT
* FDB LIT
* FDB TRCON-10
* FDB IDDOT
* FDB LIT
* FDB TRCOFF-11
* FDB IDDOT
*DBG
FDB QUIT
* FDB SEMIS never executed
PAGE
*
* ######>> screen 56 <<
* bootstrap code... moves rom contents to ram :
* ======>> 157 <<
FCB $84
FCC 3,COLD
FCB $C4
FDB ABORT-8
COLD FDB *+2
CENT LDS #REND-1 top of destination
LDX #ERAM top of stuff to move
COLD2 DEX
LDA A 0,X
PSH A move TASK & FORTH to ram
CPX #RAM
BNE COLD2
*
LDS #XFENCE-1 put stack at a safe place for now
LDX COLINT
STX XCOLUM
LDX DELINT
STX XDELAY
LDX VOCINT
STX XVOCL
LDX DPINIT
STX XDP
LDX FENCIN
STX XFENCE
WENT LDS #XFENCE-1 top of destination
LDX #FENCIN top of stuff to move
WARM2 DEX
LDA A 0,X
PSH A
CPX #SINIT
BNE WARM2
*
LDS SINIT
LDX UPINIT
STX UP init user ram pointer
LDX #ABORT
STX IP
NOP Here is a place to jump to special user
NOP initializations such as I/0 interrups
NOP
*
* For systems with TRACE:
LDX #00
STX TRLIM clear trace mode
LDX #0
STX BRKPT clear breakpoint address
JMP RPSTOR+2 start the virtual machine running !
*
* Here is the stuff that gets copied to ram :
* at address $140:
*
* Thus, MAGIC numbers that initialize USE and PREV, magically! (JMR)
* RAM FDB $3000,$3000,0,0
RAM FDB $4000+132,$4000+132,0,0
* ======>> (152) <<
FCB $C5 immediate
FCC 4,FORTH
FCB $C8
FDB MNOP-7
RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
FDB 0
FCC "(C) Forth Interest Group, 1979"
FCB $84
FCC 3,TASK
FCB $CB
FDB FORTH-8
RTASK FDB DOCOL,SEMIS
ERAM FCC "David Lion"
PAGE
*
* ######>> screen 57 <<
* ======>> 158 <<
FCB $84
FCC 3,S->D
FCB $C4
FDB COLD-7
STOD FDB DOCOL,DUP,ZLESS,MINUS
FDB SEMIS
*
* ======>> 159 <<
FCB $81 ; *
FCB $AA
FDB STOD-7
STAR FDB *+2
JSR USTARS
INS
INS
JMP NEXT
*
* ======>> 160 <<
FCB $84
FCC 3,/MOD
FCB $C4
FDB STAR-4
SLMOD FDB DOCOL,TOR,STOD,FROMR,USLASH
FDB SEMIS
*
* ======>> 161 <<
FCB $81 ; /
FCB $AF
FDB SLMOD-7
SLASH FDB DOCOL,SLMOD,SWAP,DROP
FDB SEMIS
*
* ======>> 162 <<
FCB $83
FCC 2,MOD
FCB $C4
FDB SLASH-4
MOD FDB DOCOL,SLMOD,DROP
FDB SEMIS
*
* ======>> 163 <<
FCB $85
FCC 4,*/MOD
FCB $C4
FDB MOD-6
SSMOD FDB DOCOL,TOR,USTAR,FROMR,USLASH
FDB SEMIS
*
* ======>> 164 <<
FCB $82
FCC 1,*/
FCB $AF
FDB SSMOD-8
SSLASH FDB DOCOL,SSMOD,SWAP,DROP
FDB SEMIS
*
* ======>> 165 <<
FCB $85
FCC 4,M/MOD
FCB $C4
FDB SSLASH-5
MSMOD FDB DOCOL,TOR,ZERO,R,USLASH
FDB FROMR,SWAP,TOR,USLASH,FROMR
FDB SEMIS
*
* ======>> 166 <<
FCB $83
FCC 2,ABS
FCB $D3
FDB MSMOD-8
ABS FDB DOCOL,DUP,ZLESS,ZBRAN
FDB ABS2-*
FDB MINUS
ABS2 FDB SEMIS
*
* ======>> 167 <<
FCB $84
FCC 3,DABS
FCB $D3
FDB ABS-6
DABS FDB DOCOL,DUP,ZLESS,ZBRAN
FDB DABS2-*
FDB DMINUS
DABS2 FDB SEMIS
*
* ######>> screen 58 <<
* Disc primatives :
* ======>> 168 <<
FCB $83
FCC 2,USE
FCB $C5
FDB DABS-7
USE FDB DOCON
FDB XUSE
* ======>> 169 <<
FCB $84
FCC 3,PREV
FCB $D6
FDB USE-6
PREV FDB DOCON
FDB XPREV
* ======>> 170 <<
FCB $84
FCC 3,+BUF
FCB $C6
FDB PREV-7
PBUF FDB DOCOL,CLITER
FCB $84
FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
FDB PBUF2-*
FDB DROP,FIRST
PBUF2 FDB DUP,PREV,AT,SUB
FDB SEMIS
*
* ======>> 171 <<
FCB $86
FCC 5,UPDATE
FCB $C5
FDB PBUF-7
UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
FDB SEMIS
*
* ======>> 172 <<
FCB $8D
FCC 12,EMPTY-BUFFERS
FCB $D3
FDB UPDATE-9
MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
FDB SEMIS
*
* ======>> 173 <<
FCB $83
FCC 2,DR0
FCB $B0
FDB MTBUF-16
DRZERO FDB DOCOL,ZERO,OFSET,STORE
FDB SEMIS
*
* ======>> 174 <<== system dependant word
FCB $83
FCC 2,DR1
FCB $B1
FDB DRZERO-6
*DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
DRONE FDB DOCOL,LIT,RAMDSZ,OFSET,STORE
FDB SEMIS
*
* ######>> screen 59 <<
* ======>> 175 <<
FCB $86
FCC 5,BUFFER
FCB $D2
FDB DRONE-6
BUFFER FDB DOCOL,USE,AT,DUP,TOR
BUFFR2 FDB PBUF,ZBRAN
FDB BUFFR2-*
FDB USE,STORE,R,AT,ZLESS
FDB ZBRAN
FDB BUFFR3-*
FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
FDB SEMIS
*
* ######>> screen 60 <<
* ======>> 176 <<
FCB $85
FCC 4,BLOCK
FCB $CB
FDB BUFFER-9
BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
FDB BLOCK5-*
BLOCK3 FDB PBUF,ZEQU,ZBRAN
FDB BLOCK4-*
FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
FDB BLOCK3-*
FDB DUP,PREV,STORE
BLOCK5 FDB FROMR,DROP,TWOP
FDB SEMIS
*
* ######>> screen 61 <<
* ======>> 177 <<
FCB $86
FCC 5,(LINE)
FCB $A9
FDB BLOCK-8
PLINE FDB DOCOL,TOR,CLITER
FCB $40
FDB BBUF,SSMOD,FROMR,BSCR,STAR,PLUS,BLOCK,PLUS,CLITER
FCB $40
FDB SEMIS
*
* ======>> 178 <<
FCB $85
FCC 4,.LINE
FCB $C5
FDB PLINE-9
DLINE FDB DOCOL,PLINE,DTRAIL,TYPE
FDB SEMIS
*
* ======>> 179 <<
FCB $87
FCC 6,MESSAGE
FCB $C5
FDB DLINE-8
MESS FDB DOCOL,WARN,AT,ZBRAN
FDB MESS3-*
FDB DDUP,ZBRAN
FDB MESS3-*
FDB CLITER
FCB 4
FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
FDB MESS4-*
MESS3 FDB PDOTQ
FCB 6
FCC 6,err # ; Make sure there's a space there at the end.
FDB DOT
MESS4 FDB SEMIS
*
* ======>> 180 <<
FCB $84
FCC 3,LOAD input:scr #
FCB $C4
FDB MESS-10
LOAD FDB DOCOL,BLK,AT,TOR,IN,AT,TOR,ZERO,IN,STORE
FDB BSCR,STAR,BLK,STORE
FDB INTERP,FROMR,IN,STORE,FROMR,BLK,STORE
FDB SEMIS
*
* ======>> 181 <<
FCB $C3
FCC 2,-->
FCB $BE
FDB LOAD-7
ARROW FDB DOCOL,QLOAD,ZERO,IN,STORE,BSCR
FDB BLK,AT,OVER,MOD,SUB,BLK,PSTORE
FDB SEMIS
PAGE
*
*
* ######>> screen 63 <<
* The next 4 subroutines are machine dependent, and are
* called by words 13 through 16 in the dictionary.
*
* ======>> 182 << code for EMIT
* PEMIT JMP $F018 ; EXBUG outch, rob the RTS.
PEMIT STA B N+1 save B
STX N+2 save X
LDA B ACIAC
BIT B #2 check ready bit
BEQ PEMIT+4 if not ready for more data
STA A N
AND A #$7F
STA A ACIAD
LDX UP
STA B IOSTAT-UORIG,X
LDA A N
LDA B N+1 recover B & X
LDX N+2
RTS only A register may change
* PEMIT JMP $E1D1 for MIKBUG
* PEMIT FCB $3F,$11,$39 for PROTO
* PEMIT JMP $D286 for Smoke Signal DOS
*
* ======>> 183 << code for KEY
PKEY CLR $FF53
INC $FF53 ; shut off echo
JMP $F015 ; EXBUG inch, rob the RTS.
* PKEY STA B N
* STX N+1
* LDA B ACIAC
* ASR B
* BCC PKEY+4 no incoming data yet
* LDA A ACIAD
* AND A #$7F strip parity bit
* LDX UP
* STA B IOSTAT+1-UORIG,X
* LDA B N
* LDX N+1
* RTS
* PKEY JMP $E1AC for MIKBUG
* PKEY FCB $3F,$14,$39 for PROTO
* PKEY JMP $D289 for Smoke Signal DOS
*
* ######>> screen 64 <<
* ======>> 184 << code for ?TERMINAL
PQTER LDA A ACIAC Test for 'break' condition
AND A #$11 mask framing error bit and
* input buffer full
BEQ PQTER2
LDA A ACIAD clear input buffer
LDA A #01
PQTER2 RTS
PAGE
*
* ======>> 185 << code for CR
PCR JMP $F021 ; EXBUG pcrlf, rob the RTS.
* PCR LDA A #$D carriage return
* BSR PEMIT
* LDA A #$A line feed
* BSR PEMIT
* LDA A #$7F rubout
* LDX UP
* LDA B XDELAY+1-UORIG,X
* PCR2 DEC B
* BMI PQTER2 return if minus
* PSH B save counter
* BSR PEMIT print RUBOUTs to delay.....
* PUL B
* BRA PCR2 repeat
PAGE
*
* ######>> screen 66 <<
* ======>> 187 <<
FCB $85
FCC 4,?DISC
FCB $C3
FDB ARROW-6
QDISC FDB *+2
JMP NEXT
*
* ######>> screen 67 <<
* ======>> 189 <<
FCB $8B
FCC 10,BLOCK-WRITE
FCB $C5
FDB QDISC-8
BWRITE FDB *+2
JMP NEXT
*
* ######>> screen 68 <<
* ======>> 190 <<
FCB $8A
FCC 9,BLOCK-READ
FCB $C4
FDB BWRITE-14
BREAD FDB *+2
JMP NEXT
*
*The next 3 words are written to create a substitute for disc
* mass memory,located between $3210 & $3FFF in ram.
* ======>> 190.1 <<
FCB $82
FCC 1,LO
FCB $CF
FDB BREAD-13
LO FDB DOCON
FDB MEMEND a system dependent equate at front
*
* ======>> 190.2 <<
FCB $82
FCC 1,HI
FCB $C9
FDB LO-5
HI FDB DOCON
* FDB MEMTOP ( $3FFF ($7FFF) in this version )
FDB RAMDEN
*
* ######>> screen 69 <<
* ======>> 191 <<
FCB $83
FCC 2,R/W
FCB $D7
FDB HI-5
RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
FDB RW2-*
FDB PDOTQ
FCB 8
FCC 8, Range ?
FDB QUIT
RW2 FDB FROMR,ZBRAN
FDB RW3-*
FDB SWAP
RW3 FDB BBUF,CMOVE
FDB SEMIS
*
* ######>> screen 72 <<
* ======>> 192 <<
FCB $C1 immediate
FCB $A7 ' ( tick )
FDB RW-6
TICK FDB DOCOL,DFIND,ZEQU,ZERO,QERR,DROP,LITER
FDB SEMIS
*
* ======>> 193 <<
FCB $86
FCC 5,FORGET
FCB $D4
FDB TICK-4
FORGET FDB DOCOL,CURENT,AT,CONTXT,AT,SUB,CLITER
FCB $18
FDB QERR,TICK,DUP,FENCE,AT,LESS,CLITER
FCB $15
FDB QERR,DUP,ZERO,PORIG,GREAT,CLITER
FCB $15
FDB QERR,DUP,NFA,DP,STORE,LFA,AT,CONTXT,AT,STORE
FDB SEMIS
*
* ######>> screen 73 <<
* ======>> 194 <<
FCB $84
FCC 3,BACK
FCB $CB
FDB FORGET-9
BACK FDB DOCOL,HERE,SUB,COMMA
FDB SEMIS
*
* ======>> 195 <<
FCB $C5
FCC 4,BEGIN
FCB $CE
FDB BACK-7
BEGIN FDB DOCOL,QCOMP,HERE,ONE
FDB SEMIS
*
* ======>> 196 <<
FCB $C5
FCC 4,ENDIF
FCB $C6
FDB BEGIN-8
ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE
FDB OVER,SUB,SWAP,STORE
FDB SEMIS
*
* ======>> 197 <<
FCB $C4
FCC 3,THEN
FCB $CE
FDB ENDIF-8
THEN FDB DOCOL,ENDIF
FDB SEMIS
*
* ======>> 198 <<
FCB $C2
FCC 1,DO
FCB $CF
FDB THEN-7
DO FDB DOCOL,COMPIL,XDO,HERE,THREE
FDB SEMIS
*
* ======>> 199 <<
FCB $C4
FCC 3,LOOP
FCB $D0
FDB DO-5
LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
FDB SEMIS
*
* ======>> 200 <<
FCB $C5
FCC 4,+LOOP
FCB $D0
FDB LOOP-7
PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
FDB SEMIS
*
* ======>> 201 <<
FCB $C5
FCC 4,UNTIL ( same as END )
FCB $CC
FDB PLOOP-8
UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
FDB SEMIS
*
* ######>> screen 74 <<
* ======>> 202 <<
FCB $C3
FCC 2,END
FCB $C4
FDB UNTIL-8
END FDB DOCOL,UNTIL
FDB SEMIS
*
* ======>> 203 <<
FCB $C5
FCC 4,AGAIN
FCB $CE
FDB END-6
AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
FDB SEMIS
*
* ======>> 204 <<
FCB $C6
FCC 5,REPEAT
FCB $D4
FDB AGAIN-8
REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
FDB TWO,SUB,ENDIF
FDB SEMIS
*
* ======>> 205 <<
FCB $C2
FCC 1,IF
FCB $C6
FDB REPEAT-9
IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
FDB SEMIS
*
* ======>> 206 <<
FCB $C4
FCC 3,ELSE
FCB $C5
FDB IF-5
ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO
FDB SEMIS
*
* ======>> 207 <<
FCB $C5
FCC 4,WHILE
FCB $C5
FDB ELSE-7
WHILE FDB DOCOL,IF,TWOP
FDB SEMIS
*
* ######>> screen 75 <<
* ======>> 208 <<
FCB $86
FCC 5,SPACES
FCB $D3
FDB WHILE-8
SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
FDB SPACE3-*
FDB ZERO,XDO
SPACE2 FDB SPACE,XLOOP
FDB SPACE2-*
SPACE3 FDB SEMIS
*
* ======>> 209 <<
FCB $82
FCC 1,<#
FCB $A3
FDB SPACES-9
BDIGS FDB DOCOL,PAD,HLD,STORE
FDB SEMIS
*
* ======>> 210 <<
FCB $82
FCC 1,#>
FCB $BE
FDB BDIGS-5
EDIGS FDB DOCOL,DROP,DROP,HLD,AT,PAD,OVER,SUB
FDB SEMIS
*
* ======>> 211 <<
FCB $84
FCC 3,SIGN
FCB $CE
FDB EDIGS-5
SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
FDB SIGN2-*
FDB CLITER
FCC "-"
FDB HOLD
SIGN2 FDB SEMIS
*
* ======>> 212 <<
FCB $81 #
FCB $A3
FDB SIGN-7
DIG FDB DOCOL,BASE,AT,MSMOD,ROT,CLITER
FCB 9
FDB OVER,LESS,ZBRAN
FDB DIG2-*
FDB CLITER
FCB 7
FDB PLUS
DIG2 FDB CLITER
FCC "0" ascii zero
FDB PLUS,HOLD
FDB SEMIS
*
* ======>> 213 <<
FCB $82
FCC 1,#S
FCB $D3
FDB DIG-4
DIGS FDB DOCOL
DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
FDB DIGS2-*
FDB SEMIS
*
* ######>> screen 76 <<
* ======>> 214 <<
FCB $82
FCC 1,.R
FCB $D2
FDB DIGS-5
DOTR FDB DOCOL,TOR,STOD,FROMR,DDOTR
FDB SEMIS
*
* ======>> 215 <<
FCB $83
FCC 2,D.R
FCB $D2
FDB DOTR-5
DDOTR FDB DOCOL,TOR,SWAP,OVER,DABS,BDIGS,DIGS,SIGN
FDB EDIGS,FROMR,OVER,SUB,SPACES,TYPE
FDB SEMIS
*
* ======>> 216 <<
FCB $82
FCC 1,D.
FCB $AE
FDB DDOTR-6
DDOT FDB DOCOL,ZERO,DDOTR,SPACE
FDB SEMIS
*
* ======>> 217 <<
FCB $81 .
FCB $AE
FDB DDOT-5
DOT FDB DOCOL,STOD,DDOT
FDB SEMIS
*
* ======>> 218 <<
FCB $81 ?
FCB $BF
FDB DOT-4
QUEST FDB DOCOL,AT,DOT
FDB SEMIS
*
* ######>> screen 77 <<
* ======>> 219 <<
FCB $84
FCC 3,LIST
FCB $D4
FDB QUEST-4
LIST FDB DOCOL,DEC,CR,DUP,SCR,STORE,PDOTQ
FCB 6
FCC "SCR # "
FDB DOT,CLITER
FCB $10
FDB ZERO,XDO
LIST2 FDB CR,I,THREE
FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
FDB LIST2-*
FDB CR
FDB SEMIS
*
* ======>> 220 <<
FCB $85
FCC 4,INDEX
FCB $D8
FDB LIST-7
INDEX FDB DOCOL,CR,ONEP,SWAP,XDO
INDEX2 FDB CR,I,THREE
FDB DOTR,SPACE,ZERO,I,DLINE
FDB QTERM,ZBRAN
FDB INDEX3-*
FDB LEAVE
INDEX3 FDB XLOOP
FDB INDEX2-*
FDB SEMIS
*
* ======>> 221 <<
FCB $85
FCC 4,TRIAD
FCB $C4
FDB INDEX-8
TRIAD FDB DOCOL,THREE,SLASH,THREE,STAR
FDB THREE,OVER,PLUS,SWAP,XDO
TRIAD2 FDB CR,I
FDB LIST,QTERM,ZBRAN
FDB TRIAD3-*
FDB LEAVE
TRIAD3 FDB XLOOP
FDB TRIAD2-*
FDB CR,CLITER
FCB $0F
FDB MESS,CR
FDB SEMIS
*
* ######>> screen 78 <<
* ======>> 222 <<
FCB $85
FCC 4,VLIST
FCB $D4
FDB TRIAD-8
VLIST FDB DOCOL,CLITER
FCB $80
FDB OUT,STORE,CONTXT,AT,AT
VLIST1 FDB OUT,AT,COLUMS,AT,CLITER
FCB 32
FDB SUB,GREAT,ZBRAN
FDB VLIST2-*
FDB CR,ZERO,OUT,STORE
VLIST2 FDB DUP
* FDB TRCON
FDB IDDOT,SPACE,SPACE,PFA,LFA,AT
FDB DUP,ZEQU,QTERM,OR
* FDB TRCOFF
FDB ZBRAN
FDB VLIST1-*
FDB DROP
FDB SEMIS
*
* ======>> XX <<
FCB $84
FCC 3,NOOP
FCB $D0
FDB VLIST-8
NOOP FDB NEXT a useful no-op
*
* ======>> XX1 <<
FDB $87
FCC 6,TRACEON
FCB $CE
FDB NOOP-7
TRCON FDB *+2
CLR TRACEM
INC TRACEM
JMP NEXT
*
* ======>> XX2 <<
FDB $88
FCC 7,TRACEOFF
FCB $C6
FDB TRCON-10
TRCOFF FDB *+2
CLR TRACEM
JMP NEXT
*
* ======>> XXX <<
FDB $84
FCC 3,MNOP
FCB $D0
FDB TRCOFF-11
MNOP FDB *+2
NOP a place to insert a machine-level breakpoint.
JMP NEXT
*
ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
*
ORG MEMEND simulating disc on-line
* SCREEN 0
FCC "0) Index to BIF HI-LEVEL disk "
FCC "1) "
FCC "2) Title page, Copr. notice "
FCC "3) MONITOR CALL TO DEBUG "
FCC "4) ERROR MESSAGES "
FCC "5) "
FCC "6) "
FCC "7) "
FCC "8) "
FCC "9) "
FCC "10) "
FCC "11) "
FCC "12) "
FCC "13) "
FCC "14) "
FCC "15) "
* SCREEN 1
FCC "16) "
FCC "17) "
FCC "18) "
FCC "19) "
FCC "20) "
FCC "21) "
FCC "22) "
FCC "23) "
FCC "24) "
FCC "25) "
FCC "26) "
FCC "27) "
FCC "28) "
FCC "29) "
FCC "30) "
FCC "31) "
* SCREEN 2
FCC " ( FORTH 68 RAM resident utilities and testing stuff ) " 0
FCC " ( Copyright 2013 Joel Rees ) " 1
FCC " " 2
FCC " " 3
FCC " " 4
FCC " " 5
FCC " " 6
FCC " " 7
FCC " " 8
FCC " " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " " 15
* SCREEN 3
FCC " ( No need to call the monitor in exorsim, just ctrl-c. ) " 0
FCC " ( But maybe we can put some other useful stuff here. ) " 1
FCC " " 2
FCC " 1 WARNING ! " 3
FCC " " 4
FCC " VOCABULARY DEBUG DEFINITIONS " 5
FCC " ( addr n -- ) " 6
FCC " : DUMPHEX BASE @ >R HEX " 7
FCC " 0 DO DUP I + C@ 0 <# # # #> TYPE SPACE LOOP " 8
FCC " DROP R> BASE ! ; " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " FORTH DEFINITIONS " 15
* SCREEN 4
FCC "( ERROR MESSAGES ) " 0
FCC "DATA STACK UNDERFLOW " 1
FCC "DICTIONARY FULL " 2
FCC "ADDRESS RESOLUTION ERROR " 3
FCC "HIDES DEFINITION IN " 4
FCC "NULL VECTOR WRITTEN " 5
FCC "DISC RANGE? " 6
FCC "DATA STACK OVERFLOW " 7
FCC "DISC ERROR! " 8
FCC "CAN'T EXECUTE A NULL! " 9
FCC "CONTROL STACK UNDERFLOW " 10
FCC "CONTROL STACK OVERFLOW " 11
FCC "ARRAY REFERENCE OUT OF BOUNDS " 12
FCC "ARRAY DIMENSION NOT VALID " 13
FCC "NO PROCEDURE TO ENTER " 14
FCC " ( WAS REGISTER ) " 15
* SCREEN 5
FCC " " 0
FCC "COMPILATION ONLY, USE IN DEF " 1
FCC "EXECUTION ONLY " 2
FCC "CONDITIONALS NOT PAIRED " 3
FCC "DEFINITION INCOMPLETE " 4
FCC "IN PROTECTED DICTIONARY " 5
FCC "USE ONLY WHEN LOADING " 6
FCC "OFF CURRENT EDITING SCREEN " 7
FCC "DECLARE VOCABULARY " 8
FCC "DEFINITION NOT IN VOCABULARY " 9
FCC "IN FORWARD BLOCK " 10
FCC "ALLOCATION LIST CORRUPTED: LOST " 11
FCC "CAN'T REDEFINE nul! " 12
FCC "NOT FORWARD REFERENCE " 13
FCC " ( WAS IMMEDIATE ) " 14
FCC " " 15
* SCREEN 6
FCC "( MORE ERROR MESSAGES asm6809 ) " 0
FCC "HAS INCORRECT ADDRESS MODE " 1
FCC "HAS INCORRECT INDEX MODE " 2
FCC "OPERAND NOT REGISTER " 3
FCC "HAS ILLEGAL IMMEDIATE " 4
FCC "PC OFFSET MUST BE ABSOLUTE " 5
FCC "ACCUMULATOR OFFSET REQUIRED " 6
FCC "ILLEGAL MEMORY INDIRECTION (6809) " 7
FCC "ILLEGAL INDEX BASE (6809) " 8
FCC "ILLEGAL TARGET SPECIFIED " 9
FCC "CAN'T STACK ON SELF (6809) " 10
FCC "DUPLICATE IN LIST " 11
FCC "REGISTER NOT STACK (6809) " 12
FCC "EMPTY REGISTER LIST (6809) " 13
FCC "IMMEDIATE OPERAND REQUIRED " 14
FCC "REQUIRES CONDITION " 15
*
* SCREEN 7
FCC " " 0
FCC "COMPILE-TIME STACK UNDERFLOW " 1
FCC "COMPILE-TIME STACK OVERFLOW " 2
FCC " " 3
FCC " " 4
FCC " " 5
FCC " " 6
FCC " " 7
FCC " " 8
FCC " " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " " 15
*
* SCREEN 8
FCC " ( Crude editing facilities. -- one byte characters ) " 0
FCC " " 1
FCC " VOCABULARY EDITOR DEFINITIONS " 2
FCC " " 3
FCC " ( n -- nb nc ) ( convert line number to block, count offset ) " 4
FCC " : L2BLOCK 64 * B/BUF /MOD ; ( 64 characters per line magic # ) " 5
FCC " " 6
FCC " ( n -- n ) ( convert screen number to block number ) " 7
FCC " : S2BLOCK B/SCR * ; ( magic numbers hidden in B/SCR ) " 8
FCC " " 9
FCC " ( ns nl -- addr ) ( screen, line to address in block ) " 10
FCC " : SL2BB SWAP S2BLOCK SWAP L2BLOCK SWAP >R + BLOCK R> + ; " 11
FCC " " 12
FCC " ( ns nl -- ) ( show one line of the screen ) " 13
FCC " : SHOWLINE SL2BB CR 64 TYPE ; ( list just one line ) " 14
FCC " --> " 15
*
* SCREEN 9
FCC " ( More crude editing facilities. -- one byte characters ) " 0
FCC " " 1
FCC " 0 VARIABLE LNEDBUF 62 ALLOT ( buffer for line editing ) " 2
FCC " " 3
FCC " ( ns nl -- ) ( overwrite one line of the screen ) " 4
FCC " : PUTLINE LNEDBUF 64 BLANKS ( just enough to write to disc ) " 5
FCC " CR LNEDBUF 64 EXPECT CR ( just enough to write ) " 6
FCC " SL2BB LNEDBUF SWAP 64 CMOVE UPDATE ; " 7
FCC " ( Full screen editing requires keyboard control codes. ) " 8
FCC " " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " " 15
*
* I don't know enough about the EXORciser, and don't want to take the time
* to try to work through the disk simulation in exorsim to get real simulated
* disk access running.
* This gives me enough to check my understanding of forth, to help me figure
* out my bif-c project or whatever my next step is.
*
* Going farther with the exorsim version of the fig-FORTH 6800 model would be
* a good student exercise, maybe? (For what coursework?)
* But I think I need to move on.
*
* SCREEN 10
FCC " " 0
FCC " " 1
FCC " " 2
FCC " " 3
FCC " " 4
FCC " " 5
FCC " " 6
FCC " " 7
FCC " " 8
FCC " " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " " 15
*
* SCREEN 11
FCC " " 0
FCC " " 1
FCC " " 2
FCC " " 3
FCC " " 4
FCC " " 5
FCC " " 6
FCC " " 7
FCC " " 8
FCC " " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " " 15
*
* SCREEN 12
FCC " " 0
FCC " " 1
FCC " " 2
FCC " " 3
FCC " " 4
FCC " " 5
FCC " " 6
FCC " " 7
FCC " " 8
FCC " " 9
FCC " " 10
FCC " " 11
FCC " " 12
FCC " " 13
FCC " " 14
FCC " " 15
*
RAMDEN EQU *
RAMDSZ EQU RAMDEN-MEMEND
*
ORG ORIG ; set the COLD entry address
PAGE
OPT L
END