X-Forth#
Author: Carsten Strotmann
Language: FORTH
Compiler/Interpreter: X-FORTH /ATASM
Published: 10.2003
Sourcecode of X-Forth for Atari 800/800XL/130XE, indirect threaded Forth based on FIG-Forth
Code compiles with ATASM -> http://atasm.sf.net
; -------------------------------------------------------------------------
; X-FORTH 1.1b
; RELEASE 18.10.2003
; Homepage: http://www.strotmann.de/twiki/bin/view/APG/ProjXForth
; License: GNU Public License (GPL)
;
; based on Sources from fig-forth and Andreas Jung
;
; compiles with ATASM --> http://atasm.sourceforge.net
;--------------------------------------------------------------------------
; Flags
DEBUG = 0
KEYWAIT = 1
FINDDEBUG = 0
FILE = 1
DYNMEMTOP = 0
; Startadresse im Speicher
.BANK
* = $2000
; Kernal-Routinen des Atari800
DOSVEC = $000A
DOSINI = $000C
; FORTH-Systemkonstanten. Sie muessen gegebenenfalls an die jeweilige
; Hardware angepasst werden.
BOS = $8E ; Start des Daten-Stacks in der Zeropage
TOS = $C6 ; Zeiger auf den TOS ($C6)
N = $F0 ; temporaerer Arbeitsspeicher ($F0) (orig TOS+8)
IP = N+8 ; Instruction Pointer IP ($F8)
W = IP+3 ; Codefeld-Pointer W ($FB)
UP = W+2 ; User-Pointer UP ($FD)
XSAVE = UP+2 ; temporaerer Speicher fuer das X-Register ($FF)
;
TIBX = $0100 ; Terminal Input Buffer, 84 Bytes
MEM = $B800 ; Ende des FORTH-Speichers
UAREA = MEM-128 ; User-Area, 128 Bytes
; Der Speicher zwischen dem Ende des Dictionaries und DAREA steht fuer
; Benutzerprogramme zur Verfuegung.
; Es folgen nun die Boot-up-Parameter, d.h. Sprungvektoren und
; Parameter zur Systembeschreibung.
ORIG NOP ; 0+ORIGIN: Kaltstart ueber COLD
JMP PFA_COLD ;
REENTR NOP ; 4+ORIGIN: Warmstart ueber WARM
JMP WARM ;
.WORD $0004 ; 8+ORIGIN: "6502" zur Basis 36
.WORD $5ED2 ;
.WORD NFA_LASTWORD ; 12+ORIGIN: NFA des letzten Wortes
.WORD 126 ; 14+ORIGIN: externer Backspace-Charakter
.WORD UAREA ; 16+ORIGIN: initialer User-Pointer UP
.WORD TOS ; 18+ORIGIN: Startwert fuer S0
.WORD $1FF ; 20+ORIGIN: Startwert fuer R0
.WORD TIBX ; 22+ORIGIN: Startwert fuer TIB
.WORD 31 ; 24+ORIGIN: Startwert fuer WIDTH
.WORD 0 ; 26+ORIGIN: Startwert fuer WARNING
.WORD TOP ; 28+ORIGIN: Startwert fuer FENCE
.WORD TOP ; 30+ORIGIN: Startwert fuer DP
.WORD PFA_FORTH+6 ; 32+ORIGIN: Startwert fuer VOC-LINK
; Die folgenden NOP's bewirken eine Verschiebung des Dictionaries, so
; dass kein Codefeld auf eine Adresse der Form $XXFF faellt. Aufgrund
; eines Bugs im 6502-Prozessor wuerde dann naemlich der indirekte
; Sprung an der Adresse W-1 nicht richtig funktionieren. Bei jeder
; Aenderung des Dictionaries muessen die folgenden Zeilen gegebenenfalls
; geaendert werden.
; NOP
; NOP
NOP
; >>>>>>>>>>>>>>>> LIT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( LIT [ -> n ] legt die inline folgende Zahl auf den Stack. )
;( ========================================================================= )
NFA_LIT .CBYTE $83, "LIT"
LFA_LIT .WORD 0
CFA_LIT .WORD PFA_LIT
PFA_LIT
LDA (IP),Y ; Lo-Byte der inline folgenden Zahl holen
PHA ; und auf den Stack retten
INC IP ; Instruction-Pointer inkrementieren
BNE L30
INC IP+1
L30
LDA (IP),Y ; Hi-Byte der inline folgenden Zahl holen
L31
INC IP ; Instruction-Pointer inkrementieren
BNE PUSH
INC IP+1
PUSH
DEX ; Datenstack-Pointer dekrementieren
DEX
PUT
STA 1,X ; Hi-Byte (ist in A) auf den Datenstack legen
PLA ; Lo-Byte vom Stack holen
STA 0,X ; und auf den Datenstack legen
; =========================================================================
; Der Adressinterpreter NEXT holt die Adresse des naechsten Secondaries
; und fuehrt es aus.
; =========================================================================
NEXT
LDY #1
LDA (IP),Y ; Hi-Byte der Wortadresse
STA W+1 ; im W-Register ablegen
DEY
LDA (IP),Y ; Lo-Byte der Wortadresse
STA W ; im W-Register ablegen
.IF debug
PHA
LDA DEBUGFLG
BEQ DL1
PLA
JSR TRACE ; DEBUG
PHA
DL1 PLA
.ENDIF
CLC
LDA IP ; IP um 2 inkrementieren
ADC #2
STA IP
BCC L54
INC IP+1
L54
JMP W-1 ; indirekten Sprung nach (W) ausfuehren
; >>>>>>>>>>>>>>>> CLIT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CLIT [ -> b ] legt das inline folgende Byte auf den Stack. )
;( ========================================================================= )
NFA_CLIT .CBYTE $84,"CLIT"
LFA_CLIT .WORD NFA_LIT
CFA_CLIT .WORD PFA_CLIT
PFA_CLIT
LDA (IP),Y ; inline folgendes Byte holen
PHA ; und auf den Stack legen
TYA ; Akkumulator (Hi-Byte) mit Y=0 laden
BEQ L31 ; und in die Routine LIT verzweigen
; =========================================================================
; Die Routine SETUP poppt n Zellen vom Datenstack und schreibt sie in den
; temporaeren Speicher ab Adresse N. Die Zahl n wird im Akkumulator
; uebergeben.
; =========================================================================
SETUP
ASL A ; n verdoppeln, ergibt Anzahl zu poppender Bytes
STA N-1 ; Anzahl zu poppender Bytes sichern
L63
LDA 0,X ; ein Byte vom Datenstack holen (zu Anfang ist Y=0)
STA N,Y ; und im Speicherbereich ab Adresse N ablegen
INX ; Datenstack-Pointer inkrementieren
INY ; Zielindex inkrementieren
CPY N-1 ; sind bereits 2*n Bytes gepoppt?
BNE L63 ; nein, dann weitermachen
LDY #0 ; Y.=0 wiederherstellen
RTS ; und fertig
; >>>>>>>>>>>>>>>> EXECUTE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( EXECUTE [ addr -> ] fuehrt das Wort aus, dessen CFA auf dem Stack liegt. )
;( ========================================================================= )
NFA_EXECUTE .CBYTE $87,"EXECUTE"
LFA_EXECUTE .WORD NFA_CLIT
CFA_EXECUTE .WORD PFA_EXECUTE
PFA_EXECUTE
LDA 0,X ; Lo-Byte von addr
STA W ; in das W-Register schreiben
LDA 1,X ; Hi-Byte von addr
STA W+1 ; in das W-Register schreiben
INX ; addr vom Datenstack nehmen
INX
JMP W-1 ; Secondary ab addr ausfuehren
; >>>>>>>>>>>>>>>> BRANCH <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( BRANCH [ ] bewirkt einen relativen Sprung, abhaengig vom inline folgenden )
;( Offset. )
;( ========================================================================= )
NFA_BRANCH .CBYTE $86, "BRANCH"
LFA_BRANCH .WORD NFA_EXECUTE
CFA_BRANCH .WORD PFA_BRANCH
PFA_BRANCH
CLC
LDA (IP),Y ; Lo-Byte des Offsets holen
ADC IP ; zu aktuellem IP hinzuaddieren
PHA ; und auf den Stack retten
INY
LDA (IP),Y ; Hi-Byte des Offsets holen
ADC IP+1 ; zu aktuellem IP hinzuaddieren
STA IP+1 ; und im IP-Register ablegen
PLA ; Lo-Byte des neuen IP-Inhaltes vom Stack holen
STA IP ; und im IP-Register ablegen
JMP NEXT+2 ; dort weitermachen, LDY #1 kann uebersprungen werden
; >>>>>>>>>>>>>>>> 0BRANCH <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( 0BRANCH [ f -> ] bewirkt einen relativen Sprung, abhaengig vom inline )
;( folgenden Offset, wenn f Null ist. )
;( ========================================================================= )
NFA_0BRANCH .CBYTE $87, "0BRANCH"
LFA_0BRANCH .WORD NFA_BRANCH
CFA_0BRANCH .WORD PFA_0BRANCH
PFA_0BRANCH
INX ; f vom Datenstack nehmen
INX
LDA $FE,X ; f testen
ORA $FF,X
BEQ PFA_BRANCH ; verzweigen, falls f=0
BUMP CLC
LDA IP ; sonst IP ueber den Offset hinwegsetzen
ADC #2
STA IP
BCC L122
INC IP+1
L122 JMP NEXT ; und weitermachen
; >>>>>>>>>>>>>>>> (LOOP) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [LOOP] [ ] inkrementiert den Loop-Index um 1 und testet auf Erreichen der )
;( Abbruchbedingung. Eventuell wird gemaess einem inline folgenden Offset )
;( verzweigt. )
;( ========================================================================= )
NFA_BRACKETLOOP .CBYTE $86, "(LOOP)"
LFA_BRACKETLOOP .WORD NFA_0BRANCH
CFA_BRACKETLOOP .WORD PFA_BRACKETLOOP
PFA_BRACKETLOOP
L130 STX XSAVE ; X-Register retten
TSX ; Stackpointer nach X bringen
INC $101,X ; Loop-Index I inkrementieren
BNE PL1
INC $102,X
PL1 CLC
LDA $103,X ; Hi(Schleifenlimit-I-1) berechnen
SBC $101,X
LDA $104,X
SBC $102,X
PL2 LDX XSAVE ; X-Register wiederherstellen
ASL A ; falls obige Differenz nicht negativ:
BCC PFA_BRANCH ; an den Schleifenanfang verzweigen
PLA ; sonst Schleifenlimit und I vom Stack nehmen
PLA
PLA
PLA
JMP BUMP ; und Offset uebergehen
; >>>>>>>>>>>>>>>> (+LOOP) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [+LOOP] [ n -> ] inkrementiert den Loop-Index um n und testet auf Errei- )
;( chen der Abbruchbedingung. Eventuell wird gemaess einem inline folgenden )
;( Offset verzweigt. )
;( ========================================================================= )
NFA_BRACKETPLUSLOOP .CBYTE $87, "(+LOOP)"
LFA_BRACKETPLUSLOOP .WORD NFA_BRACKETLOOP
CFA_BRACKETPLUSLOOP .WORD PFA_BRACKETPLUSLOOP
PFA_BRACKETPLUSLOOP
INX ; Datenstackpointer inkrementieren
INX
STX XSAVE ; X-Register retten
LDA $FF,X ; Hi-Byte von n
PHA ; zweimal auf den Stack legen
PHA
LDA $FE,X ; Lo-Byte von n holen
TSX ; Stackpointer nach X holen
INX ; Hi-Byte von n interessiert momentan nicht
INX
CLC
ADC $101,X ; Lo-Byte von n auf I aufaddieren
STA $101,X
PLA ; Hi-Byte von n holen
ADC $102,X ; und auf I aufaddieren
STA $102,X
PLA ; nochmal Hi-Byte von n holen
BPL PL1 ; falls n positiv: bei (LOOP) weitermachen
CLC
LDA $101,X ; sonst Hi(I-Schleifenlimit-1) berechnen
SBC $103,X
LDA $102,X
SBC $104,X
JMP PL2 ; und hiermit bei (LOOP) weitermachen
; >>>>>>>>>>>>>>>> (DO) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [DO] [ n1 n2 -> ] bringt die Loop-Parameter [Startindex, Limit] zum )
;( Return-Stack. )
;( ========================================================================= )
NFA_BRACKETDO .CBYTE $84, "(DO)"
LFA_BRACKETDO .WORD NFA_BRACKETPLUSLOOP
CFA_BRACKETDO .WORD PFA_BRACKETDO
PFA_BRACKETDO
LDA 3,X ; Limit zum Returnstack bringen
PHA
LDA 2,X
PHA
LDA 1,X ; Startindex zum Returnstack bringen
PHA
LDA 0,X
PHA
POPTWO
INX ; n2 von Datenstack poppen
INX
POP
INX ; n1 vom Datenstack poppen
INX
JMP NEXT ; und weitermachen
; >>>>>>>>>>>>>>>> R <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( R [ -> n ] kopiert das oberste Element des Return-Stacks zum Parameter- )
;( Stack. )
;( ========================================================================= )
NFA_R .CBYTE $81, "R"
LFA_R .WORD NFA_BRACKETDO
CFA_R .WORD PFA_R
PFA_R
STX XSAVE ; Datenstackpointer retten
TSX ; X-Register als Index in den Returnstack benutzen
LDA $101,X ; Lo-Byte vom Returnstack holen
PHA ; und merken
LDA $102,X ; Hi-Byte vom Returnstack holen
LDX XSAVE ; Datenstackpointer wiederherstellen
JMP PUSH ; n auf den Datenstack pushen und fertig
; >>>>>>>>>>>>>>>> I <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( I [ -> n ] legt den aktuellen Loop-Index auf den Stack. )
;( ========================================================================= )
NFA_I .CBYTE $81, "I"
LFA_I .WORD NFA_R
CFA_I .WORD PFA_R ; Link zu "R", Befehl identisch
PFA_I
; >>>>>>>>>>>>>>>> J <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( J [ -> n ] kopiert den Zaehlindex der aesseren Scheife auf den Datenstack )
;( )
;( ========================================================================= )
NFA_J .CBYTE $81, "J"
LFA_J .WORD NFA_I
CFA_J .WORD PFA_J
PFA_J
STX XSAVE ; Datenstackpointer retten
TSX ; X-Register als Index in den Returnstack benutzen
LDA $105,X ; Lo-Byte vom Returnstack holen
PHA ; und merken
LDA $106,X ; Hi-Byte vom Returnstack holen
LDX XSAVE ; Datenstackpointer wiederherstellen
JMP PUSH ; n auf den Datenstack pushen und fertig
; >>>>>>>>>>>>>>>> DIGIT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DIGIT [ c n1 -> n2 tf ] falls ok, [ c n1 -> ff ] falls schlecht. Wandelt )
;( den ASCII-Charakter c in sein Zahlen-Aequivalent n2 um. Als Basis wird )
;( n1 benutzt. Ist c ein gueltiges Ziffernsymbol im n1-System, so wird tf=1 )
;( zurueckgegeben, sonst ff=0. )
;( ========================================================================= )
NFA_DIGIT .CBYTE $85, "DIGIT"
LFA_DIGIT .WORD NFA_J
CFA_DIGIT .WORD PFA_DIGIT
PFA_DIGIT
SEC
LDA 2,X ; Zeichen c holen
SBC #$30 ; und '0' subtrahieren
BMI L234 ; falls negativ: Misserfolg melden
CMP #$A ; mit 10 vergleichen
BMI L227 ; kleiner, dann weiter
SEC
SBC #7 ; sonst weitere 7 abziehen
CMP #$A ; falls kleiner als 10:
BMI L234 ; Misserfolg melden
L227
CMP 0,X ; ermittelte Zahl mit Basis n1 vergleichen
BPL L234 ; Zahl groesser oder gleich Basis, dann Misserfolg melden
STA 2,X ; sonst Zahl in n2 zurueckgeben
LDA #1 ; tf zurueckgeben (Y=0)
PHA
TYA
JMP PUT
L234 TYA ; Misserfolg: ff zurueckgeben (Y=0)
PHA
INX
INX
JMP PUT
; >>>>>>>>>>>>>>>> (FIND) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [FIND] [ addr1 addr2 -> pfa b tf ] falls ok, [ addr1 addr2 -> ff ] sonst. )
;( Sucht im Dictionary, beginnend bei der NFA addr2, nach dem String addr1. )
;( Wird das Wort gefunden, so wird seine PFA, das Count-Byte und ein true- )
;( Flag uebergeben, sonst lediglich ein false-Flag. )
;( ========================================================================= )
NFA_BRACKETFIND .CBYTE $86, "(FIND)"
LFA_BRACKETFIND .WORD NFA_DIGIT
CFA_BRACKETFIND .WORD PFA_BRACKETFIND
PFA_BRACKETFIND
LDA #2 ; addr1 und addr2
JSR SETUP ; in den Speicher ab Adresse N poppen
STX XSAVE ; Datenstackpointer retten
L249 LDY #0 ; Vergleich beginnt beim Count-Byte
LDA (N),Y ; Count-Byte des Woerterbucheintrages holen
EOR (N+2),Y ; und mit Count-Byte des Strings vergleichen
AND #$3F ; dabei die beiden obersten Bits ignorieren
BNE L281 ; bei Ungleichheit verzweigen
L254 INY ; naechstes Zeichen anvisieren
LDA (N),Y ; naechstes Zeichen des Woerterbucheintrages holen
EOR (N+2),Y ; und mit naechstem Zeichen des Strings vergleichen
ASL A ; hoechstes Bit in den Uebertrag schieben
BNE L280 ; bei Ungleichheit verzweigen
BCC L254 ; weiter vergleichen falls String-Ende noch nicht erreicht
LDX XSAVE ; bei Gleichheit Datenstackpointer wiederherstellen
DEX ; auf dem Datenstack Platz fuer pfa und b schaffen
DEX
DEX
DEX
CLC
TYA ; Offset des letzten String-Zeichens
ADC #5 ; plus 5 ergibt Offset des Parameterfeldes
ADC N ; plus NFA ergibt PFA
STA 2,X ; Lo-Byte der PFA in den Datenstack schreiben
LDY #0
TYA ; eventuell aufgetretenen Uebertrag
ADC N+1 ; in Hi-Byte der PFA beruecksichtigen
STA 3,X ; Hi-Byte der PFA in den Datenstack schreiben
STY 1,X ; Hi-Byte von b auf Null setzen
LDA (N),Y ; Count-Byte des gefundenen Wortes holen
STA 0,X ; und in den Datenstack schreiben
LDA #1 ; True-Flag vorbereiten
PHA
JMP PUSH ; auf den Datenstack legen und fertig
L280 BCS L284 ; Suche ueberspringen falls String-Ende erreicht
L281 INY ; naechstes Zeichen anvisieren
LDA (N),Y ; naechstes Zeichen des Woerterbucheintrages holen
.IF finddebug
JSR OUTCH ; debug - Druckt die Suche nach einem Word
LDA (N),Y ; debug - wenn Fehler in der Verkettung bestehen,
; debug - Woerter nicht gefunden werden
.ENDIF
BPL L281 ; hoechstes Bit nicht gesetzt, dann weitersuchen
L284 INY ; sonst Byte hinter dem Namenfeld anvisieren
LDA (N),Y ; Lo-Byte des Linkfeldes holen
TAX ; und in das X-Register laden
INY ; Hi-Byte des Linkfeldes anvisieren
LDA (N),Y ; und holen
STA N+1 ; und anstelle des alten Wertes von addr2 ablegen
STX N ; das gleiche mit dem Lo-Byte des Linkfeldes
ORA N ; im Linkfeld angegebene Adresse testen
BNE L249 ; ungleich Null, dann erneut vergleichen
LDX XSAVE ; sonst Datenstackpointer wiederherstellen
LDA #0 ; False-Flag vorbereiten
PHA
JMP PUSH ; auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> ENCLOSE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ENCLOSE [ addr1 c -> addr1 n1 n2 n3 ] separiert einen Text beginnend ab )
;( der Adresse addr1 mit dem Delimiter c. n1 ist der Byte-Offset zum ersten )
;( von c verschiedenen ASCII-Charakter, n2 der Byte-Offset zum ersten )
;( Delimiter-Charakter c hinter dem Text und n3 der Byte-Offset zum ersten )
;( Charakter, der auf diesen Delimiter folgt. Das Zeichen ASCII-Null dient )
;( als unbedingter Delimiter, ab dem nicht mehr weitergesucht wird. )
;( ========================================================================= )
NFA_ENCLOSE .CBYTE $87,"ENCLOSE"
LFA_ENCLOSE .WORD NFA_BRACKETFIND
CFA_ENCLOSE .WORD PFA_ENCLOSE
PFA_ENCLOSE
LDA #2 ; Parameter addr1 und c
JSR SETUP ; in den Speicher ab N poppen
TXA
SEC ; Platz im Datenstack fuer addr1, n1, n2 und n3
SBC #8 ; bereitstellen
TAX
STY 3,X ; Hi-Byte von n2 auf Null setzen (Y=0)
STY 1,X ; Hi-Byte von n1 ebenso
DEY
L313 INY ; naechstes Zeichen im Text ab addr1 anvisieren
LDA (N+2),Y ; Zeichen holen
CMP N ; mit c vergleichen
BEQ L313 ; alle c's am Anfang ueberlesen
STY 4,X ; Position des ersten Nicht-c in n1 ablegen
L318 LDA (N+2),Y ; naechstes Zeichen im Text ab addr1 holen
BNE L327 ; nicht Null, dann verzweigen
STY 2,X ; sonst Position der Null in n2
STY 0,X ; und in n3 ablegen
TYA
CMP 4,X ; Position mit Position des ersten Nicht-c vergleichen
BNE L326 ; andere Position, dann verzweigen
INC 2,X ; sonst n2 inkrementieren
L326 JMP NEXT ; und fertig
L327 STY 2,X ; aktuelle Position in n2 ablegen
INY ; naechstes Zeichen anvisieren
CMP N ; aktuelles Zeichen mit c vergleichen
BNE L318 ; bei Ungleichheit weitersuchen
STY 0,X ; sonst naechste Position im n3 ablegen
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> EMIT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( EMIT [ c -> ] sendet den ASCII-Charakter c zum Standard-Ausgabegeraet und )
;( erhoeht die USER-Variable OUT um 1. )
;( ========================================================================= )
NFA_EMIT .CBYTE $84, "EMIT"
LFA_EMIT .WORD NFA_ENCLOSE
CFA_EMIT .WORD PFA_EMIT
PFA_EMIT
XEMIT
TYA ; A.=0 (Y=0)
SEC
LDY #$1A ; Offset der User-Variablen OUT
ADC (UP),Y ; OUT inkrementieren
STA (UP),Y
INY
LDA #0
ADC (UP),Y ; auch Hi-Byte von OUT beruecksichtigen
STA (UP),Y
TYA ; Y Register auf den Stack retten
PHA
LDA 0,X ; Zeichen c holen
STX XSAVE ; Datenstackpointer retten
JSR OUTCH ; Zeichen ausgeben
LDX XSAVE ; Datenstackpointer wiederherstellen
PLA
TAY ; Y Register wiederherstellen
JMP POP ; c vom Datenstack entfernen und fertig
; >>>>>>>>>>>>>>>> KEY <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( KEY [ -> c ] wartet auf eine Tastaturbetaetigung und uebergibt den ASCII- )
;( Code der gedrueckten Taste. )
;( ========================================================================= )
NFA_KEY .CBYTE $83, "KEY"
LFA_KEY .WORD NFA_EMIT
CFA_KEY .WORD PFA_KEY
PFA_KEY
XKEY
STX XSAVE ; Datenstackpointer retten
XKEY1
JSR GETCH ; Zeichen von der Tastatur einlesen (im accu)
LDX XSAVE ; Datenstackpointer wiederherstellen
JMP PUSHOA ; Akkumulator als c auf den Datenstack und fertig
; >>>>>>>>>>>>>>>> ?TERMINAL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?TERMINAL [ -> f ] liefert f=1 zurueck, wenn eine Taste betaetigt wurde, )
;( sonst f=0. )
;( ========================================================================= )
NFA_QUERYTERMINAL .CBYTE $89, "?TERMINAL"
LFA_QUERYTERMINAL .WORD NFA_KEY
CFA_QUERYTERMINAL .WORD PFA_QUERYTERMINAL
PFA_QUERYTERMINAL
XQTER
CH = $02FC
LDA CH ; wenn $FF dann keine Taste gedrückt
CLC
ADC #1 ; +1 = 0 wenn keine Taste gedrückt
BEQ XQTER1
LDA #1 ; ansonsten 1
XQTER1
JMP PUSHOA ; Akkumulator auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> CR <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CR [ ] gibt einen Zeilenvorschub auf den Bildschirm aus. )
;( ========================================================================= )
NFA_CR .CBYTE $82, "CR"
LFA_CR .WORD NFA_QUERYTERMINAL
CFA_CR .WORD PFA_CR
PFA_CR
XCR STX XSAVE ; Datenstackpointer retten
TYA
PHA ; Y Register retten
LDA #155 ; Carriage Return
JSR OUTCH ; auf dem Bildschirm ausgeben
LDX XSAVE ; Datenstackpointer wiederherstellen
PLA ; Y Register wiederherstellen
TAY
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> CMOVE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CMOVE [ from to count ] kopiert von Adresse from nach Adresse to genau )
;( count Bytes in aufsteigender Richtung. )
;( ========================================================================= )
NFA_CMOVE .CBYTE $85, "CMOVE"
LFA_CMOVE .WORD NFA_CR
CFA_CMOVE .WORD PFA_CMOVE
PFA_CMOVE
LDA #3 ; alle drei Parameter
JSR SETUP ; in den Speicherbereich ab Adresse N poppen
L370 CPY N ; noch nicht count Bytes kopiert?
BNE L375 ; dann verzweigen
DEC N+1 ; auch Hi-Byte von count beruecksichtigen
BPL L375 ; und verzweigen, wenn noch Bytes zu kopieren sind
JMP NEXT ; sonst fertig
L375 LDA (N+4),Y ; ein Byte holen
STA (N+2),Y ; und im Zielbereich ablegen
INY ; naechstes Byte anvisieren
BNE L370 ; bei Ueberlauf des Y-Registers:
INC N+5 ; Hi-Byte von from inkrementieren
INC N+3 ; Hi-Byte von to inkrementieren
JMP L370 ; und weiterkopieren
; >>>>>>>>>>>>>>>> U* <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( U* [ u1 u2 -> ud ] multipliziert die beiden vorzeichenlosen Zahlen u1 und )
;( u2 und gibt das Ergebnis als doppeltgenaue, vorzeichenlose Zahl ud )
;( zurueck. )
;( ========================================================================= )
NFA_UMULT .CBYTE $82, "U*"
LFA_UMULT .WORD NFA_CMOVE
CFA_UMULT .WORD PFA_UMULT
PFA_UMULT
LDA 2,X ; u1 nach N/N+1 retten
STA N ; und ud auf Null setzen (Y=0)
STY 2,X
LDA 3,X
STA N+1
STY 3,X
LDY #16 ; Y-Register als Zaehler (16 Bit)
L396 ASL 2,X ; Zwischenergebnis ud verdoppeln
ROL 3,X
ROL 0,X ; und rechts in u2 hineinschieben
ROL 1,X ; dabei das jetzt hoechste Bit von u2 holen
BCC L411 ; Bit=0, dann verzweigen
CLC
LDA N ; sonst das gerettete u1 auf ud aufaddieren
ADC 2,X
STA 2,X
LDA N+1
ADC 3,X
STA 3,X
LDA #0 ; auch das Hi-Word von ud beruecksichtigen
ADC 0,X
STA 0,X
L411 DEY ; naechstes Bit anvisieren
BNE L396 ; noch nicht alle Bits durch, dann weiterrechnen
JMP NEXT ; sonst fertig
; >>>>>>>>>>>>>>>> U/ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( U/ [ ud u1 -> u2 u3 ] dividiert die doppelt genaue, vorzeichenlose Zahl )
;( ud durch die vorzeichenlose Zahl u1 und uebergibt den Quotienten u3 und )
;( den Rest u2 als vorzeichenlose Zahlen. )
;( ========================================================================= )
NFA_UDIV .CBYTE $82, "U/"
LFA_UDIV .WORD NFA_UMULT
CFA_UDIV .WORD PFA_UDIV
PFA_UDIV
LDA 4,X ; Hi-Word von ud nach [4/5,X] bringen
LDY 2,X ; und Lo-Word von ud nach [2/3,X]
STY 4,X ; wobei das Lo-Word bereits einmal verdoppelt wird
ASL A
STA 2,X
LDA 5,X
LDY 3,X
STY 5,X
ROL A
STA 3,X
LDA #16 ; Schleife wird 16 mal durchlaufen
STA N ; N ist Schleifenzaehler
L433 ROL 4,X ; Hi-Word von ud verdoppeln
ROL 5,X
SEC
LDA 4,X ; u1 vom Hi-Word von ud abziehen
SBC 0,X ; Ergebnis nach Y/A
TAY
LDA 5,X
SBC 1,X
BCC L444 ; falls Ergebnis nicht negativ:
STY 4,X ; Subtraktion an ud tatsaechlich durchfuehren
STA 5,X
L444 ROL 2,X ; Lo-Word von ud nach links schieben
ROL 3,X ; dabei eventuell eine 1 in den Quotienten hineinschieben
DEC N ; naechstes Bit anvisieren
BNE L433 ; noch nicht alle Bits durch, dann weitermachen
JMP POP ; sonst u1 vom Datenstack entfernen und fertig
; >>>>>>>>>>>>>>>> AND <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( AND [ n1 n2 -> n3 ] ermittelt die bitweise Und-Verknuepfung der Zahlen n1 )
;( und n2. )
;( ========================================================================= )
NFA_AND .CBYTE $83, "AND"
LFA_AND .WORD NFA_UDIV
CFA_AND .WORD PFA_AND
PFA_AND
LDA 0,X ; Lo-Byte von n1 AND n2 berechnen
AND 2,X
PHA
LDA 1,X ; Hi-Byte von n1 AND n2 berechnen
AND 3,X
BINARY
INX ; n2 vom Datenstack entfernen
INX
JMP PUT ; Ergebnis auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> OR <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( OR [ n1 n2 -> n3 ] ermittelt die bitweise Oder-Verknuepfung der Zahlen )
;( n1 und n2. )
;( ========================================================================= )
NFA_OR .CBYTE $82, "OR"
LFA_OR .WORD NFA_AND
CFA_OR .WORD PFA_OR
PFA_OR
LDA 0,X ; Lo-Byte von n1 OR n2 berechnen
ORA 2,X
PHA
LDA 1,X ; Hi-Byte von n1 OR n2 berechnen
ORA 3,X
INX ; n2 vom Datenstack entfernen
INX
JMP PUT ; Ergebnis auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> XOR <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( XOR [ n1 n2 -> n3 ] ermittelt die bitweise Exklusiv-Oder-Verknuepfung der )
;( Zahlen n1 und n2. )
;( ========================================================================= )
NFA_XOR .CBYTE $83, "XOR"
LFA_XOR .WORD NFA_OR
CFA_XOR .WORD PFA_XOR
PFA_XOR
LDA 0,X ; Lo-Byte von n1 XOR n2 berechnen
EOR 2,X
PHA
LDA 1,X ; Hi-Byte von n1 XOR n2 berechnen
EOR 3,X
INX ; n2 vom Datenstack entfernen
INX
JMP PUT ; Ergebnis auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> SP@ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SP@ [ -> addr ] ermittelt die Adresse des TOS [vor dem Aufruf]. )
;( ========================================================================= )
NFA_SPFETCH .CBYTE $83, "SP@"
LFA_SPFETCH .WORD NFA_XOR
CFA_SPFETCH .WORD PFA_SPFETCH
PFA_SPFETCH
TXA ; Adresse des TOS wird durch das X-Register angegeben
PUSHOA
PHA ; Akkumulator als Lo-Byte
LDA #0 ; und 0 als Hi-Byte
JMP PUSH ; auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> SP! <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SP! [ ] reinitialisiert den Stack-Pointer. )
;( ========================================================================= )
NFA_SPSTORE .CBYTE $83, "SP!"
LFA_SPSTORE .WORD NFA_SPFETCH
CFA_SPSTORE .WORD PFA_SPSTORE
PFA_SPSTORE
LDY #6 ; User-Variable S0 enthaelt Initialwert des Datenstackpointers
LDA (UP),Y ; Inhalt der User-Variablen holen
TAX ; in den Datenstackpointer X laden
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> RP! <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( RP! [ ] reinitialisiert den Return-Stack-Pointer. )
;( ========================================================================= )
NFA_RPSTORE .CBYTE $83, "RP!"
LFA_RPSTORE .WORD NFA_SPSTORE
CFA_RPSTORE .WORD PFA_RPSTORE
PFA_RPSTORE
STX XSAVE ; Datenstackpointer retten
LDY #8 ; User-Variable R0 enthaelt Initialwert des Returnstackpointers
LDA (UP),Y ; Inhalt der User-Variablen holen
TAX ; und in den Returnstackpointer laden
TXS
LDX XSAVE ; Datenstackpointer wiederherstellen
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> ;S <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ;S [ ] beendet die Ausfuehrung des aktuellen Wortes und kehrt zum aufru- )
;( fenden Wort zurueck. )
;( ========================================================================= )
NFA_EXIT .CBYTE $82, ";S"
LFA_EXIT .WORD NFA_RPSTORE
CFA_EXIT .WORD PFA_EXIT
PFA_EXIT
PLA ; Returnadresse vom Returnstack poppen
STA IP ; und in den IP laden
PLA
STA IP+1
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> LEAVE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( LEAVE [ ] erzwingt das Verlassen der aktuellen DO ... LOOP - oder DO ... )
;( +LOOP - Schleife, indem der Abbruchwert auf den Stand des aktuellen )
;( Index-Wertes gesetzt wird. )
;( ========================================================================= )
NFA_LEAVE .CBYTE $85, "LEAVE"
LFA_LEAVE .WORD NFA_EXIT
CFA_LEAVE .WORD PFA_LEAVE
PFA_LEAVE
STX XSAVE ; Datenstackpointer retten
TSX ; X-Register als Index in den Returnstack benutzen
LDA $101,X ; Limit auf den Wert des Schleifenzaehlers I setzen
STA $103,X
LDA $102,X
STA $104,X
LDX XSAVE ; Datenstackpointer wiederherstellen
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> >R <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( >R [ n -> ] legt die Zahl n auf den Return-Stack. )
;( ========================================================================= )
NFA_RPUSH .CBYTE $82, ">R"
LFA_RPUSH .WORD NFA_LEAVE
CFA_RPUSH .WORD PFA_RPUSH
PFA_RPUSH
LDA 1,X ; HI-Byte von n
PHA ; auf den Returnstack pushen
LDA 0,X ; Lo-Byte von n
PHA ; auf den Returnstack pushen
INX ; n vom Datenstack entfernen
INX
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> R> <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( R> [ -> n ] poppt das oberste Element vom Return-Stack und legt es auf )
;( den Parameterstack. )
;( ========================================================================= )
NFA_RPOP .CBYTE $82, "R>"
LFA_RPOP .WORD NFA_RPUSH
CFA_RPOP .WORD PFA_RPOP
PFA_RPOP
DEX ; Platz auf dem Datenstack fuer n schaffen
DEX
PLA ; Lo-Byte vom Returnstack poppen
STA 0,X ; und in den Datenstack schreiben
PLA ; Hi-Byte vom Returnstack poppen
STA 1,X ; und in den Datenstack schreiben
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> 0= <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( 0= [ n -> f ] uebergibt f=true, wenn die Zahl n gleich Null ist, sonst )
;( false. )
;( ========================================================================= )
NFA_NULLEQUAL .CBYTE $82, "0="
LFA_NULLEQUAL .WORD NFA_RPOP
CFA_NULLEQUAL .WORD PFA_NULLEQUAL
PFA_NULLEQUAL
LDA 0,X ; n testen
ORA 1,X
STY 1,X ; Hi-Byte von f auf Null setzen (Y=0)
BNE L613 ; Lo-Byte von f auf 1 setzen, falls n=0
INY
L613 STY 0,X
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> 0< <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( 0< [ n -> f ] uebergibt f=true, wenn die Zahl n kleiner Null ist, sonst )
;( false. )
;( ========================================================================= )
NFA_LTNULL .CBYTE $82, "0<"
LFA_LTNULL .WORD NFA_NULLEQUAL
CFA_LTNULL .WORD PFA_LTNULL
PFA_LTNULL
ASL 1,X ; hoechstes Bit von n holen
TYA ; und im Akkumulator zu 1 oder 0 werden lassen (Y=0)
ROL A
STY 1,X ; Hi-Byte von f auf Null setzen
STA 0,X ; Lo-Byte von f auf obiges Ergebnis setzen
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> + <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( + [ n1 n2 -> n3 ] berechnet die Summe der Zahlen n1 und n2. )
;( ========================================================================= )
NFA_PLUS .CBYTE $81, "+"
LFA_PLUS .WORD NFA_LTNULL
CFA_PLUS .WORD PFA_PLUS
PFA_PLUS
CLC
LDA 0,X ; Summe n3.=n1+n2 berechnen und in den Datenstack schreiben
ADC 2,X
STA 2,X
LDA 1,X
ADC 3,X
STA 3,X
INX ; n3 vom Datenstack entfernen
INX
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> D+ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( D+ [ d1 d2 -> Summe ] berechnet die doppeltgenaue Summe der beiden )
;( doppeltgenauen Zahlen d1 und d2. )
;( ========================================================================= )
NFA_DPLUS .CBYTE $82, "D+"
LFA_DPLUS .WORD NFA_PLUS
CFA_DPLUS .WORD PFA_DPLUS
PFA_DPLUS
CLC
LDA 2,X ; Lo-Word der Summe berechnen
ADC 6,X
STA 6,X
LDA 3,X
ADC 7,X
STA 7,X
LDA 0,X ; Hi-Word der Summe berechnen
ADC 4,X
STA 4,X
LDA 1,X
ADC 5,X
STA 5,X
JMP POPTWO ; d2 vom Stack entfernen und fertig
; >>>>>>>>>>>>>>>> MINUS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( MINUS [ n1 -> n2 ] negiert die Zahl n1. )
;( ========================================================================= )
NFA_NEGATE .CBYTE $85, "MINUS"
LFA_NEGATE .WORD NFA_DPLUS
CFA_NEGATE .WORD PFA_NEGATE
PFA_NEGATE
SEC
MINUS1
TYA
SBC 0,X ; Differenz 0-n1 berechnen (Y=0)
STA 0,X
TYA
SBC 1,X
STA 1,X
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> DMINUS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DMINUS [ d1 -> d2 ] negiert die doppeltgenaue Zahl d1. )
;( ========================================================================= )
NFA_DMINUS .CBYTE $86, "DMINUS"
LFA_DMINUS .WORD NFA_NEGATE
CFA_DMINUS .WORD PFA_DMINUS
PFA_DMINUS
SEC
TYA
SBC 2,X ; Lo-Word der Differenz 0-d1 berechnen (Y=0)
STA 2,X
TYA
SBC 3,X
STA 3,X
JMP MINUS1 ; Hi-Word der Differenz berechnen und fertig
; >>>>>>>>>>>>>>>> OVER <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( OVER [ n1 n2 -> n1 n2 n1 ] legt den Second auf den Stack. )
;( ========================================================================= )
NFA_OVER .CBYTE $84, "OVER"
LFA_OVER .WORD NFA_DMINUS
CFA_OVER .WORD PFA_OVER
PFA_OVER
LDA 2,X ; n1 holen
PHA
LDA 3,X
JMP PUSH ; auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> DROP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DROP [ n -> ] entfernt das oberste Element vom Stack. )
;( ========================================================================= )
NFA_DROP .CBYTE $84, "DROP"
LFA_DROP .WORD NFA_OVER
CFA_DROP .WORD POP
PFA_DROP
; >>>>>>>>>>>>>>>> SWAP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SWAP [ n1 n2 -> n2 n1 ] vertauscht die beiden obersten Stack-Elemente. )
;( ========================================================================= )
NFA_SWAP .CBYTE $84, "SWAP"
LFA_SWAP .WORD NFA_DROP
CFA_SWAP .WORD PFA_SWAP
PFA_SWAP
LDA 2,X ; Lo-Byte von n1 holen
PHA ; und merken
LDA 0,X ; Lo-Byte von n2 holen
STA 2,X ; und damit das Lo-Byte von n1 ueberschreiben
LDA 3,X ; Hi-Byte von n1 holen und im Akkumulator merken
LDY 1,X ; Hi-Byte von n2 holen
STY 3,X ; und damit das Hi-Byte von n1 ueberschreiben
JMP PUT ; gemerktes n1 in den Datenstack schreiben und fertig
; >>>>>>>>>>>>>>>> PICK <<<<<<<<<<<<<<<
;( ========================================================================= )
;( PICK [ n1 -> n2 ] holt das n-te Element des Stacks )
;( ========================================================================= )
NFA_PICK .CBYTE $84, "PICK"
LFA_PICK .WORD NFA_SWAP
CFA_PICK .WORD PFA_PICK
PFA_PICK
STX XSAVE ; Stackzeiger sichern
TXA ; Stackzeiger in den Accu
SEC
ADC 0,X ; Lo-Byte von n1 holen,
ADC 0,X ; verdoppeln und zum Stackzeiger addieren
TAX
DEX ; in den Stackzeiger schieben, zeigt nun auf Element n1
LDA 0,X ; Lo-Byte von n2 holen
PHA ; und merken
LDA 1,X ; Hi-Byte von n2 holen
LDX XSAVE
JMP PUT ; gemerktes n2 in den Datenstack schreiben und fertig
; >>>>>>>>>>>>>>>> DUP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DUP [ n -> n n ] dupliziert das oberste Stack-Element. )
;( ========================================================================= )
NFA_DUP .CBYTE $83, "DUP"
LFA_DUP .WORD NFA_PICK
CFA_DUP .WORD PFA_DUP
PFA_DUP
LDA 0,X ; n holen
PHA
LDA 1,X
JMP PUSH ; auf den Datenstack pushen und fertig
; >>>>>>>>>>>>>>>> +! <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( +! [ n addr -> ] inkrementiert die Zahl, auf die die Adresse addr zeigt, )
;( um n. )
;( ========================================================================= )
NFA_PLUSSTORE .CBYTE $82,"+!"
LFA_PLUSSTORE .WORD NFA_DUP
CFA_PLUSSTORE .WORD PFA_PLUSSTORE
PFA_PLUSSTORE
CLC
LDA (0,X) ; Lo-Byte der durch addr adressierten Zahl
ADC 2,X ; plus Lo-Byte von n
STA (0,X) ; an der Adresse addr ablegen
INC 0,X ; addr inkrementieren
BNE L754
INC 1,X
L754 LDA (0,X) ; Hi-Byte der durch addr adressierten Zahl
ADC 3,X ; plus Hi-Byte von n
STA (0,X) ; an der Adresse addr+1 ablegen
JMP POPTWO ; n und addr vom Datenstack entfernen und fertig
; >>>>>>>>>>>>>>>> TOGGLE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( TOGGLE [ addr b -> ] fuehrt eine bitweise Exklusiv-Oder-Verknuepfung des )
;( durch addr adressierten Bytes mit dem Bitmuster b durch. )
;( ========================================================================= )
NFA_TOGGLE .CBYTE $86, "TOGGLE"
LFA_TOGGLE .WORD NFA_PLUSSTORE
CFA_TOGGLE .WORD PFA_TOGGLE
PFA_TOGGLE
LDA (2,X) ; durch addr adressiertes Byte holen
EOR 0,X ; mit b XOR-verknuepfen
STA (2,X) ; und wieder im Speicher ablegen
JMP POPTWO ; addr und b vom Datenstack entfernen und fertig
; >>>>>>>>>>>>>>>> @ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( @ [ addr -> n ] ermittelt die durch addr adressierte Zahl. )
;( ========================================================================= )
NFA_FETCH .CBYTE $81, "@"
LFA_FETCH .WORD NFA_TOGGLE
CFA_FETCH .WORD PFA_FETCH
PFA_FETCH
LDA (0,X) ; Lo-Byte der durch addr adressierten Zahl holen
PHA ; und merken
INC 0,X ; addr inkrementieren
BNE L781
INC 1,X
L781 LDA (0,X) ; Hi-Byte holen und im Akkumulator merken
JMP PUT ; gemerkte Zahl in den Datenstack schreiben und fertig
; >>>>>>>>>>>>>>>> C@ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( C@ [ addr -> b ] ermittelt das durch addr adressierte Byte. )
;( ========================================================================= )
NFA_CFETCH .CBYTE $82, "C@"
LFA_CFETCH .WORD NFA_FETCH
CFA_CFETCH .WORD PFA_CFETCH
PFA_CFETCH
LDA (0,X) ; durch addr adressiertes Byte holen
STA 0,X ; und in den Datenstack schreiben
STY 1,X ; Hi-Byte auf Null setzen (Y=0)
JMP NEXT ; und fertig
; >>>>>>>>>>>>>>>> ! <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ! [ n addr -> ] speichert die Zahl n an die Adresse addr. )
;( ========================================================================= )
NFA_STORE .CBYTE $81, "!"
LFA_STORE .WORD NFA_CFETCH
CFA_STORE .WORD PFA_STORE
PFA_STORE
LDA 2,X ; Lo-Byte von n holen
STA (0,X) ; und bei addr abspeichen
INC 0,X ; addr inkrementieren
BNE L806
INC 1,X
L806 LDA 3,X ; Hi-Byte von n holen
STA (0,X) ; und bei addr+1 abspeichern
JMP POPTWO ; n und addr vom Datenstack entfernen
; >>>>>>>>>>>>>>>> C! <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( C! [ b addr -> ] speichert das Byte b an die Adresse addr. )
;( ========================================================================= )
NFA_CSTORE .CBYTE $82, "C!"
LFA_CSTORE .WORD NFA_STORE
CFA_CSTORE .WORD PFA_CSTORE
PFA_CSTORE
LDA 2,X ; Byte b holen
STA (0,X) ; und bei addr abspeichern
JMP POPTWO ; b und addr vom Datenstack entfernen und fertig
; >>>>>>>>>>>>>>>> : <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( : [ ] leitet eine Colon-Definition ein. )
;( ========================================================================= )
NFA_COLON .BYTE $81+$40, 186 ; IMMEDIATE
LFA_COLON .WORD NFA_CSTORE
CFA_COLON .WORD DOCOL
PFA_COLON
.WORD CFA_QUERYEXEC ; ?EXEC
.WORD CFA_STORECSP ; !CSP
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_FETCH ; @
.WORD CFA_CONTEXT ; CONTEXT
.WORD CFA_STORE ; !
.WORD CFA_CREATE ; CREATE
.WORD CFA_RIGHTBRACKET ; ]
.WORD CFA_BRACKETCODE ; (;CODE)
; das neue Wort fuehrt zunaechst folgenden Code aus:
DOCOL
LDA IP+1 ; Instruction Pointer IP auf den Returnstack pushen
PHA
LDA IP
PHA
.IF debug
PHA
LDA DEBUGFLG
BEQ DL2
JSR TCOLON ; DEBUG
DL2 PLA
.ENDIF
CLC
LDA W ; Wortadressregister
ADC #2 ; plus zwei ergibt Adresse des ersten Tokens
STA IP ; dort mit der Interpretation fortfahren
TYA
ADC W+1 ; auch Hi-Byte des IP beruecksichtigen (Y=0)
STA IP+1
JMP NEXT ; Interpretation an neuer Stelle fortsetzen
; >>>>>>>>>>>>>>>> ; <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ; [ ] schliesst eine Colon-Definition ab. )
;( ========================================================================= )
; : ;
; ?CSP ( ueberpruefen, ob die Stackposition noch die alte ist )
; COMPILE ;S ( Semis an das Ende des Wortes kompilieren )
; SMUDGE ( Wort gueltig machen )
; [COMPILE] [ ( in den Execute-Mode uebergehen )
; ; IMMEDIATE
NFA_SEMIS .BYTE $81+$40, 187 ; IMMEDIATE
LFA_SEMIS .WORD NFA_COLON
CFA_SEMIS .WORD DOCOL
PFA_SEMIS
.WORD CFA_QUERYCSP ; ?CSP
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_EXIT ; ;S
.WORD CFA_SMUDGE ; SMUDGE
.WORD CFA_LEFTBRACKET ; [
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> CONSTANT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CONSTANT [ n -> ] definiert eine Konstante. )
;( ========================================================================= )
NFA_CONSTANT .CBYTE $88, "CONSTANT"
LFA_CONSTANT .WORD NFA_SEMIS
CFA_CONSTANT .WORD DOCOL
PFA_CONSTANT
.WORD CFA_CREATE ; CREATE
.WORD CFA_SMUDGE ; SMUDGE
.WORD CFA_COMMA ; ,
.WORD CFA_BRACKETCODE ; (;CODE)
; das neue Wort fuehrt den folgenden Code aus:
DOCON LDY #2
LDA (W),Y ; Lo-Byte des Wertes n im Parameterfeld holen
PHA ; und merken
INY ; Hi-Byte von n anvisieren
LDA (W),Y ; und holen
JMP PUSH ; n auf den Datenstack pushen und fertig
; >>>>>>>>>>>>>>>> VARIABLE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( VARIABLE [ n -> ] definiert und initialisiert eine Variable. )
;( ========================================================================= )
NFA_VARIABLE .CBYTE $88,"VARIABLE"
LFA_VARIABLE .WORD NFA_CONSTANT
CFA_VARIABLE .WORD DOCOL
PFA_VARIABLE
.WORD CFA_CONSTANT ; CONSTANT
.WORD CFA_BRACKETCODE ; (;CODE)
; aber bei Aufruf den folgenden Code ausfuehren:
DOVAR CLC
LDA W ; Lo-Byte der PFA der Variablen ermitteln
ADC #2
PHA ; und merken
TYA
ADC W+1 ; Hi-Byte der PFA ermitteln und merken
JMP PUSH ; PFA auf den Datenstack pushen und fertig
; >>>>>>>>>>>>>>>> USER <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( USER [ n -> ] definiert eine User-Variable mit dem Offset n. )
;( ========================================================================= )
NFA_USER .CBYTE $84, "USER"
LFA_USER .WORD NFA_VARIABLE
CFA_USER .WORD DOCOL
PFA_USER
.WORD CFA_CONSTANT ; CONSTANT
.WORD CFA_BRACKETCODE ; (;CODE)
; aber bei Aufruf den folgenden Code ausfuehren:
DOUSE
LDY #2
CLC
LDA (W),Y ; Lo-Byte des Offsets der Uservariablen
ADC UP ; plus Userpointer ergibt Adresse der Uservariablen
PHA ; merken
LDA #0
ADC UP+1 ; Hi-Byte holen und im Akkumulator merken
JMP PUSH ; gemerkte Adresse auf den Datenstack legen und fertig
NFA_PREV .= NFA_USER
;( ========================================================================= )
;( Definition diverser Konstanten. )
;( ========================================================================= )
; >>>>>>>>>>>>>>>> 0 <<<<<<<<<<<<<<<<
; CONSTANT 0 ( Null )
NFA_0 .CBYTE $81, "0"
LFA_0 .WORD NFA_PREV
CFA_0 .WORD DOCON
PFA_0 .WORD 0
; >>>>>>>>>>>>>>>> 1 <<<<<<<<<<<<<<<<
; CONSTANT 1 ( Eins )
NFA_1 .CBYTE $81, "1"
LFA_1 .WORD NFA_0
CFA_1 .WORD DOCON
PFA_1 .WORD 1
; >>>>>>>>>>>>>>>> 2 <<<<<<<<<<<<<<<<
; CONSTANT 2 ( Zwei )
NFA_2 .CBYTE $81,"2"
LFA_2 .WORD NFA_1
CFA_2 .WORD DOCON
PFA_2 .WORD 2
; >>>>>>>>>>>>>>>> 3 <<<<<<<<<<<<<<<<
; CONSTANT 3 ( Drei )
NFA_3 .CBYTE $81, "3"
LFA_3 .WORD NFA_2
CFA_3 .WORD DOCON
PFA_3 .WORD 3
; >>>>>>>>>>>>>>>> BL <<<<<<<<<<<<<<<<
; CONSTANT BL ( Blank )
NFA_BL .CBYTE $82, "BL"
LFA_BL .WORD NFA_3
CFA_BL .WORD DOCON
PFA_BL .WORD 32
; >>>>>>>>>>>>>>>> ABORTINIT <<<<<<<<<<<<<<<<
; CONSTANT ABORTINIT ( ABORT INIT ADRESSE )
NFA_ABORTINIT .CBYTE $89, "ABORTINIT"
LFA_ABORTINIT .WORD NFA_BL
CFA_ABORTINIT .WORD DOCON
PFA_ABORTINIT .WORD ABORTINIT
NFA_PREV .= NFA_ABORTINIT
.IF debug
;( ========================================================================= )
;( Definition Debug Flag. )
;( ========================================================================= )
; >>>>>>>>>>>>>>>> DEBUGFLAG <<<<<<<<<<<<<<<<
; CONSTANT 0 ( Null )
NFA_DEBUGFLAG .CBYTE $89, "DEBUGFLAG"
LFA_DEBUGFLAG .WORD NFA_PREV
CFA_DEBUGFLAG .WORD DOCON
PFA_DEBUGFLAG .WORD DEBUGFLG
NFA_PREV .= NFA_DEBUGFLAG
; >>>>>>>>>>>>>>>> DEBUGON <<<<<<<<<<<<<<<<
NFA_DEBUGON .CBYTE $87, "DEBUGON"
LFA_DEBUGON .WORD NFA_PREV
CFA_DEBUGON .WORD DOCOL
PFA_DEBUGON
.WORD CFA_CLIT
.BYTE 1 ; 1
.WORD CFA_DEBUGFLAG ; DEBUGFLAG
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
NFA_PREV .= NFA_DEBUGON
; >>>>>>>>>>>>>>>> DEBUGOFF <<<<<<<<<<<<<<<<
NFA_DEBUGOFF .CBYTE $88, "DEBUGOFF"
LFA_DEBUGOFF .WORD NFA_PREV
CFA_DEBUGOFF .WORD DOCOL
PFA_DEBUGOFF
.WORD CFA_CLIT
.BYTE 0 ; 0
.WORD CFA_DEBUGFLAG ; DEBUGFLAG
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
NFA_PREV .= NFA_DEBUGOFF
.ENDIF ; DEBUG
; >>>>>>>>>>>>>>>> +ORIGIN <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( +ORIGIN [ n -> addr ] uebergibt die Adresse Origin+n. Origin ist die )
;( tiefste Adresse im Forth-Kern. )
;( ========================================================================= )
NFA_PLUSORIGIN .CBYTE $87, "+ORIGIN"
LFA_PLUSORIGIN .WORD NFA_PREV
CFA_PLUSORIGIN .WORD DOCOL
PFA_PLUSORIGIN
.WORD CFA_LIT ; LIT
.WORD ORIG
.WORD CFA_PLUS ; +
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> S0 <<<<<<<<<<<<<<<<
; 6 USER S0 ( Initialisierungswert fuer Daten-Stack-Pointer )
NFA_S0 .CBYTE $82, "S0"
LFA_S0 .WORD NFA_PLUSORIGIN
CFA_S0 .WORD DOUSE
PFA_S0 .WORD 6
; >>>>>>>>>>>>>>>> R0 <<<<<<<<<<<<<<<<
; 8 USER R0 ( Initialisierungswert fuer Return-Stack-Pointer )
NFA_R0 .CBYTE $82, "R0"
LFA_R0 .WORD NFA_S0
CFA_R0 .WORD DOUSE
PFA_R0 .WORD 8
; >>>>>>>>>>>>>>>> TIB <<<<<<<<<<<<<<<<
; 10 USER TIB ( Startadresse des Terminal-Input-Buffers )
NFA_TIB .CBYTE $83, "TIB"
LFA_TIB .WORD NFA_R0
CFA_TIB .WORD DOUSE
PFA_TIB .WORD 10
; >>>>>>>>>>>>>>>> WIDTH <<<<<<<<<<<<<<<<
; 12 USER WIDTH ( Maximallaenge von Forth-Namen )
NFA_WIDTH .CBYTE $85, "WIDTH"
LFA_WIDTH .WORD NFA_TIB
CFA_WIDTH .WORD DOUSE
PFA_WIDTH .WORD 12
; >>>>>>>>>>>>>>>> WARNING <<<<<<<<<<<<<<<<
; 14 USER WARNING ( Kontrollvariable fuer Systembotschaften )
NFA_WARNING .CBYTE $87, "WARNING"
LFA_WARNING .WORD NFA_WIDTH
CFA_WARNING .WORD DOUSE
PFA_WARNING .WORD 14
; >>>>>>>>>>>>>>>> FENCE <<<<<<<<<<<<<<<<
; 16 USER FENCE ( unterste Adresse des mit FORGET loeschbaren Bereichs )
NFA_FENCE .CBYTE $85, "FENCE"
LFA_FENCE .WORD NFA_WARNING
CFA_FENCE .WORD DOUSE
PFA_FENCE .WORD 16
; >>>>>>>>>>>>>>>> DP <<<<<<<<<<<<<<<<
; 18 USER DP ( Dictionary Pointer )
NFA_DP .CBYTE $82, "DP"
LFA_DP .WORD NFA_FENCE
CFA_DP .WORD DOUSE
PFA_DP .WORD 18
; >>>>>>>>>>>>>>>> VOC-LINK <<<<<<<<<<<<<<<<
; 20 USER VOC-LINK ( Adresse einer Zelle in der Definition des letzten Vokab. )
NFA_VOCLINK .CBYTE $88, "VOC-LINK"
LFA_VOCLINK .WORD NFA_DP
CFA_VOCLINK .WORD DOUSE
PFA_VOCLINK .WORD 20
; >>>>>>>>>>>>>>>> SOURCE-ID <<<<<<<<<<<<<<<<
; 22 USER SOURCE-ID ( Nummer des geoffneten Kanals )
NFA_SOURCEID .CBYTE $89,"SOURCE-ID"
LFA_SOURCEID .WORD NFA_VOCLINK
CFA_SOURCEID .WORD DOUSE
PFA_SOURCEID .WORD 22
; >>>>>>>>>>>>>>>> IN <<<<<<<<<<<<<<<<
; 24 USER IN ( Byte-Offset im gegenwaertigen Eingabe-Textbuffer )
NFA_IN .CBYTE $82, "IN"
LFA_IN .WORD NFA_SOURCEID
CFA_IN .WORD DOUSE
PFA_IN .WORD 24
; >>>>>>>>>>>>>>>> OUT <<<<<<<<<<<<<<<<
; 26 USER OUT ( Anzahl mittels EMIT ausgegebener Zeichen )
NFA_OUT .CBYTE $83, "OUT"
LFA_OUT .WORD NFA_IN
CFA_OUT .WORD DOUSE
PFA_OUT .WORD 26
; >>>>>>>>>>>>>>>> SCR <<<<<<<<<<<<<<<<
; 28 USER SCR ( Nummer des zuletzt aufgerufenen Screens )
NFA_SCR .CBYTE $83, "SCR"
LFA_SCR .WORD NFA_OUT
CFA_SCR .WORD DOUSE
PFA_SCR .WORD 28
; >>>>>>>>>>>>>>>> OFFSET <<<<<<<<<<<<<<<<
; 30 USER OFFSET ( Block-Offset zum Disk-Drive, auf das zugegriffen wird )
NFA_OFFSET .CBYTE $86, "OFFSET"
LFA_OFFSET .WORD NFA_SCR
CFA_OFFSET .WORD DOUSE
PFA_OFFSET .WORD 30
; >>>>>>>>>>>>>>>> CONTEXT <<<<<<<<<<<<<<<<
; 32 USER CONTEXT ( Pointer zum Context-Vokabular )
NFA_CONTEXT .CBYTE $87, "CONTEXT"
LFA_CONTEXT .WORD NFA_OFFSET
CFA_CONTEXT .WORD DOUSE
PFA_CONTEXT .WORD 32
; >>>>>>>>>>>>>>>> CURRENT <<<<<<<<<<<<<<<<
; 34 USER CURRENT ( Pointer zum Current-Vokabular )
NFA_CURRENT .CBYTE $87,"CURRENT"
LFA_CURRENT .WORD NFA_CONTEXT
CFA_CURRENT .WORD DOUSE
PFA_CURRENT .WORD 34
; >>>>>>>>>>>>>>>> STATE <<<<<<<<<<<<<<<<
; 36 USER STATE ( ungleich Null, wenn System im Compile-Mode )
NFA_STATE .CBYTE $85, "STATE"
LFA_STATE .WORD NFA_CURRENT
CFA_STATE .WORD DOUSE
PFA_STATE .WORD 36
; >>>>>>>>>>>>>>>> BASE <<<<<<<<<<<<<<<<
; 38 USER BASE ( gegenwaertig vereinbarte Zahlenbasis )
NFA_BASE .CBYTE $84, "BASE"
LFA_BASE .WORD NFA_STATE
CFA_BASE .WORD DOUSE
PFA_BASE .WORD 38
; >>>>>>>>>>>>>>>> DPL <<<<<<<<<<<<<<<<
; 40 USER DPL ( Anzahl der Digits rechts vom Dezimalpunkt )
NFA_DPL .CBYTE $83, "DPL"
LFA_DPL .WORD NFA_BASE
CFA_DPL .WORD DOUSE
PFA_DPL .WORD 40
; >>>>>>>>>>>>>>>> FLD <<<<<<<<<<<<<<<<
; 42 USER FLD ( Kontrollvariable fuer formatierte I/O )
NFA_FLD .CBYTE $83, "FLD"
LFA_FLD .WORD NFA_DPL
CFA_FLD .WORD DOUSE
PFA_FLD .WORD 42
; >>>>>>>>>>>>>>>> CSP <<<<<<<<<<<<<<<<
; 44 USER CSP ( gesicherter Stackpointer-Stand )
NFA_CSP .CBYTE $83, "CSP"
LFA_CSP .WORD NFA_FLD
CFA_CSP .WORD DOUSE
PFA_CSP .WORD 44
; >>>>>>>>>>>>>>>> R# <<<<<<<<<<<<<<<<
; 46 USER R# ( Position des Editor-Cursors )
NFA_RNUM .CBYTE $82, "R#"
LFA_RNUM .WORD NFA_CSP
CFA_RNUM .WORD DOUSE
PFA_RNUM .WORD 46
; >>>>>>>>>>>>>>>> HLD <<<<<<<<<<<<<<<<
; 48 USER HLD ( Adresse des letzten Zeichens bei Umwandlung Zahl->String )
NFA_HLD .CBYTE $83, "HLD"
LFA_HLD .WORD NFA_RNUM
CFA_HLD .WORD DOUSE
PFA_HLD .WORD 48
; >>>>>>>>>>>>>>>> 1+ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( 1+ [ n1 -> n2 ] inkrementiert die oberste Zahl auf dem Stack. )
;( ========================================================================= )
;
; : 1+ 1 + ;
NFA_1PLUS .CBYTE $82,"1+"
LFA_1PLUS .WORD NFA_HLD
CFA_1PLUS .WORD DOCOL
PFA_1PLUS
.WORD CFA_1 ; 1
.WORD CFA_PLUS ; +
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> 2+ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( 2+ [ n1 -> n2 ] inkrementiert die oberste Zahl auf dem Stack um 2. )
;( ========================================================================= )
;
; : 2+ 2 + ;
NFA_2PLUS .CBYTE $82,"2+"
LFA_2PLUS .WORD NFA_1PLUS
CFA_2PLUS .WORD DOCOL
PFA_2PLUS
.WORD CFA_2 ; 2
.WORD CFA_PLUS ; +
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> HERE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( HERE [ -> addr ] uebergibt die Adresse der ersten freien Stelle im )
;( Dictionary. )
;( ========================================================================= )
;
; : HERE DP @ ; ( Adresse, auf die der Dictionary Pointer zeigt, zurueckgeben )
NFA_HERE .CBYTE $84,"HERE"
LFA_HERE .WORD NFA_2PLUS
CFA_HERE .WORD DOCOL
PFA_HERE
.WORD CFA_DP ; DP
.WORD CFA_FETCH ; @
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ALLOT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ALLOT [ n -> ] vergroessert das Dictionary um n Bytes. Hierbei ist n eine )
;( vorzeichenbehaftete Zahl, kann also auch negativ sein. )
;( ========================================================================= )
;
; : ALLOT DP +! ; ( Dictionary-Pointer um n inkrementieren )
NFA_ALLOT .CBYTE $85,"ALLOT"
LFA_ALLOT .WORD NFA_HERE
CFA_ALLOT .WORD DOCOL
PFA_ALLOT
.WORD CFA_DP ; DP
.WORD CFA_PLUSSTORE ; +!
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> , <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( , [ n -> ] fuegt die Zahl n an das Dictionary an. )
;( ========================================================================= )
;
; : , HERE ! 2 ALLOT ; ( n hinter das Dictionary schreiben und DP erhoehen )
NFA_COMMA .CBYTE $81,","
LFA_COMMA .WORD NFA_ALLOT
CFA_COMMA .WORD DOCOL
PFA_COMMA
.WORD CFA_HERE ; HERE
.WORD CFA_STORE ; !
.WORD CFA_2 ; 2
.WORD CFA_ALLOT ; ALLOT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> C, <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( C, [ b -> ] fuegt das Byte b an das Dictionary an. )
;( ========================================================================= )
;
; : C, HERE C! 1 ALLOT ; ( b hinter das Dictionary schreiben und DP erhoehen )
NFA_CCOMMA .CBYTE $82,"C,"
LFA_CCOMMA .WORD NFA_COMMA
CFA_CCOMMA .WORD DOCOL
PFA_CCOMMA
.WORD CFA_HERE ; HERE
.WORD CFA_CSTORE ; C!
.WORD CFA_1 ; 1
.WORD CFA_ALLOT ; ALLOT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> - <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( - [ n1 n2 -> n3 ] berechnet die Differenz n1-n2. )
;( ========================================================================= )
;
; : - MINUS + ; ( n2 negieren und auf n1 aufaddieren )
NFA_MINUS .CBYTE $81,"-"
LFA_MINUS .WORD NFA_CCOMMA
CFA_MINUS .WORD DOCOL
PFA_MINUS
.WORD CFA_NEGATE ; MINUS
.WORD CFA_PLUS ; +
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> = <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( = [ n1 n2 -> f ] vergleicht die Zahlen n1 und n2 und gibt true zurueck, )
;( wenn sie gleich sind, sonst false. )
;( ========================================================================= )
;
; : = - 0= ; ( Differenz von n1 und n2 auf Gleichheit mit 0 testen )
NFA_EQUAL .CBYTE $81,"="
LFA_EQUAL .WORD NFA_MINUS
CFA_EQUAL .WORD DOCOL
PFA_EQUAL
.WORD CFA_MINUS ; -
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> U< <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( U< [ u1 u2 -> f ] liefert f=true, wenn u1<u2 ist, wobei u1 und u2 als )
;( vorzeichenlose Zahlen aufgefasst werden. )
;( ========================================================================= )
;
; : U< - 0< ; ( vergleichen durch Subtraktion )
NFA_ULT .CBYTE $82,"U<"
LFA_ULT .WORD NFA_EQUAL
CFA_ULT .WORD DOCOL
PFA_ULT
.WORD CFA_MINUS ; -
.WORD CFA_LTNULL ; 0<
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> < <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( < [ n1 n2 -> f ] liefert f=true, wenn n1<n2 ist. )
;( ========================================================================= )
NFA_LT .CBYTE $81,"<"
LFA_LT .WORD NFA_ULT
CFA_LT .WORD PFA_LT
PFA_LT
SEC
LDA 2,X ; Testsubtraktion n1-n2 durchfuehren
SBC 0,X
LDA 3,X
SBC 1,X
STY 3,X ; Hi-Byte von f auf Null setzen (Y=0)
BVC L1258 ; kein Ueberlauf, dann verzweigen
EOR #$80 ; sonst Vorzeichenbit der Differenz umdrehen
L1258 BPL L1260 ; Differenz positiv, dann verzweigen (Y=0)
INY ; sonst true-Flag vorbereiten
L1260 STY 2,X ; ermitteltes Flag in den Datenstack schreiben
JMP POP ; n2 vom Stack entfernen und fertig
; >>>>>>>>>>>>>>>> > <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( > [ n1 n2 -> f ] liefert f=true, wenn n1>n2 ist. )
;( ========================================================================= )
;
; : > SWAP < ; ( n1>n2 gdw n2<n1 )
NFA_GT .CBYTE $81,">"
LFA_GT .WORD NFA_LT
CFA_GT .WORD DOCOL
PFA_GT
.WORD CFA_SWAP ; SWAP
.WORD CFA_LT ; <
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ROT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ROT [ n1 n2 n3 -> n2 n3 n1 ] rotiert die drei obersten Stackelemente. )
;( ========================================================================= )
;
; : ROT >R SWAP R> SWAP ; ( n1 mit Hilfe des Returnstacks nach vorne holen )
NFA_ROT .CBYTE $83,"ROT"
LFA_ROT .WORD NFA_GT
CFA_ROT .WORD DOCOL
PFA_ROT
.WORD CFA_RPUSH ; >R
.WORD CFA_SWAP ; SWAP
.WORD CFA_RPOP ; R>
.WORD CFA_SWAP ; SWAP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> SPACE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SPACE [ ] sendet ein ASCII-Space zum Ausgabegeraet. )
;( ========================================================================= )
;
; : SPACE BL EMIT ;
NFA_SPACE .CBYTE $85,"SPACE"
LFA_SPACE .WORD NFA_ROT
CFA_SPACE .WORD DOCOL
PFA_SPACE
.WORD CFA_BL ; BL
.WORD CFA_EMIT ; EMIT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> -DUP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( -DUP [ n1 -> n1 ] falls n1=0, [ n1 -> n1 n1 ] sonst. Dupliziert den TOS, )
;( wenn er ungleich Null ist. )
;( ========================================================================= )
;
; : -DUP DUP IF DUP ENDIF ;
NFA_MINUSDUP .CBYTE $84,"-DUP"
LFA_MINUSDUP .WORD NFA_SPACE
CFA_MINUSDUP .WORD DOCOL
PFA_MINUSDUP
.WORD CFA_DUP ; DUP
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL1-*
.WORD CFA_DUP ; DUP
LBL1
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> TRAVERSE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( TRAVERSE [ addr1 n -> addr2 ] gibt mit addr2 die Adresse des jeweils )
;( anderen Ende eines Namens an, Laengenbyte inklusive. Ist n=1, so wird )
;( aufsteigend gesucht, ist n=-1, so wird absteigend gesucht. )
;( ========================================================================= )
;
; : TRAVERSE
; SWAP
; BEGIN OVER + 127 OVER C@ < UNTIL ( solange suchen bis Byte>127 )
; SWAP DROP
; ;
NFA_TRAVERSE .CBYTE $88,"TRAVERSE"
LFA_TRAVERSE .WORD NFA_MINUSDUP
CFA_TRAVERSE .WORD DOCOL
PFA_TRAVERSE
.WORD CFA_SWAP ; SWAP
LBL2
.WORD CFA_OVER ; OVER
.WORD CFA_PLUS ; +
.WORD CFA_CLIT ; CLIT
.BYTE 127
.WORD CFA_OVER ; OVER
.WORD CFA_CFETCH ; C@
.WORD CFA_LT ; <
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL2-*
.WORD CFA_SWAP ; SWAP
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> LATEST <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( LATEST [ -> addr ] uebergibt die NFA des zuletzt im Current-Vokabular )
;( definierten Wortes. )
;( ========================================================================= )
;
; : LATEST CURRENT @ @ ;
NFA_LATEST .CBYTE $86,"LATEST"
LFA_LATEST .WORD NFA_TRAVERSE
CFA_LATEST .WORD DOCOL
PFA_LATEST
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_FETCH ; @
.WORD CFA_FETCH ; @
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> LFA <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( LFA [ pfa -> lfa ] wandelt die PFA eines Wortes in die entsprechende LFA )
;( um. )
;( ========================================================================= )
;
; : LFA 4 - ;
NFA_LFA .CBYTE $83,"LFA"
LFA_LFA .WORD NFA_LATEST
CFA_LFA .WORD DOCOL
PFA_LFA
.WORD CFA_CLIT ; CLIT
.BYTE 4
.WORD CFA_MINUS ; -
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> CFA <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CFA [ pfa -> cfa ] wandelt die PFA eines Wortes in die entsprechende CFA )
;( um. )
;( ========================================================================= )
;
; : CFA 2 - ;
NFA_CFA .CBYTE $83,"CFA"
LFA_CFA .WORD NFA_LFA
CFA_CFA .WORD DOCOL
PFA_CFA
.WORD CFA_2 ; 2
.WORD CFA_MINUS ; -
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> NFA <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( NFA [ pfa -> nfa ] wandelt die PFA eines Wortes in die entsprechende NFA )
;( um. )
;( ========================================================================= )
;
; : NFA 5 - -1 TRAVERSE ;
NFA_NFA .CBYTE $83,"NFA"
LFA_NFA .WORD NFA_CFA
CFA_NFA .WORD DOCOL
PFA_NFA
.WORD CFA_CLIT ; CLIT
.BYTE 5
.WORD CFA_MINUS ; -
.WORD CFA_LIT ; LIT
.WORD -1
.WORD CFA_TRAVERSE ; TRAVERSE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> PFA <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( PFA [ nfa -> pfa ] wandelt die NFA eines Wortes in die entsprechende PFA )
;( um. )
;( ========================================================================= )
;
; : PFA 1 TRAVERSE 5 + ;
NFA_PFA .CBYTE $83,"PFA"
LFA_PFA .WORD NFA_NFA
CFA_PFA .WORD DOCOL
PFA_PFA
.WORD CFA_1 ; 1
.WORD CFA_TRAVERSE ; TRAVERSE
.WORD CFA_CLIT ; CLIT
.BYTE 5
.WORD CFA_PLUS ; +
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> !CSP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( !CSP [ ] rettet die aktuelle Stackpointer-Position in die User-Variable )
;( CSP. )
;( ========================================================================= )
;
; : !CSP SP@ CSP ! ;
NFA_STORECSP .CBYTE $84,"!CSP"
LFA_STORECSP .WORD NFA_PFA
CFA_STORECSP .WORD DOCOL
PFA_STORECSP
.WORD CFA_SPFETCH ; SP@
.WORD CFA_CSP ; CSP
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?ERROR <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?ERROR [ f n -> ] gibt die Fehlermeldung Nummer n aus, wenn f=true ist. )
;( ========================================================================= )
;
; : ?ERROR SWAP IF ERROR ELSE DROP ENDIF ;
NFA_QUERYERROR .CBYTE $86,"?ERROR"
LFA_QUERYERROR .WORD NFA_STORECSP
CFA_QUERYERROR .WORD DOCOL
PFA_QUERYERROR
.WORD CFA_SWAP ; SWAP
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL3-*
.WORD CFA_ERROR ; ERROR
.WORD CFA_BRANCH ; BRANCH
.WORD LBL4-*
LBL3
.WORD CFA_DROP ; DROP
LBL4
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?COMP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?COMP [ ] gibt eine entsprechende Fehlermeldung aus, wenn sich das System )
;( nicht im Compile-Mode befindet. )
;( ========================================================================= )
;
; : ?COMP STATE @ 0= 17 ?ERROR ;
NFA_QUERYCOMP .CBYTE $85,"?COMP"
LFA_QUERYCOMP .WORD NFA_QUERYERROR
CFA_QUERYCOMP .WORD DOCOL
PFA_QUERYCOMP
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_CLIT ; CLIT
.BYTE 17
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?EXEC <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?EXEC [ ] gibt eine entsprechende Fehlermeldung aus, wenn sich das System )
;( nicht im Execute-Mode befindet. )
;( ========================================================================= )
;
; : ?EXEC STATE @ 18 ?ERROR ;
NFA_QUERYEXEC .CBYTE $85,"?EXEC"
LFA_QUERYEXEC .WORD NFA_QUERYCOMP
CFA_QUERYEXEC .WORD DOCOL
PFA_QUERYEXEC
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_CLIT ; CLIT
.BYTE 18
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?PAIRS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?PAIRS [ n1 n2 -> ] gibt eine entsprechende Fehlermeldung aus, wenn n1 )
;( und n2 ungleich sind. Das Wort wird waehrend der Kompilation benutzt, um )
;( festzustellen, ob zwei strukturierte Sprachelemente zusammengehoeren. )
;( ========================================================================= )
;
; : ?PAIRS - 19 ?ERROR ;
NFA_QUERYPAIRS .CBYTE $86,"?PAIRS"
LFA_QUERYPAIRS .WORD NFA_QUERYEXEC
CFA_QUERYPAIRS .WORD DOCOL
PFA_QUERYPAIRS
.WORD CFA_MINUS ; -
.WORD CFA_CLIT ; CLIT
.BYTE 19
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?CSP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?CSP [ ] gibt eine entsprechende Fehlermeldung aus, wenn die aktuelle )
;( Stack-Position von der in der User-Variablen CSP geretteten abweicht. )
;( ========================================================================= )
;
; : ?CSP SP@ CSP @ - 20 ?ERROR ;
NFA_QUERYCSP .CBYTE $84,"?CSP"
LFA_QUERYCSP .WORD NFA_QUERYPAIRS
CFA_QUERYCSP .WORD DOCOL
PFA_QUERYCSP
.WORD CFA_SPFETCH ; SP@
.WORD CFA_CSP ; CSP
.WORD CFA_FETCH ; @
.WORD CFA_MINUS ; -
.WORD CFA_CLIT ; CLIT
.BYTE 20
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?LOADING <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?LOADING [ ] gibt eine entsprechende Fehlermeldung aus, falls nicht )
;( geladen wird. )
;( ========================================================================= )
;
; : ?LOADING SOURCE-ID @ 0= 22 ?ERROR ;
NFA_QUERYLOADING .CBYTE $88,"?LOADING"
LFA_QUERYLOADING .WORD NFA_QUERYCSP
CFA_QUERYLOADING .WORD DOCOL
PFA_QUERYLOADING
.WORD CFA_SOURCEID ; SOURCE-ID
.WORD CFA_FETCH ; @
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_CLIT ; CLIT
.BYTE 22
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> COMPILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( COMPILE [ ] kompiliert das inline folgende Wort in das Dictionary. )
;( ========================================================================= )
;
; : COMPILE
; ?COMP ( nur im Compile-Mode erlaubt )
; R> ( Fortsetzungsadresse holen )
; DUP 2+ >R ( inline folgendes Wort in der Ausfuehrung ueberspringen )
; @ , ( inline folgendes Wort an das Dictionary anfuegen )
; ;
NFA_COMPILE .CBYTE $87,"COMPILE"
LFA_COMPILE .WORD NFA_QUERYLOADING
CFA_COMPILE .WORD DOCOL
PFA_COMPILE
.WORD CFA_QUERYCOMP ; ?COMP
.WORD CFA_RPOP ; R>
.WORD CFA_DUP ; DUP
.WORD CFA_2PLUS ; 2+
.WORD CFA_RPUSH ; >R
.WORD CFA_FETCH ; @
.WORD CFA_COMMA ; ,
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> [ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [ [ ] schaltet in den Execute-Mode um. )
;( ========================================================================= )
;
; : [ 0 STATE ! ; IMMEDIATE
NFA_LEFTBRACKET .CBYTE $81+$40, "[" ; IMMEDIATE
LFA_LEFTBRACKET .WORD NFA_COMPILE
CFA_LEFTBRACKET .WORD DOCOL
PFA_LEFTBRACKET
.WORD CFA_0 ; 0
.WORD CFA_STATE ; STATE
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ] <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ] [ ] schaltet in den Compile-Mode um. )
;( ========================================================================= )
;
; : ] 192 STATE ! ;
NFA_RIGHTBRACKET .CBYTE $81,"]"
LFA_RIGHTBRACKET .WORD NFA_LEFTBRACKET
CFA_RIGHTBRACKET .WORD DOCOL
PFA_RIGHTBRACKET
.WORD CFA_CLIT ; CLIT
.BYTE 192
.WORD CFA_STATE ; STATE
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> SMUDGE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SMUDGE [ ] dreht das SMUDGE-Bit im Header des zuletzt definierten Wortes )
;( um, d.h. macht das Wort gueltig, wenn es vorher ungueltig war, und )
;( umgekehrt. )
;( ========================================================================= )
;
; : SMUDGE LATEST 32 TOGGLE ;
NFA_SMUDGE .CBYTE $86,"SMUDGE"
LFA_SMUDGE .WORD NFA_RIGHTBRACKET
CFA_SMUDGE .WORD DOCOL
PFA_SMUDGE
.WORD CFA_LATEST ; LATEST
.WORD CFA_CLIT ; CLIT
.BYTE 32
.WORD CFA_TOGGLE ; TOGGLE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> HEX <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( HEX [ ] setzt die I/O-Zahlenbasis auf 16. )
;( ========================================================================= )
;
; : HEX 16 BASE ! ;
NFA_HEX .CBYTE $83,"HEX"
LFA_HEX .WORD NFA_SMUDGE
CFA_HEX .WORD DOCOL
PFA_HEX
.WORD CFA_CLIT ; CLIT
.BYTE 16
.WORD CFA_BASE ; BASE
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> DECIMAL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DECIMAL [ ] setzt die I/O-Zahlenbasis auf 10. )
;( ========================================================================= )
;
; : DECIMAL 10 BASE ! ;
NFA_DECIMAL .CBYTE $87,"DECIMAL"
LFA_DECIMAL .WORD NFA_HEX
CFA_DECIMAL .WORD DOCOL
PFA_DECIMAL
.WORD CFA_CLIT ; CLIT
.BYTE 10
.WORD CFA_BASE ; BASE
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> (;CODE) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [;CODE] [ ] ueberschreibt das Codefeld des soeben definierten Wortes mit )
;( der unmittelbar auf [;CODE] folgenden Adresse und kehrt zum aufrufenden )
;( Wort zurueck. )
;( ========================================================================= )
;
; : (;CODE) R> LATEST PFA CFA ! ;
NFA_BRACKETCODE .CBYTE $87,"(;CODE)"
LFA_BRACKETCODE .WORD NFA_DECIMAL
CFA_BRACKETCODE .WORD DOCOL
PFA_BRACKETCODE
.WORD CFA_RPOP ; R>
.WORD CFA_LATEST ; LATEST
.WORD CFA_PFA ; PFA
.WORD CFA_CFA ; CFA
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ;CODE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ;CODE [ ] beendet die Colon-Definition eines Definitionswortes und )
;( beginnt die Spezifikationsphase des Assemblerteiles. )
;( ========================================================================= )
;
; : ;CODE
; ?CSP ( Stackpointer-Position ueberpruefen )
; COMPILE (;CODE) ( [;CODE] kompilieren )
; [COMPILE] [ ( in den Execute-Mode umschalten )
; SMUDGE ( soeben definiertes Wort gueltig machen )
; ; IMMEDIATE
NFA_CODE .CBYTE $85+$40,";CODE" ; IMMEDIATE
LFA_CODE .WORD NFA_BRACKETCODE
CFA_CODE .WORD DOCOL
PFA_CODE
.WORD CFA_QUERYCSP ; ?CSP
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRACKETCODE ; (;CODE)
.WORD CFA_LEFTBRACKET ; [
.WORD CFA_SMUDGE ; SMUDGE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> <BUILDS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( <BUILDS [ ] beginnt die Definitionsphase eines High-Level-Definitions- )
;( wortes. )
;( ========================================================================= )
;
; : <BUILDS 0 CONSTANT ; ( provisorischen Konstanten-Header aufbauen )
NFA_BUILDS .CBYTE $87,"<BUILDS"
LFA_BUILDS .WORD NFA_CODE
CFA_BUILDS .WORD DOCOL
PFA_BUILDS
.WORD CFA_0 ; 0
.WORD CFA_CONSTANT ; CONSTANT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> DOES> <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DOES> [ ] beendet die Definitionsphase eines High-Level-Definitionswortes )
;( und leitet die Definitionsphase des entsprechenden Ausfuehrungsteils ein. )
;( ========================================================================= )
;
; : DOES>
; R> ( Adresse des auf DOES> folgenden High-Level-Codes )
; LATEST PFA ! ( in das Parameterfeld des soeben def. Wortes schreiben )
; ;CODE ; das neue Wort fuehrt den folgenden Code aus:
; DODOE LDA IP+1 ; Instruction-Pointer IP auf den Returnstack pushen
; PHA
; LDA IP
; PHA
; LDY #2
; LDA (W),Y ; IP mit der Adresse laden, die als erstes im
; STA IP ; Parameterfeld des Wortes abgelegt ist.
; INY ; Dies ist die Adresse unmittelbar hinter dem DOES>
; LDA (W),Y ; des definierenden Wortes.
; STA IP+1
; CLC
; LDA W ; Adresse des zweiten Eintrags im Parameterfeld des
; ADC #4 ; Wortes holen
; PHA
; LDA W+1
; ADC #0
; JMP PUSH ; auf den Datenstack legen und fertig
; END-CODE
NFA_DOES .CBYTE $85,"DOES>"
LFA_DOES .WORD NFA_BUILDS
CFA_DOES .WORD DOCOL
PFA_DOES
.WORD CFA_RPOP ; R>
.WORD CFA_LATEST ; LATEST
.WORD CFA_PFA ; PFA
.WORD CFA_STORE ; !
.WORD CFA_BRACKETCODE ; (;CODE)
; das neue Wort fuehrt den folgenden Code aus:
DODOE LDA IP+1 ; Instruction-Pointer IP auf den Returnstack pushen
PHA
LDA IP
PHA
LDY #2
LDA (W),Y ; IP mit der Adresse laden, die als erstes im
STA IP ; Parameterfeld des Wortes abgelegt ist.
INY ; Dies ist die Adresse unmittelbar hinter dem DOES>
LDA (W),Y ; des definierenden Wortes.
STA IP+1
CLC
LDA W ; Adresse des zweiten Eintrags im Parameterfeld des
ADC #4 ; Wortes holen
PHA
LDA W+1
ADC #0
JMP PUSH ; auf den Datenstack legen und fertig
; >>>>>>>>>>>>>>>> COUNT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( COUNT [ addr1 -> addr2 n ] ermittelt zum String, auf dessen Count-Byte )
;( addr1 zeigt, die eigentliche Startadresse addr2 und die Anzahl n der )
;( Zeichen. )
;( ========================================================================= )
;
; : COUNT DUP 1+ SWAP C@ ; ( addr2=addr1+1 und n=[addr1] )
NFA_COUNT .CBYTE $85,"COUNT"
LFA_COUNT .WORD NFA_DOES
CFA_COUNT .WORD DOCOL
PFA_COUNT
.WORD CFA_DUP ; DUP
.WORD CFA_1PLUS ; 1+
.WORD CFA_SWAP ; SWAP
.WORD CFA_CFETCH ; C@
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> TYPE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( TYPE [ addr count -> ] gibt den aus count Zeichen bestehenden String, )
;( beginnend ab Adresse addr, auf die Standardausgabe aus. )
;( ========================================================================= )
;
; : TYPE
; -DUP IF ( falls count<>0, d.h. falls Zeichen auszugeben sind: )
; OVER + SWAP DO ( fuer alle I von addr bis addr+count-1: )
; I C@ EMIT ( Zeichen in Adresse I ausgeben )
; LOOP
; ELSE ( falls count=0: )
; DROP ( nichts ausgeben, addr vom Stack nehmen )
; ENDIF
; ;
NFA_TYPE .CBYTE $84,"TYPE"
LFA_TYPE .WORD NFA_COUNT
CFA_TYPE .WORD DOCOL
PFA_TYPE
.WORD CFA_MINUSDUP ; -DUP
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL5-*
.WORD CFA_OVER ; OVER
.WORD CFA_PLUS ; +
.WORD CFA_SWAP ; SWAP
.WORD CFA_BRACKETDO ; (DO)
LBL6
.WORD CFA_I ; I
.WORD CFA_CFETCH ; C@
.WORD CFA_EMIT ; EMIT
.WORD CFA_BRACKETLOOP ; (LOOP)
.WORD LBL6-*
.WORD CFA_BRANCH ; BRANCH
.WORD LBL7-*
LBL5
.WORD CFA_DROP ; DROP
LBL7
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> -TRAILING <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( -TRAILING [ addr n1 -> addr n2 ] verkuerzt den durch addr und n1 bezeich- )
;( neten String um Blanks am Textende, d.h. die Zeichen in addr+n2 bis )
;( addr+n1-1 sind Blanks. )
;( ========================================================================= )
;
; : -TRAILING
; DUP 0 DO ( wiederhole die folgende Schleife maximal n1-mal )
; OVER OVER + 1 - C@ ( Zeichen an der Adresse addr+n-1 )
; BL - IF ( falls es kein Blank ist: )
; LEAVE ( Suche beenden )
; ELSE ( sonst: )
; 1 - ( n dekrementieren )
; ENDIF
; LOOP
; ;
NFA_MINUSTRAILING .CBYTE $89,"-TRAILING"
LFA_MINUSTRAILING .WORD NFA_TYPE
CFA_MINUSTRAILING .WORD DOCOL
PFA_MINUSTRAILING
.WORD CFA_DUP ; DUP
.WORD CFA_0 ; 0
.WORD CFA_BRACKETDO ; (DO)
LBL8
.WORD CFA_OVER ; OVER
.WORD CFA_OVER ; OVER
.WORD CFA_PLUS ; +
.WORD CFA_1 ; 1
.WORD CFA_MINUS ; -
.WORD CFA_CFETCH ; C@
.WORD CFA_BL ; BL
.WORD CFA_MINUS ; -
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL9-*
.WORD CFA_LEAVE ; LEAVE
.WORD CFA_BRANCH ; BRANCH
.WORD LBL10-*
LBL9
.WORD CFA_1 ; 1
.WORD CFA_MINUS ; -
LBL10
.WORD CFA_BRACKETLOOP ; (LOOP)
.WORD LBL8-*
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> (.") <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [."] [ ] gibt den inline folgenden String auf die Standardausgabe aus. )
;( ========================================================================= )
;
; : (.")
; R COUNT ( Adresse und Laenge des inline folgenden Strings )
; DUP 1+ R> + >R ( Returnadresse um die Gesamtlaenge des Strings erhoehen )
; TYPE ( String auf die Standardausgabe ausgeben )
; ;
NFA_BRAKETDOTQUOTE .CBYTE $84,"(.",34,")"
LFA_BRAKETDOTQUOTE .WORD NFA_MINUSTRAILING
CFA_BRAKETDOTQUOTE .WORD DOCOL
PFA_BRAKETDOTQUOTE
.WORD CFA_R ; R
.WORD CFA_COUNT ; COUNT
.WORD CFA_DUP ; DUP
.WORD CFA_1PLUS ; 1+
.WORD CFA_RPOP ; R>
.WORD CFA_PLUS ; +
.WORD CFA_RPUSH ; >R
.WORD CFA_TYPE ; TYPE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ." <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ." [ ] gibt den im Eingabestrom folgenden String auf die Standardausgabe )
;( aus. Im Compile-Mode werden [."] und der String kompiliert. )
;( ========================================================================= )
;
; : ."
; 34 ( Zeichen '"' )
; STATE @ IF ( falls Compile-Mode: )
; COMPILE (.") ( [."] kompilieren )
; WORD ( folgenden String kompilieren )
; HERE C@ 1+ ALLOT ( Dictionary-Pointer entsprechend erhoehen )
; ELSE ( falls Execute-Mode: )
; WORD ( folgenden String holen )
; HERE COUNT TYPE ( und auf die Standardausgabe ausgeben )
; ENDIF
; ; IMMEDIATE
NFA_DOTQUOTE .BYTE $C2,".",$A2
LFA_DOTQUOTE .WORD NFA_BRAKETDOTQUOTE
CFA_DOTQUOTE .WORD DOCOL
PFA_DOTQUOTE
.WORD CFA_CLIT ; CLIT
.BYTE 34
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL11-*
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRAKETDOTQUOTE ; (.")
.WORD CFA_WORD ; WORD
.WORD CFA_CFETCH ; C@
.WORD CFA_1PLUS ; 1+
.WORD CFA_ALLOT ; ALLOT
.WORD CFA_BRANCH ; BRANCH
.WORD LBL12-*
LBL11
.WORD CFA_WORD ; WORD
.WORD CFA_COUNT ; COUNT
.WORD CFA_TYPE ; TYPE
LBL12
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> EXPECT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( EXPECT [ addr count -> ] holt bis zu count Zeichen vom Keyboard - wenn )
;( nicht vorher CR eingegeben wird - und legt sie ab Adresse addr ab, durch )
;( ein oder mehrere Null-Bytes abgeschlossen. )
;( ========================================================================= )
;
; : EXPECT
; OVER + OVER DO ( fuer I von addr bis addr+count-1 tue: )
; KEY ( Taste holen )
; DUP 126 +ORIGIN @ = IF ( falls externes Backspace: )
; DROP 8 ( Taste durch internes Backspace ersetzen )
; OVER I = ( 1 falls am linken Anschlag, sonst 0 )
; DUP R> 2 - + >R ( I um 1 [falls Anfang] oder 2 dekrementieren )
; - ( ASCII 8 [BS] oder ASCII 7 [BEL] zuruecklassen )
; ELSE ( falls kein externes Backspace: )
; DUP 155 = IF ( falls CR: )
; LEAVE DROP BL 0 ( Eingabe beenden, Blank ausgeben, 0 speichern )
; ELSE ( falls kein CR: )
; DUP ( Zeichen ausgeben und speichern )
; ENDIF
; I C! ( eingegebenes Zeichen speichern )
; 0 I 1+ ! ( 0 in der darauffolgenden Zelle speichern )
; ENDIF
; EMIT ( eingegebenes Zeichen ausgeben )
; LOOP
; DROP ( Adresse addr vergessen )
; ;
NFA_EXPECT .CBYTE $86,"EXPECT"
LFA_EXPECT .WORD NFA_DOTQUOTE
CFA_EXPECT .WORD DOCOL
PFA_EXPECT
.WORD CFA_OVER ; OVER
.WORD CFA_PLUS ; +
.WORD CFA_OVER ; OVER
.WORD CFA_BRACKETDO ; (DO)
LBL13
.WORD CFA_KEY ; KEY
.WORD CFA_DUP ; DUP
.WORD CFA_CLIT ; CLIT
.BYTE $0E
.WORD CFA_PLUSORIGIN ; +ORIGIN
.WORD CFA_FETCH ; @
.WORD CFA_EQUAL ; =
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL14-*
.WORD CFA_DROP ; DROP
.WORD CFA_CLIT ; CLIT
.BYTE 126
.WORD CFA_OVER ; OVER
.WORD CFA_I ; I
.WORD CFA_EQUAL ; =
.WORD CFA_DUP ; DUP
.WORD CFA_RPOP ; R>
.WORD CFA_2 ; 2
.WORD CFA_MINUS ; -
.WORD CFA_PLUS ; +
.WORD CFA_RPUSH ; >R
.WORD CFA_MINUS ; -
.WORD CFA_BRANCH ; BRANCH
.WORD LBL15-*
LBL14
.WORD CFA_DUP ; DUP
.WORD CFA_CLIT ; CLIT
.BYTE 155
.WORD CFA_EQUAL ; =
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL16-*
.WORD CFA_LEAVE ; LEAVE
.WORD CFA_DROP ; DROP
.WORD CFA_BL ; BL
.WORD CFA_0 ; 0
.WORD CFA_BRANCH ; BRANCH
.WORD LBL17-*
LBL16
.WORD CFA_DUP ; DUP
LBL17
.WORD CFA_I ; I
.WORD CFA_CSTORE ; C!
.WORD CFA_0 ; 0
.WORD CFA_I ; I
.WORD CFA_1PLUS ; 1+
.WORD CFA_STORE ; !
LBL15
.WORD CFA_EMIT ; EMIT
.WORD CFA_BRACKETLOOP ; (LOOP)
.WORD LBL13-*
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> QUERY <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( QUERY [ ] holt bis zu 80 Zeichen - wenn nicht vorher CR eingegeben wird - )
;( vom Terminal und legt sie im Terminal-Input-Buffer TIB ab. Ausserdem wird )
;( die User-Variable IN auf 0 gesetzt. )
;( ========================================================================= )
;
; : QUERY
; TIB @ 80 EXPECT ( bis zu 80 Zeichen in den Terminal-Input-Buffer einlesen )
; 0 IN ! ( Interpretation beginnt beim Offset 0 )
; ;
NFA_QUERY .CBYTE $85,"QUERY"
LFA_QUERY .WORD NFA_EXPECT
CFA_QUERY .WORD DOCOL
PFA_QUERY
.WORD CFA_TIB ; TIB
.WORD CFA_FETCH ; @
.WORD CFA_CLIT ; CLIT
.BYTE 80
.WORD CFA_EXPECT ; EXPECT
.WORD CFA_0 ; 0
.WORD CFA_IN ; IN
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> X <<<<<<<<<<<<<<<<
; ( ========================================================================= )
; ( X [ ] bricht die Interpretation einer Zeile Text bedingungslos ab. X ist )
; ( ein Pseudonym fuer den Namen, der nur aus dem ASCII-0-Zeichen besteht. )
; ( ========================================================================= )
;
; ( 32897 HERE ) ( hex 8081 und aktuelle Adresse merken )
;
; : X
; SOURCE-ID @ IF ( falls von Disk geladen wird: )
; 1 BLK +! ( naechsten Block interpretieren )
; 0 IN ! ( beginnend beim Offset 0 )
; BLK @ 0 B/SCR U/ DROP 0= IF ( falls Screen-Ende erreicht wurde: )
; ?EXEC R> DROP ( Interpretation ganz abbrechen )
; ENDIF
; ELSE ( falls nicht von Disk geladen wird: )
; R> DROP ( Interpretation ganz abbrechen )
; ENDIF
; ; IMMEDIATE
NFA_X .BYTE $C1, $80
LFA_X .WORD NFA_QUERY
CFA_X .WORD DOCOL
PFA_X
;.WORD CFA_BLK ; BLK
;.WORD CFA_FETCH ; @
;.WORD CFA_0BRANCH ; 0BRANCH
;.WORD LBL18-*
;.WORD CFA_1 ; 1
;.WORD CFA_BLK ; BLK
;.WORD CFA_PLUSSTORE ; +!
;.WORD CFA_0 ; 0
;.WORD CFA_IN ; IN
;.WORD CFA_STORE ; !
;.WORD CFA_BLK ; BLK
;.WORD CFA_FETCH ; @
;.WORD CFA_0 ; 0
;.WORD CFA_BSCR ; B/SCR
;.WORD CFA_UDIV ; U/
;.WORD CFA_DROP ; DROP
;.WORD CFA_NULLEQUAL ; 0=
;.WORD CFA_0BRANCH ; 0BRANCH
;.WORD LBL19-*
;.WORD CFA_QUERYEXEC ; ?EXEC
;.WORD CFA_RPOP ; R>
;.WORD CFA_DROP ; DROP
;LBL19
;.WORD CFA_BRANCH ; BRANCH
;.WORD LBL20-*
LBL18
.WORD CFA_RPOP ; R>
.WORD CFA_DROP ; DROP
LBL20
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> FILL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( FILL [ addr n b -> ] fuellt n Bytes ab Adresse addr mit dem Wert b. )
;( ========================================================================= )
;
; : FILL
; SWAP >R OVER C! ( Byte b in Adresse addr speichern )
; DUP 1+ R> 1 - CMOVE ( n-1 Bytes aufsteigend von addr nach addr+1 kopieren )
; ;
NFA_FILL .CBYTE $84,"FILL"
LFA_FILL .WORD NFA_X
CFA_FILL .WORD DOCOL
PFA_FILL
.WORD CFA_SWAP ; SWAP
.WORD CFA_RPUSH ; >R
.WORD CFA_OVER ; OVER
.WORD CFA_CSTORE ; C!
.WORD CFA_DUP ; DUP
.WORD CFA_1PLUS ; 1+
.WORD CFA_RPOP ; R>
.WORD CFA_1 ; 1
.WORD CFA_MINUS ; -
.WORD CFA_CMOVE ; CMOVE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ERASE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ERASE [ addr n -> ] fuellt n Bytes ab Adresse addr mit Nullen. )
;( ========================================================================= )
;
;: ERASE 0 FILL ;
NFA_ERASE .CBYTE $85,"ERASE"
LFA_ERASE .WORD NFA_FILL
CFA_ERASE .WORD DOCOL
PFA_ERASE
.WORD CFA_0 ; 0
.WORD CFA_FILL ; FILL
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> BLANKS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( BLANKS [ addr count -> ] fuellt count Bytes ab Adresse addr mit Blanks. )
;( ========================================================================= )
;
; : BLANKS BL FILL ;
NFA_BLANKS .CBYTE $86,"BLANKS"
LFA_BLANKS .WORD NFA_ERASE
CFA_BLANKS .WORD DOCOL
PFA_BLANKS
.WORD CFA_BL ; BL
.WORD CFA_FILL ; FILL
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> HOLD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( HOLD [ c -> ] fuegt das Zeichen c in einen Ziffernstring ein. Das Wort )
;( wird in Verbindung mit <# und #> gebraucht. )
;( ========================================================================= )
;
;: HOLD
; -1 HLD +! ( Zeiger im Ziffernstring weitersetzen )
; HLD @ C! ( Zeichen c in das Byte, auf das HLD zeigt, speichern )
; ;
NFA_HOLD .CBYTE $84,"HOLD"
LFA_HOLD .WORD NFA_BLANKS
CFA_HOLD .WORD DOCOL
PFA_HOLD
.WORD CFA_LIT ; LIT
.WORD -1
.WORD CFA_HLD ; HLD
.WORD CFA_PLUSSTORE ; +!
.WORD CFA_HLD ; HLD
.WORD CFA_FETCH ; @
.WORD CFA_CSTORE ; C!
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> PAD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( PAD [ -> addr ] uebergibt die Startadresse des Text-Ausgabe-Buffers PAD. )
;( ========================================================================= )
;
; : PAD HERE 68 + ;
NFA_PAD .CBYTE $83, "PAD"
LFA_PAD .WORD NFA_HOLD
CFA_PAD .WORD DOCOL
PFA_PAD
.WORD CFA_HERE ; HERE
.WORD CFA_CLIT ; CLIT
.BYTE 68
.WORD CFA_PLUS ; +
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> WORD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( WORD [ c -> c-addr ] bringt das im Input-Strom folgende, durch das )
;( Zeichen c abgeschlossene Wort als String nach HERE. Der String beginnt )
;( mit einem Count-Byte. )
;( ========================================================================= )
;
;: WORD
; TIB @ ( Adresse des Terminal-Input-Buffers )
; IN @ + ( Adresse, ab der gelesen wird )
; SWAP ENCLOSE ( Wort separieren )
; HERE 34 BLANKS ( Bereich HERE ... HERE+33 mit Blanks fuellen )
; IN +! ( IN zeigt jetzt auf Offset hinter dem Wort )
; OVER - >R ( Wortlaenge auf den Return-Stack legen )
; R HERE C! ( Wortlaenge als Count-Byte nach HERE speichern )
; + ( Startadresse des separierten Wortes )
; HERE 1+ ( Zieladresse des Wortes )
; R> ( Anzahl der zu kopierenden Zeichen )
; CMOVE ( separiertes Wort kopieren )
; HERE ( HERE auf dem Stack hinterlassen )
; ;
NFA_WORD .CBYTE $84, "WORD"
LFA_WORD .WORD NFA_PAD
CFA_WORD .WORD DOCOL
PFA_WORD
.WORD CFA_TIB ; TIB
.WORD CFA_FETCH ; @
.WORD CFA_IN ; IN
.WORD CFA_FETCH ; @
.WORD CFA_PLUS ; +
.WORD CFA_SWAP ; SWAP
.WORD CFA_ENCLOSE ; ENCLOSE
.WORD CFA_HERE ; HERE
.WORD CFA_CLIT ; CLIT
.BYTE 34
.WORD CFA_BLANKS ; BLANKS
.WORD CFA_IN ; IN
.WORD CFA_PLUSSTORE ; +!
.WORD CFA_OVER ; OVER
.WORD CFA_MINUS ; -
.WORD CFA_RPUSH ; >R
.WORD CFA_R ; R
.WORD CFA_HERE ; HERE
.WORD CFA_CSTORE ; C!
.WORD CFA_PLUS ; +
.WORD CFA_HERE ; HERE
.WORD CFA_1PLUS ; 1+
.WORD CFA_RPOP ; R>
.WORD CFA_CMOVE ; CMOVE
.WORD CFA_HERE ; HERE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> (NUMBER) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [NUMBER] [ d1 addr1 -> d2 addr2 ] akkumuliert den Ziffernstring ab )
;( Adresse addr1+1 zur doppeltgenauen, vorzeichenlosen Zahl d2 auf. addr2 )
;( ist die Adresse des ersten gefundenen Zeichens, das keine gueltige Ziffer )
;( darstellt. )
;( ========================================================================= )
;
; : (NUMBER)
; BEGIN
; 1+ ( auf naechstes Zeichen zeigen )
; DUP >R ( diesen Zeiger auf dem Return-Stack merken )
; C@ ( Zeichen holen )
; BASE @ DIGIT ( und in Ziffer umwandeln )
; WHILE ( solange es sich um eine gueltige Ziffer handelt: )
; SWAP BASE @ U* ( Hi-Word von d mit der Basis multiplizieren )
; DROP ( Hi-Word dieses Produktes vergessen )
; ROT BASE @ U* ( Lo-Word von d mit der Basis multiplizieren )
; D+ ( Summe Basis*d+n berechnen )
; DPL @ 1+ IF ( falls DPL nicht den Wert -1 enthaelt: )
; 1 DPL +! ( DPL inkrementieren )
; ENDIF
; R> ( neuen Zeiger vom Return-Stack zurueckholen )
; REPEAT ( wiederholen )
; R> ( falls fertig: Zeiger vom Returnstack holen )
; ;
NFA_PARENTNUMBER .CBYTE $88,"(NUMBER)"
LFA_PARENTNUMBER .WORD NFA_WORD
CFA_PARENTNUMBER .WORD DOCOL
PFA_PARENTNUMBER
LBL23
.WORD CFA_1PLUS ; 1+
.WORD CFA_DUP ; DUP
.WORD CFA_RPUSH ; >R
.WORD CFA_CFETCH ; C@
.WORD CFA_BASE ; BASE
.WORD CFA_FETCH ; @
.WORD CFA_DIGIT; DIGIT
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL24-*
.WORD CFA_SWAP ; SWAP
.WORD CFA_BASE ; BASE
.WORD CFA_FETCH ; @
.WORD CFA_UMULT ; U*
.WORD CFA_DROP ; DROP
.WORD CFA_ROT ; ROT
.WORD CFA_BASE ; BASE
.WORD CFA_FETCH ; @
.WORD CFA_UMULT ; U*
.WORD CFA_DPLUS ; D+
.WORD CFA_DPL ; DPL
.WORD CFA_FETCH ; @
.WORD CFA_1PLUS ; 1+
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL25-*
.WORD CFA_1 ; 1
.WORD CFA_DPL ; DPL
.WORD CFA_PLUSSTORE ; +!
LBL25
.WORD CFA_RPOP ; R>
.WORD CFA_BRANCH ; BRANCH
.WORD LBL23-*
LBL24
.WORD CFA_RPOP ; R>
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> NUMBER <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( NUMBER [ addr -> d ] wandelt den String, auf dessen Count-Byte addr )
;( zeigt, in eine doppeltgenaue Zahl d um. Das Count-Byte selbst wird nicht )
;( beruecksichtigt, der Ziffernstring muss durch ein Blank abgeschlossen )
;( sein. )
;( ========================================================================= )
;
; : NUMBER
; 0 0 ROT ( Anfangsbedingungen fuer [NUMBER] schaffen )
; DUP 1+ C@ ( erstes Zeichen nach dem Count-Byte holen )
; 45 = ( Vorzeichenflag: 1 falls Minuszeichen, sonst 0 )
; DUP >R ( Vorzeichenflag auf den Returnstack legen )
; + ( falls Vorzeichen: Adresse inkrementieren )
; -1 ( noch kein Dezimalpunkt gefunden )
; BEGIN ( Ziffern und Punkte einlesen und umwandeln: )
; DPL ! ( Dezimalpunkt-Position in DPL speichern )
; (NUMBER) ( folgende Ziffern in d aufakkumulieren )
; DUP C@ BL - ( Abbruch der Schleife, falls Blank angetroffen )
; WHILE ( sonst weitermachen )
; DUP C@ 46 - 0 ?ERROR ( Fehler falls kein Punkt )
; 0 ( Punkt gefunden, dann 0 in DPL speichern [s.o.] )
; REPEAT
; DROP ( Adresse vergessen )
; R> IF ( falls Minuszeichen am Anfang: )
; DMINUS ( Zahl negieren )
; ENDIF
; ;
NFA_NUMBER .CBYTE $86,"NUMBER"
LFA_NUMBER .WORD NFA_PARENTNUMBER
CFA_NUMBER .WORD DOCOL
PFA_NUMBER
.WORD CFA_0 ; 0
.WORD CFA_0 ; 0
.WORD CFA_ROT ; ROT
.WORD CFA_DUP ; DUP
.WORD CFA_1PLUS ; 1+
.WORD CFA_CFETCH ; C@
.WORD CFA_CLIT ; CLIT
.BYTE 45
.WORD CFA_EQUAL ; =
.WORD CFA_DUP ; DUP
.WORD CFA_RPUSH ; >R
.WORD CFA_PLUS ; +
.WORD CFA_LIT ; LIT
.WORD -1
LBL26
.WORD CFA_DPL ; DPL
.WORD CFA_STORE ; !
.WORD CFA_PARENTNUMBER ; (NUMBER)
.WORD CFA_DUP ; DUP
.WORD CFA_CFETCH ; C@
.WORD CFA_BL ; BL
.WORD CFA_MINUS ; -
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL27-*
.WORD CFA_DUP ; DUP
.WORD CFA_CFETCH ; C@
.WORD CFA_CLIT ; CLIT
.BYTE 46
.WORD CFA_MINUS ; -
.WORD CFA_0 ; 0
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_0 ; 0
.WORD CFA_BRANCH ; BRANCH
.WORD LBL26-*
LBL27
.WORD CFA_DROP ; DROP
.WORD CFA_RPOP ; R>
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL28-*
.WORD CFA_DMINUS ; DMINUS
LBL28
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> -FIND <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( -FIND [ -> pfa b tf ] falls Suche erfolgreich, sonst [ -> ff ]. Liest das )
;( naechste Wort und bringt es, mit Count-Byte versehen, nach HERE. )
;( Anschliessend wird das CONTEXT- und das CURRENT-Vokabular nach dem Wort )
;( abgesucht. Wird es gefunden, so wird seine PFA, das Count-Byte b und ein )
;( true-Flag uebergeben, sonst lediglich ein false-Flag. )
;( ========================================================================= )
;
; : -FIND
; BL WORD ( naechstes Wort lesen und nach HERE bringen )
; HERE CONTEXT @ @ (FIND) ( CONTEXT-Vokabular nach dem Wort absuchen )
; DUP 0= IF ( falls nicht gefunden: )
; DROP ( false-Flag vergessen )
; HERE LATEST (FIND) ( CURRENT-Vokabular nach dem Wort absuchen )
; ENDIF
; ;
NFA_MINUSFIND .CBYTE $85,"-FIND"
LFA_MINUSFIND .WORD NFA_NUMBER
CFA_MINUSFIND .WORD DOCOL
PFA_MINUSFIND
.WORD CFA_BL ; BL
.WORD CFA_WORD ; WORD
.WORD CFA_CONTEXT ; CONTEXT
.WORD CFA_FETCH ; @
.WORD CFA_FETCH ; @
.WORD CFA_BRACKETFIND ; (FIND)
.WORD CFA_DUP ; DUP
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_0BRANCH ; 0BRACH
.WORD LBL29-*
.WORD CFA_DROP ; DROP
.WORD CFA_HERE ; HERE
.WORD CFA_LATEST ; LATEST
.WORD CFA_BRACKETFIND ; (FIND)
LBL29
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> (ABORT) <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [ABORT] [ ] wird im Anschluss an eine Fehlermeldung ausgefuehrt, wenn die )
;( User-Variable WARNING den Wert -1 hat. Es wird lediglich das Wort ABORT )
;( aufgerufen. )
;( ========================================================================= )
;
; : (ABORT) ABORT ;
NFA_PARENTABORT .CBYTE $87,"(ABORT)"
LFA_PARENTABORT .WORD NFA_MINUSFIND
CFA_PARENTABORT .WORD DOCOL
PFA_PARENTABORT
.WORD CFA_ABORT ; ABORT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ERROR <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ERROR [ n -> in blk ] gibt je nach Inhalt der User-Variablen WARNING den )
;( Text der Zeile n relativ zu Zeile 0 in Screen 4 aus [WARNING=1] oder )
;( lediglich eine verkuerzte Fehlermeldung unter Angabe der Fehlernummer n )
;( [WARNING=0]. Ist WARNING=-1, so wird [ABORT] aufgerufen. Schliesslich )
;( wird der Inhalt der User-Variablen IN und BLK zurueckgegeben. )
;( ========================================================================= )
; : ERROR
; WARNING @ 0< IF (ABORT) THEN
; HERE COUNT TYPE ."?" MESSAGE SP!
; IN @ BLK @ QUIT ;
NFA_ERROR .CBYTE $85, "ERROR"
LFA_ERROR .WORD NFA_PARENTABORT
CFA_ERROR .WORD DOCOL
PFA_ERROR
.WORD CFA_WARNING ; WARNING
.WORD CFA_FETCH ; @
.WORD CFA_LTNULL ; 0<
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL30-*
.WORD CFA_PARENTABORT ; (ABORT)
LBL30
.WORD CFA_HERE ; HERE
.WORD CFA_COUNT ; COUNT
.WORD CFA_TYPE ; TYPE
.WORD CFA_BRAKETDOTQUOTE ; (.")
.BYTE 2
.BYTE 63
.BYTE 32
.WORD CFA_MESSAGE ; MESSAGE
.WORD CFA_SPSTORE ; SP!
;.WORD CFA_IN ; IN ; auskommentiert da wir keine blockbefehle haben
;.WORD CFA_FETCH ; @ ; to do --> umsetzen fuer Dateizugriff
;.WORD CFA_BLK ; BLK
;.WORD CFA_FETCH ; @
.WORD CFA_QUIT ; QUIT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ID. <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ID. [ addr -> ] kopiert das Namenfeld des Wortes, auf dessen NFA addr )
;( zeigt, nach PAD und gibt den Namen, gefolgt von einem Blank, auf die )
;( Standardausgabe aus. )
;( ========================================================================= )
;
;( Die mit [*] gekennzeichneten Zeilen sind hinzugefuegt worden, damit auch )
;( auf Rechnern mit einem erweiterten 8-Bit-Zeichensatz der Name korrekt )
;( ausgegeben wird. )
;
; : ID.
; PAD 32 95 FILL ( PAD mit 32 Underscores fuellen )
; DUP PFA LFA ( LFA des Wortes ermitteln )
; OVER - ( Differenz mit NFA ergibt Laenge des Namenfeldes )
; SWAP OVER ( Laenge noch mal retten [*] )
; PAD SWAP CMOVE ( gesamtes Namenfeld nach PAD kopieren )
; 1 - PAD + 128 TOGGLE ( MS-Bit des letzten Zeichens loeschen [*] )
; PAD COUNT 31 AND TYPE ( Namen mit korrigiertem Count-Byte ausgeben )
; SPACE ( Blank ausgeben )
; ;
NFA_IDDOT .CBYTE $83,"ID."
LFA_IDDOT .WORD NFA_ERROR
CFA_IDDOT .WORD DOCOL
PFA_IDDOT
.WORD CFA_PAD ; PAD
.WORD CFA_CLIT ; CLIT
.BYTE 32
.WORD CFA_CLIT ; CLIT
.BYTE 95
.WORD CFA_FILL ; FILL
.WORD CFA_DUP ; DUP
.WORD CFA_PFA ; PFA
.WORD CFA_LFA ; LFA
.WORD CFA_OVER ; OVER
.WORD CFA_MINUS ; -
.WORD CFA_SWAP ; SWAP
.WORD CFA_OVER ; OVER
.WORD CFA_PAD ; PAD
.WORD CFA_SWAP ; SWAP
.WORD CFA_CMOVE ; CMOVE
.WORD CFA_1 ; 1
.WORD CFA_MINUS ; -
.WORD CFA_PAD ; PAD
.WORD CFA_PLUS ; +
.WORD CFA_CLIT ; CLIT
.BYTE 128
.WORD CFA_TOGGLE ; TOGGLE
.WORD CFA_PAD ; PAD
.WORD CFA_COUNT ; COUNT
.WORD CFA_CLIT ; CLIT
.BYTE 31
.WORD CFA_AND ; AND
.WORD CFA_TYPE ; TYPE
.WORD CFA_SPACE ; SPACE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> CREATE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CREATE [ ] erzeugt einen Wort-Header im Dictionary. )
;( ========================================================================= )
;
; : CREATE
; TIB HERE 160 + U< 2 ?ERROR ( nur 6502: Fehler falls kein Platz mehr )
; -FIND IF ( Namenstring ablegen; falls schon vorhanden: )
; DROP NFA ID. ( Namen ausgeben )
; 4 MESSAGE SPACE ( Fehlermeldung 4 und Blank ausgeben )
; ENDIF
; HERE DUP C@ WIDTH @ MIN ( Laenge des evtl. gekuerzten Namen )
; 1+ ALLOT ( plus Count-Byte: ins Dictionary einverleiben )
; DP C@ 253 = ALLOT ( nur 6502: Codefeld darf nicht auf FF liegen )
; DUP 160 TOGGLE ( hoechstes und SMUDGE-Bit setzen )
; HERE 1 - 128 TOGGLE ( hoechstes Bit im letzten Buchstaben setzen )
; LATEST , ( Link-Feld auf vorheriges Wort zeigen lassen )
; CURRENT @ ! ( Current-Kette beginnt b. NFA d. neuen Wortes )
; HERE 2+ , ( naechste Adresse in das Codefeld schreiben )
; ;
NFA_CREATE .CBYTE $86,"CREATE"
LFA_CREATE .WORD NFA_IDDOT
CFA_CREATE .WORD DOCOL
PFA_CREATE
.WORD CFA_TIB ; TIB
.WORD CFA_HERE ; HERE
.WORD CFA_CLIT ; CLIT
.BYTE 160
.WORD CFA_PLUS ; +
.WORD CFA_ULT ; U<
.WORD CFA_2 ; 2
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_MINUSFIND ; -FIND
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL31-*
.WORD CFA_DROP ; DROP
.WORD CFA_NFA ; NFA
.WORD CFA_IDDOT ; ID.
.WORD CFA_CLIT ; CLIT
.BYTE 4
.WORD CFA_MESSAGE ; MESSAGE
.WORD CFA_SPACE ; SPACE
LBL31
.WORD CFA_HERE ; HERE
.WORD CFA_DUP ; DUP
.WORD CFA_CFETCH ; C@
.WORD CFA_WIDTH ; WIDTH
.WORD CFA_FETCH ; @
.WORD CFA_MIN ; MIN
.WORD CFA_1PLUS ; 1+
.WORD CFA_ALLOT ; ALLOT
.WORD CFA_DP ; DP
.WORD CFA_CFETCH ; C@
.WORD CFA_CLIT ; CLIT
.BYTE 253
.WORD CFA_EQUAL ; =
.WORD CFA_ALLOT ; ALLOT
.WORD CFA_DUP ; DUP
.WORD CFA_CLIT ; CLIT
.BYTE 160
.WORD CFA_TOGGLE ; TOGGLE
.WORD CFA_HERE ; HERE
.WORD CFA_1 ; 1
.WORD CFA_MINUS ; -
.WORD CFA_CLIT ; CLIT
.BYTE 128
.WORD CFA_TOGGLE ; TOGGLE
.WORD CFA_LATEST ; LATEST
.WORD CFA_COMMA ; ,
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_FETCH ; @
.WORD CFA_STORE ; !
.WORD CFA_HERE ; HERE
.WORD CFA_2PLUS ; 2+
.WORD CFA_COMMA ; ,
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> [COMPILE] <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [COMPILE] [ ] kompiliert das im Input-Stream folgende Wort in das )
;( Dictionary. )
;( ========================================================================= )
;
; : [COMPILE]
; -FIND 0= 0 ?ERROR ( Fehlermeldung ausgeben, falls Wort nicht vorhanden )
; DROP CFA , ( sonst CFA des Wortes in das Dictionary kompilieren )
; ; IMMEDIATE
NFA_BRACKETCOMPILE .CBYTE $89+$40,"[COMPILE]" ; IMMEDIATE
LFA_BRACKETCOMPILE .WORD NFA_CREATE
CFA_BRACKETCOMPILE .WORD DOCOL
PFA_BRACKETCOMPILE
.WORD CFA_MINUSFIND ; -FIND
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_0 ; 0
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_DROP ; DROP
.WORD CFA_CFA ; CFA
.WORD CFA_COMMA ; ,
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> LITERAL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( LITERAL [ n -> n ] falls Execute-Mode, [ n -> ] falls Compile-Mode. )
;( Im Compile-Mode wird die Zahl n mitsamt einem LIT in das Dictionary )
;( kompiliert. Im Execute-Mode hat der Aufruf keinen Effekt. )
;( ========================================================================= )
;
; : LITERAL
; STATE @ IF ( falls Compile-Mode: )
; COMPILE LIT ( Wort LIT in das Dictionary kompilieren )
; , ( Zahl n in das Dictionary kompilieren )
; ENDIF
; ; IMMEDIATE
NFA_LITERAL .CBYTE $87+$40,"LITERAL" ; IMMEDIATE
LFA_LITERAL .WORD NFA_BRACKETCOMPILE
CFA_LITERAL .WORD DOCOL
PFA_LITERAL
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL32-*
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_LIT ; LIT
.WORD CFA_COMMA ; ,
LBL32
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> DLITERAL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DLITERAL [ d -> d ] falls Execute-Mode, [ d -> ] falls Compile-Mode. )
;( Im Compile-Mode wird die doppeltgenaue Zahl d mitsamt entsprechenden )
;( LITs in das Dictionary kompiliert. Im Execute-Mode hat der Aufruf keinen )
;( Effekt. )
;( ========================================================================= )
;
; : DLITERAL
; STATE @ IF ( falls Compile-Mode: )
; SWAP ( Hi- und Lo-Word von d vertauschen )
; [COMPILE] LITERAL ( LIT und Lo-Word von d kompilieren )
; [COMPILE] LITERAL ( LIT und Hi-Word von d kompilieren )
; ENDIF
; ; IMMEDIATE
NFA_DLITERAL .CBYTE $88+$40,"DLITERAL" ; IMMEDIATE
LFA_DLITERAL .WORD NFA_LITERAL
CFA_DLITERAL .WORD DOCOL
PFA_DLITERAL
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL33-*
.WORD CFA_SWAP ; SWAP
.WORD CFA_LITERAL ; LITERAL
.WORD CFA_LITERAL ; LITERAL
LBL33
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ?STACK <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ?STACK [ ] gibt eine Fehlermeldung aus, falls der Stack ueber seine )
;( Grenzen gewachsen ist. )
;( ========================================================================= )
;
; : ?STACK
; SP@ ASM TOS SWAP U< 1 ?ERROR ( Fehlermeldung falls Stack-Unterlauf )
; SP@ ASM BOS U< 7 ?ERROR ( Fehlermeldung falls Stack-Ueberlauf )
; ;
NFA_QUERYSTACK .CBYTE $86,"?STACK"
LFA_QUERYSTACK .WORD NFA_DLITERAL
CFA_QUERYSTACK .WORD DOCOL
PFA_QUERYSTACK
.WORD CFA_SPFETCH ; SP@
.WORD CFA_LIT ; LIT
.WORD TOS
.WORD CFA_SWAP ; SWAP
.WORD CFA_ULT ; U<
.WORD CFA_1 ; 1
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_SPFETCH ; SP@
.WORD CFA_LIT ; LIT
.WORD BOS
.WORD CFA_ULT ; U<
.WORD CFA_CLIT ; CLIT
.BYTE 7
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> INTERPRET <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( INTERPRET [ ] ist der Kern des aeusseren Interpreters. Text wird geholt )
;( und, je nach Systemzustand, ausgefuehrt oder kompiliert. ASCII Null been- )
;( det die Prozedur. )
;( ========================================================================= )
;
; : INTERPRET
; BEGIN ( Endlosschleife )
; -FIND IF ( Wort lesen; falls vorhanden: )
; STATE @ < IF ( falls Compile-Mode und nicht IMMEDIATE: )
; CFA , ( CFA des Wortes kompilieren )
; ELSE ( sonst: )
; CFA EXECUTE ( Wort ausfuehren )
; ENDIF
; ?STACK ( Stack ueberpruefen )
; ELSE ( falls Wort nicht vorhanden: )
; HERE NUMBER ( Wort in Zahl umwandeln )
; DPL @ 1+ IF ( falls Dezimalpunkt vorhanden: )
; [COMPILE] DLITERAL ( doppelt-genaue Zahl kompilieren )
; ELSE ( falls kein Dezimalpunkt vorhanden: )
; DROP [COMPILE] LITERAL ( einfach genaue Zahl kompilieren )
; ENDIF
; ?STACK ( Stack ueberpruefen )
; ENDIF
; AGAIN ( Ende der Endlosschleife )
; ;
NFA_INTERPRET .CBYTE $89,"INTERPRET"
LFA_INTERPRET .WORD NFA_QUERYSTACK
CFA_INTERPRET .WORD DOCOL
PFA_INTERPRET
LBL34
.WORD CFA_MINUSFIND ; -FIND
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL35-*
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_LT ; <
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL36-*
.WORD CFA_CFA ; CFA
.WORD CFA_COMMA ; ,
.WORD CFA_BRANCH ; BRANCH
.WORD LBL37-*
LBL36
.WORD CFA_CFA ; CFA
.WORD CFA_EXECUTE ; EXECUTE
LBL37
.WORD CFA_QUERYSTACK ; ?STACK
.WORD CFA_BRANCH ; BRANCH
.WORD LBL38-*
LBL35
.WORD CFA_HERE ; HERE
.WORD CFA_NUMBER ; NUMBER
.WORD CFA_DPL ; DPL
.WORD CFA_FETCH ; @
.WORD CFA_1PLUS ; 1+
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL39-*
.WORD CFA_DLITERAL ; DLITERAL
.WORD CFA_BRANCH ; BRANCH
.WORD LBL40-*
LBL39
.WORD CFA_DROP ; DROP
.WORD CFA_LITERAL ; LITERAL
LBL40
.WORD CFA_QUERYSTACK ; ?STACK
LBL38
.WORD CFA_BRANCH ; BRANCH
.WORD LBL34-*
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> IMMEDIATE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( IMMEDIATE [ ] dreht das Precedence-Bit des zuletzt definierten Wortes um. )
;( ========================================================================= )
;
; : IMMEDIATE LATEST 64 TOGGLE ;
NFA_IMMEDIATE .CBYTE $89, "IMMEDIATE"
LFA_IMMEDIATE .WORD NFA_INTERPRET
CFA_IMMEDIATE .WORD DOCOL
PFA_IMMEDIATE
.WORD CFA_LATEST ; LATEST
.WORD CFA_CLIT ; CLIT
.BYTE 64
.WORD CFA_TOGGLE ; TOGGLE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> VOCABULARY <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( VOCABULARY [ ] definiert ein Vokabular. )
;( ========================================================================= )
;
; : VOCABULARY
; <BUILDS ( provisorischen Header des Vokabulars aufbauen )
; -24447 , ( Header 81 A0 eines Dummy-Wortes " " aufbauen )
; CURRENT @ CFA , ( NFA des letzten " "-Dummys in LFA von " " eintragen )
; HERE ( aktueller Wert von DP = CFA von " " )
; VOC-LINK @ , ( Link zum letzten Vokabular in CFA von " " eintragen )
; VOC-LINK ! ( CFA von " " in der User-Variablen VOC-LINK sichern )
; DOES> ( das neue Vokabular-Wort tut bei Aufruf folgendes: )
; 2+ CONTEXT ! ( LFA von " " in CONTEXT ablegen )
; ;
NFA_VOCABULARY .CBYTE $8A, "VOCABULARY"
LFA_VOCABULARY .WORD NFA_IMMEDIATE
CFA_VOCABULARY .WORD DOCOL
PFA_VOCABULARY
.WORD CFA_BUILDS ; <BUILDS
.WORD CFA_LIT ; LIT
.WORD -24447
.WORD CFA_COMMA ; ,
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_FETCH ; @
.WORD CFA_CFA ; CFA
.WORD CFA_COMMA ; ,
.WORD CFA_HERE ; HERE
.WORD CFA_VOCLINK ; VOC-LINK
.WORD CFA_FETCH ; @
.WORD CFA_COMMA ; ,
.WORD CFA_VOCLINK ; VOC-LINK
.WORD CFA_STORE ; !
.WORD CFA_DOES ; DOES>
DOES156
.WORD CFA_2PLUS ; 2+
.WORD CFA_CONTEXT ; CONTEXT
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> FORTH <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( FORTH [ ] macht das FORTH-Vokabular zum CONTEXT-Vokabular. )
;( ========================================================================= )
;
; VOCABULARY FORTH IMMEDIATE
;
; FORTH DEFINITIONS
NFA_FORTH .CBYTE $85+$40, "FORTH"
LFA_FORTH .WORD NFA_VOCABULARY
CFA_FORTH .WORD DODOE
PFA_FORTH
.WORD DOES156
.BYTE 129
.BYTE 160
.WORD NFA_MON
.WORD 0
; >>>>>>>>>>>>>>>> DEFINITIONS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DEFINITIONS [ ] macht das Context-Vokabular auch current. )
;( ========================================================================= )
;
; : DEFINITIONS CONTEXT @ CURRENT ! ;
NFA_DEFINITIONS .CBYTE $8B, "DEFINITIONS"
LFA_DEFINITIONS .WORD NFA_FORTH
CFA_DEFINITIONS .WORD DOCOL
PFA_DEFINITIONS
.WORD CFA_CONTEXT ; CONTEXT
.WORD CFA_FETCH ; @
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ( <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( [ [ ] leitet einen Kommentar ein, der bis zur naechsten schliessenden )
;( Klammer reicht. )
;( ========================================================================= )
;
; : ( 41 WORD DROP ; IMMEDIATE ( bis zur naechsten "Klammer zu" ueberlesen )
NFA_LEFTPAREN .CBYTE $81+$40, "(" ; IMMEDIATE
LFA_LEFTPAREN .WORD NFA_DEFINITIONS
CFA_LEFTPAREN .WORD DOCOL
PFA_LEFTPAREN
.WORD CFA_CLIT ; CLIT
.BYTE 41
.WORD CFA_WORD ; WORD
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> QUIT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( QUIT [ ] schaltet auf Keyboard-Eingabe um, beendet den Compile-Mode und )
;( tritt in eine Endlosschleife ein, in der der Benutzer Eingaben macht und )
;( diese anschliessend interpretiert werden. )
;( ========================================================================= )
; : QUIT
; 0 SOURCE-ID ! ( auf Keyboard-Eingabe umschalten )
; [COMPILE] [ ( auf Execute-Mode umschalten )
; BEGIN ( Endlosschleife: )
; RP! ( Returnstack-Pointer reinitialisieren )
; CR ( Zeilenvorschub ausgeben )
; QUERY ( eine Zeile Text in den Terminal-Input-Buffer einlesen )
; INTERPRET ( Zeile interpretieren, ASCII 0 beendet Interpretation )
; STATE @ 0= IF ( falls Execute-Mode: )
; ." OK" ( "OK" ausgeben )
; ENDIF
; AGAIN ( Ende der Endlosschleife )
; ;
NFA_QUIT .CBYTE $84, "QUIT"
LFA_QUIT .WORD NFA_LEFTPAREN
CFA_QUIT .WORD DOCOL
PFA_QUIT
.WORD CFA_0 ; 0
.WORD CFA_SOURCEID ; SOURCE-ID
.WORD CFA_STORE ; !
.WORD CFA_LEFTBRACKET ; [
LBL41
.WORD CFA_RPSTORE ; RP!
.WORD CFA_CR ; CR
.WORD CFA_QUERY ; QUERY
.WORD CFA_INTERPRET ; INTERPRET
.WORD CFA_STATE ; STATE
.WORD CFA_FETCH ; @
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL42-*
.WORD CFA_BRAKETDOTQUOTE ; (.")
.BYTE 2
.BYTE 79
.BYTE 75
LBL42
.WORD CFA_BRANCH ; BRANCH
.WORD LBL41-*
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ABORT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ABORT [ ] reinitialisiert die Stacks, schaltet in den Execute-Mode um und )
;( geht in den aeusseren Interpreter QUIT ueber. )
;( ========================================================================= )
;
; : ABORT
; SP! DECIMAL DR0 ( Initialisierungen vornehmen )
; CR ." X-FORTH 1.1" ( Systemmeldung ausgeben )
; [COMPILE] FORTH DEFINITIONS ( FORTH zum aktuellen Vokabular machen )
; QUIT ( zum aeusseren Interpreter QUIT )
; ;
NFA_ABORT .CBYTE $85,"ABORT"
LFA_ABORT .WORD NFA_QUIT
CFA_ABORT .WORD DOCOL
PFA_ABORT
.WORD CFA_SPSTORE ; SP!
.WORD CFA_DECIMAL ; DECIMAL
.WORD CFA_CR ; CR
.WORD CFA_FORTH ; FORTH
.WORD CFA_DEFINITIONS ; DEFINITIONS
;.WORD CFA_BRAKETDOTQUOTE ; (.")
;.BYTE 22,"X-FORTH 1.1c 040410/cs"
ABORTINIT
.WORD CFA_QUIT ; QUIT
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> COLD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( COLD [ ] fuehrt einen Kaltstart des Systems durch. )
;( ========================================================================= )
NFA_COLD .CBYTE $84, "COLD"
LFA_COLD .WORD NFA_ABORT
CFA_COLD .WORD PFA_COLD
PFA_COLD
SEI ; maskierbare Interrupts sperren
; USERAREA default siehe ORIGIN+16
.IF DYNMEMTOP ; USERAREA nach MEMTOP ($2E5)-$100 setzen
LDA $02E5
STA ORIG+16
LDA $02E6
SEC
SBC #2
STA ORIG+17
.ENDIF
RESET
LDA DOSINI
STA DOSIN+1
LDA DOSINI+1
STA DOSIN+2
LDA ORIG+12 ; NFA des letzten Wortes im Dictionary
STA PFA_FORTH+4 ; in das Vokabular-Wort FORTH eintragen
LDA ORIG+13
STA PFA_FORTH+5
LDY #21 ; Kaltstart: Uservariablen 0 bis VOC-LINK init.
BNE L2433 ; d.h. zusaetzlich FENCE, DP und VOC-LINK
WARM
DOSIN
JSR $E474 ; wird ueberschrieben!
LDY #15 ; Warmstart: nur Uservariablen 0 bis WARNING init.
L2433
LDA ORIG+16 ; User-Pointer UP initialisieren
STA UP
LDA ORIG+17
STA UP+1
L2437
LDA ORIG+12,Y ; Uservariablen mit Werten ab 12+ORIGIN initialis.
STA (UP),Y
DEY
BPL L2437
LDA #>PFA_ABORT ; Instruction-Pointer IP initialisieren:
STA IP+1 ; Interpretation beginnt mit dem Wort ABORT
LDA #<PFA_ABORT
STA IP
CLD ; Dezimalarithmetik ausschalten
LDA #$6C ; Opcode fuer JMP (), d.h. indirekten Sprung
STA W-1 ; unmittelbar vor das W-Register schreiben
CLI ; maskierbare Interrupts zulassen
LDA #<WARM
STA DOSINI
LDA #>WARM
STA DOSINI+1
JMP PFA_RPSTORE ; Returnstackpointer initialisieren und ABORT
; >>>>>>>>>>>>>>>> S>D <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( S>D [ n -> d ] wandelt die Zahl n in eine doppeltgenaue Zahl d um. )
;( ========================================================================= )
;
; : S>D DUP 0< MINUS ; ( $0000 oder $FFFF als Hi-Word erzeugen )
NFA_STOD .CBYTE $83, "S>D"
LFA_STOD .WORD NFA_COLD
CFA_STOD .WORD DOCOL
PFA_STOD
.WORD CFA_DUP ; DUP
.WORD CFA_LTNULL ; 0<
.WORD CFA_NEGATE ; MINUS
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> +- <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( +- [ n1 n2 -> n3 ] gibt n3=-n1 zurueck, wenn n2 negativ ist, sonst n3=n1. )
;( ========================================================================= )
;
; : +- 0< IF MINUS ENDIF ;
NFA_PLUSMINUS .CBYTE $82,"+-"
LFA_PLUSMINUS .WORD NFA_STOD
CFA_PLUSMINUS .WORD DOCOL
PFA_PLUSMINUS
.WORD CFA_LTNULL ; 0<
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL43-*
.WORD CFA_NEGATE ; MINUS
LBL43
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> D+- <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( D+- [ d1 n -> d2 ] gibt d2=-d1 zurueck, wenn n negativ ist, sonst d2=d1. )
;( Hierbei sind d1 und d2 doppeltgenaue Zahlen. )
;( ========================================================================= )
;
; : D+- 0< IF DMINUS ENDIF ;
NFA_DPLUSMINUS .CBYTE $83,"D+-"
LFA_DPLUSMINUS .WORD NFA_PLUSMINUS
CFA_DPLUSMINUS .WORD DOCOL
PFA_DPLUSMINUS
.WORD CFA_LTNULL ; 0<
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL44-*
.WORD CFA_DMINUS ; DMINUS
LBL44
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ABS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ABS [ n -> u ] berechnet den absoluten Betrag der Zahl n. )
;( ========================================================================= )
;
; : ABS DUP +- ;
NFA_ABS .CBYTE $83,"ABS"
LFA_ABS .WORD NFA_DPLUSMINUS
CFA_ABS .WORD DOCOL
PFA_ABS
.WORD CFA_DUP ; DUP
.WORD CFA_PLUSMINUS ; +-
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> DABS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DABS [ d -> ud ] berechnet den absoluten Betrag der doppeltgenauen )
;( Zahl d. )
;( ========================================================================= )
;
; : DABS DUP D+- ;
NFA_DABS .CBYTE $84,"DABS"
LFA_DABS .WORD NFA_ABS
CFA_DABS .WORD DOCOL
PFA_DABS
.WORD CFA_DUP ; DUP
.WORD CFA_DPLUSMINUS ; D+-
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> MIN <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( MIN [ n1 n2 -> min ] berechnet das Minimum der Zahlen n1 und n2. )
;( ========================================================================= )
;
; : MIN
; OVER OVER > IF ( falls n1>n2 ist: )
; SWAP ( n1 in den TOS tauschen )
; ENDIF
; DROP ( groessere Zahl im TOS vergessen )
; ;
NFA_MIN .CBYTE $83,"MIN"
LFA_MIN .WORD NFA_DABS
CFA_MIN .WORD DOCOL
PFA_MIN
.WORD CFA_OVER ; OVER
.WORD CFA_OVER ; OVER
.WORD CFA_GT ; >
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL45-*
.WORD CFA_SWAP ; SWAP
LBL45
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> MAX <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( MAX [ n1 n2 -> max ] berechnet das Maximum der Zahlen n1 und n2. )
;( ========================================================================= )
;
; : MAX
; OVER OVER < IF ( falls n1<n2 ist: )
; SWAP ( n1 in den TOS tauschen )
; ENDIF
; DROP ( kleinere Zahl im TOS vergessen )
; ;
NFA_MAX .CBYTE $83,"MAX"
LFA_MAX .WORD NFA_MIN
CFA_MAX .WORD DOCOL
PFA_MAX
.WORD CFA_OVER ; OVER
.WORD CFA_OVER ; OVER
.WORD CFA_LT ; <
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL46-*
.WORD CFA_SWAP ; SWAP
LBL46
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> M* <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( M* [ n1 n2 -> d ] multipliziert die beiden einfachgenauen Zahlen n1 und )
;( n2 und gibt das Ergebnis als doppeltgenaue Zahl d zurueck. )
;( ========================================================================= )
;
; : M*
; OVER OVER XOR >R ( Vorzeichen-Flag auf den Return-Stack bringen )
; ABS SWAP ABS U* ( absolute Betraege von n1 und n2 multiplizieren )
; R> D+- ( eventuell Ergebnis negieren )
; ;
NFA_MSTAR .CBYTE $82,"M*"
LFA_MSTAR .WORD NFA_MAX
CFA_MSTAR .WORD DOCOL
PFA_MSTAR
.WORD CFA_OVER ; OVER
.WORD CFA_OVER ; OVER
.WORD CFA_XOR ; XOR
.WORD CFA_RPUSH ; >R
.WORD CFA_ABS ; ABS
.WORD CFA_SWAP ; SWAP
.WORD CFA_ABS ; ABS
.WORD CFA_UMULT ; U*
.WORD CFA_RPOP ; R>
.WORD CFA_DPLUSMINUS ; D+-
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> M/ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( M/ [ d n1 -> n2 n3 ] berechnet zur doppeltgenauen Zahl d und zur einfach- )
;( genauen Zahl n1 den Quotienten n3=d/n1 sowie den Rest n2, der das Vorzei- )
;( chen des Zaehlers d erhaelt. )
;( ========================================================================= )
;
; : M/
; OVER >R >R ( Hi-Wort von d und n1 auf den Return-Stack bringen )
; DABS R ABS U/ ( |d| durch |n1| teilen, Quotient liegt auf dem TOS )
; R> R XOR +- ( Quotient negieren, falls sign[d]<>sign[n1] )
; SWAP R> +- ( Rest negieren, falls d negativ ist )
; SWAP ( Quotient wieder in den TOS tauschen )
; ;
NFA_MSLASH .CBYTE $82,"M/"
LFA_MSLASH .WORD NFA_MSTAR
CFA_MSLASH .WORD DOCOL
PFA_MSLASH
.WORD CFA_OVER ; OVER
.WORD CFA_RPUSH ; >R
.WORD CFA_RPUSH ; >R
.WORD CFA_DABS ; DABS
.WORD CFA_R ; R
.WORD CFA_ABS ; ABS
.WORD CFA_UDIV ; U/
.WORD CFA_RPOP ; R>
.WORD CFA_R ; R
.WORD CFA_XOR ; XOR
.WORD CFA_PLUSMINUS ; +-
.WORD CFA_SWAP ; SWAP
.WORD CFA_RPOP ; R>
.WORD CFA_PLUSMINUS ; +-
.WORD CFA_SWAP ; SWAP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> * <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( * [ n1 n2 -> n3 ] multipliziert die Zahlen n1 und n2. )
;( ========================================================================= )
;
; : * U* DROP ; ( multiplizieren und Hi-Word des Produktes vergessen )
NFA_STAR .CBYTE $81,"*"
LFA_STAR .WORD NFA_MSLASH
CFA_STAR .WORD DOCOL
PFA_STAR
.WORD CFA_UMULT ; U*
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> /MOD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( /MOD [ n1 n2 -> Rest Quot ] teilt die Zahl n1 durch die Zahl n2 und )
;( uebergibt den Rest und den Quotienten. )
;( ========================================================================= )
;
; : /MOD >R S>D R> M/ ; ( n1 doppeltgenau machen und M/ aufrufen )
NFA_SLASHMOD .CBYTE $84,"/MOD"
LFA_SLASHMOD .WORD NFA_STAR
CFA_SLASHMOD .WORD DOCOL
PFA_SLASHMOD
.WORD CFA_RPUSH ; >R
.WORD CFA_STOD ; S>D
.WORD CFA_RPOP ; R>
.WORD CFA_MSLASH ; M/
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> / <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( / [ n1 n2 -> Quotient ] berechnet den Quotienten n1/n2. )
;( ========================================================================= )
;
; : / /MOD SWAP DROP ;
NFA_SLASH .CBYTE $81,"/"
LFA_SLASH .WORD NFA_SLASHMOD
CFA_SLASH .WORD DOCOL
PFA_SLASH
.WORD CFA_SLASHMOD ; /MOD
.WORD CFA_SWAP ; SWAP
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> MOD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( MOD [ n1 n2 -> mod ] berechnet den Rest der Division n1/n2. )
;( ========================================================================= )
;
; : MOD /MOD DROP ;
NFA_MOD .CBYTE $83,"MOD"
LFA_MOD .WORD NFA_SLASH
CFA_MOD .WORD DOCOL
PFA_MOD
.WORD CFA_SLASHMOD ; /MOD
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> */MOD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( */MOD [ n1 n2 n3 -> n4 n5 ] berechnet [n1*n2]/n3 und uebergibt in n4 den )
;( Rest und in n5 den Quotienten. Es wird mit einem doppeltgenauen Zwischen- )
;( produkt n1*n2 gerechnet. )
;( ========================================================================= )
;
; : */MOD >R M* R> M/ ;
NFA_STARSLASHMOD .CBYTE $85, "*/MOD"
LFA_STARSLASHMOD .WORD NFA_MOD
CFA_STARSLASHMOD .WORD DOCOL
PFA_STARSLASHMOD
.WORD CFA_RPUSH ; >R
.WORD CFA_MSTAR ; M*
.WORD CFA_RPOP ; R>
.WORD CFA_MSLASH ; M/
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> */ <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( */ [ n1 n2 n3 -> n4 ] berechnet den Quotienten [n1*n2]/n3. Es wird mit )
;( einem doppeltgenauen Zwischenprodukt n1*n2 gerechnet. )
;( ========================================================================= )
;
; : */ */MOD SWAP DROP ;
NFA_STARSLASH .CBYTE $82,"*/"
LFA_STARSLASH .WORD NFA_STARSLASHMOD
CFA_STARSLASH .WORD DOCOL
PFA_STARSLASH
.WORD CFA_STARSLASHMOD ; */MOD
.WORD CFA_SWAP ; SWAP
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> M/MOD <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( M/MOD [ ud1 u2 -> u3 ud4 ] dividiert die vorzeichenlose, doppeltgenaue )
;( Zahl ud1 durch die vorzeichenlose Zahl u2 und uebergibt den Rest u3 sowie )
;( den doppeltgenauen Quotienten ud4. )
;( ========================================================================= )
;
;( Funktionsweise des Algorithmus: Seien B=2^16 und ud1=a*B+b. Mit / sei die )
;( ganzzahlige Division bezeichnet, mit % die Restbildung. Dann gilt: )
;( ud4 = ud1/u2 = [a*B+b]/u2 = [a/u2]*B + [[a%u2]*B+b]/u2 und )
;( u3 = ud1%u2 = [a*B+b]%u2 = [[a%u2]*B+b]%u2. )
;( Im untenstehenden Kommentar bezeichne q=[[a%u2]*B+b]/u2. )
;
;: M/MOD ( b a u2 )
; >R ( b a RS: u2 )
; 0 R ( b a 0 u2 RS: u2 )
; U/ ( b a%u2 a/u2 RS: u2 )
; R> SWAP >R ( b a%u2 u2 RS: a/u2 )
; U/ ( u3 q RS: a/u2 )
; R> ( u3 q a/u2 )
; ;
NFA_MMOD .CBYTE $85, "M/MOD"
LFA_MMOD .WORD NFA_STARSLASH
CFA_MMOD .WORD DOCOL
PFA_MMOD
.WORD CFA_RPUSH ; >R
.WORD CFA_0 ; 0
.WORD CFA_R ; R
.WORD CFA_UDIV ; U/
.WORD CFA_RPOP ; R>
.WORD CFA_SWAP ; SWAP
.WORD CFA_RPUSH ; >R
.WORD CFA_UDIV ; U/
.WORD CFA_RPOP ; R>
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> MESSAGE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( MESSAGE [ n -> ] gibt die Meldung Nummer n auf die Standardausgabe aus. )
;( Hat die User-Variable WARNING einen Wert ungleich Null, so ist dies der )
;( Inhalt der n-ten Zeile relativ zur Zeile 0 in Screen 4, Laufwerk 0. )
;( ========================================================================= )
NFA_MESSAGE .CBYTE $87, "MESSAGE"
LFA_MESSAGE .WORD NFA_MMOD
CFA_MESSAGE .WORD DOCOL
PFA_MESSAGE
.WORD CFA_BRAKETDOTQUOTE ; (.")
.BYTE 6,"MSG # "
.WORD CFA_DOT ; .
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ' <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ' [ -> addr ] ermittelt die PFA des folgenden Wortes. Im Compile-Mode )
;( wird die PFA des folgenden Wortes zusammen mit einem LIT kompiliert. )
;( ========================================================================= )
;
; : '
; -FIND ( Wort im Dictionary suchen )
; 0= 0 ?ERROR ( Fehlermeldung ausgeben, falls nicht gefunden )
; DROP ( Count-Byte des Wortes vergessen )
; [COMPILE] LITERAL ( PFA auf dem Stack lassen oder mit LIT kompilieren )
; ; IMMEDIATE
NFA_TICK .BYTE $81+$40, 167 ; IMMEDIATE
LFA_TICK .WORD NFA_MESSAGE
CFA_TICK .WORD DOCOL
PFA_TICK
.WORD CFA_MINUSFIND ; -FIND
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_0 ; 0
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_DROP ; DROP
.WORD CFA_LITERAL ; LITERAL
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> FORGET <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( FORGET [ ] loescht alle Woerter ab dem im Input-Strom folgenden aus dem )
;( Dictionary. Sind das Current- und das Context-Vokabular nicht identisch, )
;( so wird eine Fehlermeldung ausgegeben. )
;( ========================================================================= )
;
; : FORGET
; CURRENT @ CONTEXT @ - 24 ?ERROR ( Fehlermeldung falls CURRENT<>CONTEXT )
; [COMPILE] ' ( PFA des folgenden Wortes )
; DUP FENCE @ < 21 ?ERROR ( Fehlermeldung falls geschuetzt )
; DUP NFA DP ! ( Dictionary-Pointer herabsetzen )
; LFA @ CURRENT @ ! ( jetzt letztes Wort im Curr.-V. merken )
; ;
NFA_FORGET .CBYTE $86,"FORGET"
LFA_FORGET .WORD NFA_TICK
CFA_FORGET .WORD DOCOL
PFA_FORGET
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_FETCH ; @
.WORD CFA_CONTEXT ; CONTEXT
.WORD CFA_FETCH ; @
.WORD CFA_MINUS ; -
.WORD CFA_CLIT ; CLIT
.BYTE 24
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_TICK ; '
.WORD CFA_DUP ; DUP
.WORD CFA_FENCE ; FENCE
.WORD CFA_FETCH ; @
.WORD CFA_LT ; <
.WORD CFA_CLIT ; CLIT
.BYTE 21
.WORD CFA_QUERYERROR ; ?ERROR
.WORD CFA_DUP ; DUP
.WORD CFA_NFA ; NFA
.WORD CFA_DP ; DP
.WORD CFA_STORE ; !
.WORD CFA_LFA ; LFA
.WORD CFA_FETCH ; @
.WORD CFA_CURRENT ; CURRENT
.WORD CFA_FETCH ; @
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> BACK <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( BACK [ addr -> ] kompiliert die Distanz von HERE nach addr in das )
;( Dictionary. )
;( ========================================================================= )
;
; : BACK HERE - , ;
NFA_BACK .CBYTE $84,"BACK"
LFA_BACK .WORD NFA_FORGET
CFA_BACK .WORD DOCOL
PFA_BACK
.WORD CFA_HERE ; HERE
.WORD CFA_MINUS ; -
.WORD CFA_COMMA ; ,
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> BEGIN <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( BEGIN [ -> addr n ] legt die aktuelle Adresse HERE und die Strukturken- )
;( nung n=1 auf den Stack. Das Wort wird innerhalb von Colon-Definitionen )
;( verwendet und leitet eine der Strukturen BEGIN...UNTIL, BEGIN...AGAIN )
;( oder BEGIN...WHILE...REPEAT ein. )
;( ========================================================================= )
;
; : BEGIN ?COMP HERE 1 ; IMMEDIATE
NFA_BEGIN .CBYTE $85+$40,"BEGIN" ; IMMEDIATE
LFA_BEGIN .WORD NFA_BACK
CFA_BEGIN .WORD DOCOL
PFA_BEGIN
.WORD CFA_QUERYCOMP ; ?COMP
.WORD CFA_HERE ; HERE
.WORD CFA_1 ; 1
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ENDIF <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ENDIF [ addr n -> ] korrigiert die in der Adresse addr angelegte proviso- )
;( rische Sprungdistanz auf ihren korrekten Wert, naemlich nach HERE. Eine )
;( Fehlermeldung wird ausgegeben, wenn die Strukturkennung n<>2 ist und )
;( somit kein IF-Konstrukt abgeschlossen wurde. )
;( ========================================================================= )
;
; : ENDIF
; ?COMP ( Fehlermeldung falls nicht Compile-Mode )
; 2 ?PAIRS ( Fehlermeldung falls kein IF-Konstrukt abgeschlossen wurde )
; HERE OVER - ( Sprungdistanz berechnen )
; SWAP ! ( und in die durch addr bezeichnete Zelle eintragen )
; ; IMMEDIATE
NFA_ENDIF .CBYTE $85+$40, "ENDIF" ; IMMEDIATE
LFA_ENDIF .WORD NFA_BEGIN
CFA_ENDIF .WORD DOCOL
PFA_ENDIF
.WORD CFA_QUERYCOMP ; ?COMP
.WORD CFA_2 ; 2
.WORD CFA_QUERYPAIRS ; ?PAIRS
.WORD CFA_HERE ; HERE
.WORD CFA_OVER ; OVER
.WORD CFA_MINUS ; -
.WORD CFA_SWAP ; SWAP
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> THEN <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( THEN [ addr n -> ] ist ein Alias fuer ENDIF. )
;( ========================================================================= )
;
; : THEN [COMPILE] ENDIF ; IMMEDIATE
NFA_THEN .CBYTE $84+$40, "THEN" ; IMMEDIATE
LFA_THEN .WORD NFA_ENDIF
CFA_THEN .WORD DOCOL
PFA_THEN
.WORD CFA_ENDIF ; ENDIF
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> DO <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DO [ -> addr n ] legt die aktuelle Adresse HERE und die Strukturkennung )
;( n=3 auf den Stack und kompiliert ein [DO] in das Dictionary. Das Wort )
;( wird innerhalb von Colon-Definitionen verwendet und leitet eine der )
;( beiden Strukturen DO...LOOP oder DO...+LOOP ein. )
;( ========================================================================= )
;
; : DO
; COMPILE (DO) ( Runtime-Exekutive [DO] kompilieren )
; HERE 3 ( Adresse HERE und Strukturkennung n=3 auf den Stack legen )
; ; IMMEDIATE
NFA_DO .CBYTE $82+$40, "DO" ; IMMEDIATE
LFA_DO .WORD NFA_THEN
CFA_DO .WORD DOCOL
PFA_DO
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRACKETDO ; (DO)
.WORD CFA_HERE ; HERE
.WORD CFA_3 ; 3
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> LOOP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( LOOP [ addr n -> ] kompiliert die Runtime-Exekutive [LOOP] zusammen mit )
;( einer Ruecksprung-Distanz nach addr in das Dictionary und ueberprueft, ob )
;( die Strukturkennung n=3 uebergeben und somit eine DO-Struktur korrekt )
;( abgeschlossen wurde. )
;( ========================================================================= )
;
; : LOOP
; 3 ?PAIRS ( Fehler falls kein DO-Konstrukt abgeschlossen wurde )
; COMPILE (LOOP) ( Runtime-Exekutive [LOOP] kompilieren )
; BACK ( Ruecksprung-Distanz kompilieren )
; ; IMMEDIATE
NFA_LOOP .CBYTE $84+$40,"LOOP" ; IMMEDIATE
LFA_LOOP .WORD NFA_DO
CFA_LOOP .WORD DOCOL
PFA_LOOP
.WORD CFA_3 ; 3
.WORD CFA_QUERYPAIRS ; ?PAIRS
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRACKETLOOP ; (LOOP)
.WORD CFA_BACK ; BACK
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> +LOOP <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( +LOOP [ addr n -> ] kompiliert die Runtime-Exekutive [+LOOP] zusammen mit )
;( einer Ruecksprung-Distanz nach addr in das Dictionary und ueberprueft, ob )
;( die Strukturkennung n=3 uebergeben und somit eine DO-Struktur korrekt )
;( abgeschlossen wurde. )
;( ========================================================================= )
;
; : +LOOP
; 3 ?PAIRS ( Fehler falls kein DO-Konstrukt abgeschlossen wurde )
; COMPILE (+LOOP) ( Runtime-Exekutive [+LOOP] kompilieren )
; BACK ( Ruecksprung-Distanz kompilieren )
; ; IMMEDIATE
NFA_ADDLOOP .CBYTE $85+$40, "+LOOP" ; IMMEDIATE
LFA_ADDLOOP .WORD NFA_LOOP
CFA_ADDLOOP .WORD DOCOL
PFA_ADDLOOP
.WORD CFA_3 ; 3
.WORD CFA_QUERYPAIRS ; ?PAIRS
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRACKETPLUSLOOP ; (+LOOP)
.WORD CFA_BACK ; BACK
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> UNTIL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( UNTIL [ addr n -> ] kompiliert einen bedingten Ruecksprung nach Adresse )
;( addr in das Dictionary und ueberprueft, ob die Strukturkennung n=1 ueber- )
;( geben und somit eine BEGIN-Struktur korrekt abgeschlossen wurde. )
;( ========================================================================= )
;
; : UNTIL
; 1 ?PAIRS ( Fehler falls kein BEGIN-Konstrukt abgeschlossen wurde )
; COMPILE 0BRANCH ( bedingten Sprung kompilieren )
; BACK ( Ruecksprung-Distanz kompilieren )
; ; IMMEDIATE
NFA_UNTIL .CBYTE $85+$40, "UNTIL" ; IMMEDIATE
LFA_UNTIL .WORD NFA_ADDLOOP
CFA_UNTIL .WORD DOCOL
PFA_UNTIL
.WORD CFA_1 ; 1
.WORD CFA_QUERYPAIRS ; ?PAIRS
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_0BRANCH ; 0BRANCH
.WORD CFA_BACK ; BACK
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> END <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( END [ addr n -> ] ist ein Alias fuer UNTIL. )
;( ========================================================================= )
;
; : END [COMPILE] UNTIL ; IMMEDIATE
NFA_END .CBYTE $83+$40, "END" ; IMMEDIATE
LFA_END .WORD NFA_UNTIL
CFA_END .WORD DOCOL
PFA_END
.WORD CFA_UNTIL ; UNTIL
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> AGAIN <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( AGAIN [ addr n -> ] kompiliert einen unbedingten Ruecksprung nach Adresse )
;( addr in das Dictionary und ueberprueft, ob die Strukturkennung n=1 ueber- )
;( geben und somit eine BEGIN-Struktur korrekt abgeschlossen wurde. )
;( ========================================================================= )
;
; : AGAIN
; 1 ?PAIRS ( Fehler falls kein BEGIN-Konstrukt abgeschlossen wurde )
; COMPILE BRANCH ( unbedingten Sprung kompilieren )
; BACK ( Ruecksprung-Distanz kompilieren )
; ; IMMEDIATE
NFA_AGAIN .CBYTE $85+$40,"AGAIN" ; IMMEDIATE
LFA_AGAIN .WORD NFA_END
CFA_AGAIN .WORD DOCOL
PFA_AGAIN
.WORD CFA_1 ; 1
.WORD CFA_QUERYPAIRS ; ?PAIRS
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRANCH ; BRANCH
.WORD CFA_BACK ; BACK
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> REPEAT <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( REPEAT [ addr1 n1 addr2 n2 -> ] kompiliert einen unbedingten Ruecksprung )
;( nach Adresse addr1 in das Dictionary und korrigiert die Sprungdistanz bei )
;( Adresse addr2 derart, dass hinter den soeben kompilierten Sprung gesprun- )
;( gen wird. Darueberhinaus wird ueberprueft, ob mit n1=1 ein BEGIN- )
;( Konstrukt abgeschlossen wurde, der wegen n2=4 ein WHILE enthielt. )
;( ========================================================================= )
;
; : REPEAT
; >R >R ( addr2 und n2 auf den Return-Stack retten )
; [COMPILE] AGAIN ( unbedingten Ruecksprung nach addr1 kompilieren )
; R> R> ( addr2 und n2 zurueckholen )
; 2 - [COMPILE] ENDIF ( Vorwaertssprung bei Adresse addr2 korrigieren )
; ; IMMEDIATE
NFA_REPEAT .CBYTE $86+$40, "REPEAT" ; IMMEDITE
LFA_REPEAT .WORD NFA_AGAIN
CFA_REPEAT .WORD DOCOL
PFA_REPEAT
.WORD CFA_RPUSH ; >R
.WORD CFA_RPUSH ; >R
.WORD CFA_AGAIN ; AGAIN
.WORD CFA_RPOP ; R>
.WORD CFA_RPOP ; R>
.WORD CFA_2 ; 2
.WORD CFA_MINUS ; -
.WORD CFA_ENDIF ; ENDIF
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> IF <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( IF [ -> addr n ] kompiliert einen bedingten Sprung mit noch provisori- )
;( scher Sprungdistanz und legt die Adresse, an der die Distanz steht, sowie )
;( die Strukturkennung n=2 auf den Stack. Das Wort wird in Colon-Definitio- )
;( nen zur Einleitung eines IF...ENDIF- oder IF...ELSE...ENDIF-Konstruktes )
;( benutzt. )
;( ========================================================================= )
;
; : IF
; COMPILE 0BRANCH ( bedingten Sprung kompilieren )
; HERE ( Adresse addr, an der die Distanz steht )
; 0 , ( provisorische Sprungdistanz kompilieren )
; 2 ( Strukturkennung n=2 )
; ; IMMEDIATE
NFA_IF .CBYTE $82+$40,"IF" ; IMMEDIATE
LFA_IF .WORD NFA_REPEAT
CFA_IF .WORD DOCOL
PFA_IF
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_0BRANCH ; 0BRANCH
.WORD CFA_HERE ; HERE
.WORD CFA_0 ; 0
.WORD CFA_COMMA ; ,
.WORD CFA_2 ; 2
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ELSE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ELSE [ addr1 n1 -> addr2 n2 ] kompiliert einen unbedingten Sprung mit )
;( noch provisorischer Sprungdistanz und korrigiert die Sprungdistanz in )
;( addr1 derart, dass hinter den soeben kompilierten Sprung gesprungen wird. )
;( Darueberhinaus wird ueberprueft, ob mit n1=2 ein IF-Konstrukt um einen )
;( ELSE-Zweig ergaenzt wurde. Auf dem Stack werden die Adresse addr2, an der )
;( sich die soeben kompilierte provisorische Distanz befindet, und die )
;( Strukturkennung n2=2 hinterlassen. )
;( ========================================================================= )
;
; : ELSE
; 2 ?PAIRS ( Fehler falls kein IF-Konstrukt )
; COMPILE BRANCH ( unbedingten Sprung kompilieren )
; HERE ( Adresse addr2, an der die Distanz steht )
; 0 , ( provisorische Distanz kompilieren )
; SWAP 2 [COMPILE] ENDIF ( Sprungdistanz bei addr1 korrigieren )
; 2 ( Strukturkennung n2=2 )
; ; IMMEDIATE
NFA_ELSE .CBYTE $84+$40,"ELSE" ; IMMEDIATE
LFA_ELSE .WORD NFA_IF
CFA_ELSE .WORD DOCOL
PFA_ELSE
.WORD CFA_2 ; 2
.WORD CFA_QUERYPAIRS ; ?PAIRS
.WORD CFA_COMPILE ; COMPILE
.WORD CFA_BRANCH ; BRANCH
.WORD CFA_HERE ; HERE
.WORD CFA_0 ; 0
.WORD CFA_COMMA ; ,
.WORD CFA_SWAP ; SWAP
.WORD CFA_2 ; 2
.WORD CFA_ENDIF ; ENDIF
.WORD CFA_2 ; 2
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> WHILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( WHILE [ -> addr n ] kompiliert einen bedingten Vorwaertssprung mit noch )
;( provisorischer Sprungdistanz und hinterlaesst auf dem Stack die Adresse )
;( addr, an der die provisorische Sprungdistanz steht, und die Strukturken- )
;( nung n=4. )
;( ========================================================================= )
;
; : WHILE [COMPILE] IF 2+ ; IMMEDIATE
NFA_WHILE .CBYTE $85+$40, "WHILE" ; IMMEDIATE
LFA_WHILE .WORD NFA_ELSE
CFA_WHILE .WORD DOCOL
PFA_WHILE
.WORD CFA_IF ; IF
.WORD CFA_2PLUS ; 2+
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> SPACES <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SPACES [ n -> ] gibt n Spaces auf die Standardausgabe aus. )
;( ========================================================================= )
;
; : SPACES
; 0 MAX -DUP IF ( falls n>0 ist: )
; 0 DO ( wiederhole n-mal: )
; SPACE ( Blank ausgeben )
; LOOP
; ENDIF
; ;
NFA_SPACES .CBYTE $86,"SPACES"
LFA_SPACES .WORD NFA_WHILE
CFA_SPACES .WORD DOCOL
PFA_SPACES
.WORD CFA_0 ; 0
.WORD CFA_MAX ; MAX
.WORD CFA_MINUSDUP ; -DUP
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL50-*
.WORD CFA_0 ; 0
.WORD CFA_BRACKETDO ; (DO)
LBL51
.WORD CFA_SPACE ; SPACE
.WORD CFA_BRACKETLOOP ; (LOOP)
.WORD LBL51-*
LBL50
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> <# <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( <# [ ] leitet die Umwandlung einer doppeltgenauen Zahl in einen String, )
;( der von PAD-1 an abwaerts erzeugt wird, ein. )
;( ========================================================================= )
;
; : <# PAD HLD ! ; ( Laufzeiger HLD initialisieren )
NFA_LTSHARP .CBYTE $82,"<#"
LFA_LTSHARP .WORD NFA_SPACES
CFA_LTSHARP .WORD DOCOL
PFA_LTSHARP
.WORD CFA_PAD ; PAD
.WORD CFA_HLD ; HLD
.WORD CFA_STORE ; !
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> #> <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( #> [ ud -> addr n ] beendet die Umwandlung einer doppeltgenauen Zahl in )
;( einen String und uebergibt seine Startadresse addr und seine Laenge n. )
;( ========================================================================= )
;
; : #>
; DROP DROP ( evtl. noch vorhandenen Rest ud vergessen )
; HLD @ ( Startadresse addr des Strings )
; PAD OVER - ( Laenge n des Strings )
; ;
NFA_SHARPGT .CBYTE $82,"#>"
LFA_SHARPGT .WORD NFA_LTSHARP
CFA_SHARPGT .WORD DOCOL
PFA_SHARPGT
.WORD CFA_DROP ; DROP
.WORD CFA_DROP ; DROP
.WORD CFA_HLD ; HLD
.WORD CFA_FETCH ; @
.WORD CFA_PAD ; PAD
.WORD CFA_OVER ; OVER
.WORD CFA_MINUS ; -
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> SIGN <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( SIGN [ n d -> d ] fuegt an den im Aufbau befindlichen Zahlenstring ein )
;( Minuszeichen an, falls n negativ ist. Die doppeltgenaue Zahl d bleibt )
;( unveraendert. )
;( ========================================================================= )
;
; : SIGN
; ROT 0< IF ( falls n<0 ist: )
; 45 HOLD ( Zeichen "-" an den String anfuegen )
; ENDIF
; ;
NFA_SIGN .CBYTE $84,"SIGN"
LFA_SIGN .WORD NFA_SHARPGT
CFA_SIGN .WORD DOCOL
PFA_SIGN
.WORD CFA_ROT ; ROT
.WORD CFA_LTNULL ; 0<
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL52-*
.WORD CFA_CLIT ; CLIT
.BYTE 45
.WORD CFA_HOLD ; HOLD
LBL52
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> # <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( # [ ud1 -> ud2 ] ermittelt aus der vorzeichenlosen, ganzen Zahl die )
;( niederwertigste Ziffer und fuegt sie an den im Aufbau befindlichen )
;( Zahlenstring an. Der verbleibende Rest ud2 wird auf dem Stack uebergeben. )
;( ========================================================================= )
;
; : #
; BASE @ M/MOD ( einfachgenaue Ziffer und doppeltgenauen Rest ermitteln )
; ROT ( Ziffer nach vorne holen )
; 9 OVER < IF ( falls Ziffer groesser als 9 ist: )
; 7 + ( 7 addieren, um im Buchstabenbereich zu landen )
; ENDIF
; 48 + ( "0" addieren; ergibt Ziffer als ASCII-Zeichen )
; HOLD ( Ziffer an den String anfuegen )
; ;
NFA_SHARP .CBYTE $81,"#"
LFA_SHARP .WORD NFA_SIGN
CFA_SHARP .WORD DOCOL
PFA_SHARP
.WORD CFA_BASE ; BASE
.WORD CFA_FETCH ; @
.WORD CFA_MMOD ; M/MOD
.WORD CFA_ROT ; ROT
.WORD CFA_CLIT ; CLIT
.BYTE 9
.WORD CFA_OVER ; OVER
.WORD CFA_LT ; <
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL53-*
.WORD CFA_CLIT ; CLIT
.BYTE 7
.WORD CFA_PLUS ; +
LBL53
.WORD CFA_CLIT ; CLIT
.BYTE 48
.WORD CFA_PLUS ; +
.WORD CFA_HOLD ; HOLD
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> #S <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( #S [ ud1 -> ud2 ] fuegt solange Ziffern an den im Aufbau befindlichen )
;( Zahlenstring an, bis der Rest, der als ud2 uebergeben wird, 0 geworden )
;( ist. )
;( ========================================================================= )
;
; : #S
; BEGIN
; # ( eine Ziffer erzeugen und an den String anfuegen )
; OVER OVER OR 0= ( solange bis der verbleibende Rest 0 geworden ist )
; UNTIL
; ;
NFA_SHARPS .CBYTE $82,"#S"
LFA_SHARPS .WORD NFA_SHARP
CFA_SHARPS .WORD DOCOL
PFA_SHARPS
LBL54
.WORD CFA_SHARP ; #
.WORD CFA_OVER ; OVER
.WORD CFA_OVER ; OVER
.WORD CFA_OR ; OR
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL54-*
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> D.R <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( D.R [ d n -> ] gibt die doppeltgenaue Zahl d rechtsbuendig in einem Feld )
;( der Breite n auf die Standardausgabe aus. )
;( ========================================================================= )
;
; : D.R
; >R ( Feldbreite n auf den Return-Stack retten )
; SWAP OVER ( [ hi d ] erzeugen; hi enthaelt das Vorzeichen von d )
; DABS ( absoluten Betrag von d ermitteln )
; <# #S SIGN #> ( d in einen String umwandeln und Vorzeichen beruecks. )
; R> OVER - SPACES ( zunaechst entsprechend viele Blanks ausgeben )
; TYPE ( anschliessend erzeugten String ausgeben )
; ;
NFA_DDOTR .CBYTE $83, "D.R"
LFA_DDOTR .WORD NFA_SHARPS
CFA_DDOTR .WORD DOCOL
PFA_DDOTR
.WORD CFA_RPUSH ; >R
.WORD CFA_SWAP ; SWAP
.WORD CFA_OVER ; OVER
.WORD CFA_DABS ; DABS
.WORD CFA_LTSHARP ; <#
.WORD CFA_SHARPS ; #S
.WORD CFA_SIGN ; SIGN
.WORD CFA_SHARPGT ; #>
.WORD CFA_RPOP ; R>
.WORD CFA_OVER ; OVER
.WORD CFA_MINUS ; -
.WORD CFA_SPACES ; SPACES
.WORD CFA_TYPE ; TYPE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> .R <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( .R [ n1 n2 -> ] gibt die Zahl n1 rechtsbuendig in einem Feld der Breite )
;( n2 auf die Standardausgabe aus. )
;( ========================================================================= )
;
; : .R >R S>D R> D.R ; ( Zahl n1 doppeltgenau machen und mit D.R ausgeben )
NFA_DOTR .CBYTE $82,".R"
LFA_DOTR .WORD NFA_DDOTR
CFA_DOTR .WORD DOCOL
PFA_DOTR
.WORD CFA_RPUSH ; >R
.WORD CFA_STOD ; S>D
.WORD CFA_RPOP ; R>
.WORD CFA_DDOTR ; D.R
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> D. <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( D. [ d -> ] gibt die doppeltgenaue Zahl d auf die Standardausgabe aus. )
;( ========================================================================= )
; : D. 0 D.R SPACE ; ( Zahl in einem Feld der Breite 0 ausgeben )
NFA_DDOT .CBYTE $82,"D."
LFA_DDOT .WORD NFA_DOTR
CFA_DDOT .WORD DOCOL
PFA_DDOT
.WORD CFA_0 ; 0
.WORD CFA_DDOTR ; D.R
.WORD CFA_SPACE ; SPACE
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> . <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( . [ n -> ] gibt die Zahl n auf die Standardausgabe aus. )
;( ========================================================================= )
;
;: . S>D D. ; ( Zahl n doppeltgenau machen und mit D. ausgeben )
NFA_DOT .CBYTE $81,"."
LFA_DOT .WORD NFA_DDOT
CFA_DOT .WORD DOCOL
PFA_DOT
.WORD CFA_STOD ; S>D
.WORD CFA_DDOT ; D.
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> ? <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( ? [ addr -> ] gibt die Zahl, die an der Adresse addr gespeicher ist, aus. )
;( ========================================================================= )
;
;: ? @ . ;
NFA_QUEST .CBYTE $81, "?"
LFA_QUEST .WORD NFA_DOT
CFA_QUEST .WORD DOCOL
PFA_QUEST
.WORD CFA_FETCH ; @
.WORD CFA_DOT ; .
.WORD CFA_EXIT ; ;S
; >>>>>>>>>>>>>>>> U. <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( U. [ u -> ] gibt die vorzeichenlose Zahl u auf die Standardausgabe aus. )
;( ========================================================================= )
; : U. 0 D. ; ( Zahl vorzeichenlos doppeltgenau machen und mit D. ausgeben )
NFA_UDOT .CBYTE $82,"U."
LFA_UDOT .WORD NFA_QUEST
CFA_UDOT .WORD DOCOL
PFA_UDOT
.WORD CFA_0 ; 0
.WORD CFA_DDOT ; D.
.WORD CFA_EXIT ; ;S
PREVLINK .= NFA_UDOT
;( ========================================================================= )
;( Definition diverser Konstanten und Variablen, die zur Verwaltung des )
;( Disk-Systems benoetigt werden. )
;( ========================================================================= )
; >>>>>>>>>>>>>>>> C/L <<<<<<<<<<<<<<<<
; 64 CONSTANT C/L ( Zeichen pro Eingabezeile )
NFA_C_L .CBYTE $83, "C/L"
LFA_C_L .WORD PREVLINK
CFA_C_L .WORD DOCON
PFA_C_L .WORD 32
PREVLINK .= NFA_C_L
; >>>>>>>>>>>>>>>> CALL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CALL Sprung zur ASM Subroutine )
;( ========================================================================= )
NFA_CALL .CBYTE $84, "CALL"
LDA_CALL .WORD PREVLINK
CFA_CALL .WORD PFA_CALL
PFA_CALL
STX XSAVE
LDA 0,X
STA PFA_CALL1
LDA 1,X
STA PFA_CALL1+1
.BYTE $20 ; JSR
PFA_CALL1
.WORD 0
LDX XSAVE
STA 0,X
STY 1,X
JMP NEXT
PREVLINK .= NFA_CALL
; >>>>>>>>>>>>>>>> WORDS <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( WORDS [ ] gibt die Namen aller Worte, beginnend beim Context-Volabular, )
;( auf die Standardausgabe aus. Die Ausgabe kann mit einer beliebigen Taste )
;( abgebrochen werden. )
;( ========================================================================= )
;: WORDS
; 128 OUT ! ( Initialisierung, damit zu Anfang ein CR erfolgt )
; CONTEXT @ @ ( NFA des letzten Wortes im Context-Vokabular )
; BEGIN
; OUT @ C/L > IF ( falls Zeilenende ueberschritten wurde: )
; CR ( in neue Zeile gehen )
; 0 OUT ! ( Ausgabe in Spalte 0 der neuen Zeile beginnen )
; ENDIF
; DUP ID. SPACE SPACE ( Namen des aktuellen Wortes ausgeben )
; PFA LFA @ ( NFA des naechsten Wortes ermitteln )
; DUP 0= ?TERMINAL OR ( Ende der Linkerkette oder Taste gedrueckt? )
; UNTIL ( ja dann fertig, sonst weiter ausgeben )
; DROP ( letzte NFA vergessen )
;
NFA_WORDS .CBYTE $85, "WORDS"
LFA_WORDS .WORD PREVLINK
CFA_WORDS .WORD DOCOL
PFA_WORDS
.WORD CFA_CLIT ; CLIT
.BYTE 128
.WORD CFA_OUT ; OUT
.WORD CFA_STORE ; !
.WORD CFA_CONTEXT ; CONTEXT
.WORD CFA_FETCH ; @
.WORD CFA_FETCH ; @
LBL74
.WORD CFA_OUT ; OUT
.WORD CFA_FETCH ; @
.WORD CFA_C_L ; C/L
.WORD CFA_GT ; >
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL75-*
.WORD CFA_CR ; CR
.WORD CFA_0 ; 0
.WORD CFA_OUT ; OUT
.WORD CFA_STORE ; !
LBL75
.WORD CFA_DUP ; DUP
.WORD CFA_IDDOT ; ID.
;.WORD CFA_SPACE ; SPACE
;.WORD CFA_SPACE ; SPACE
.WORD CFA_PFA ; PFA
.WORD CFA_LFA ; LFA
.WORD CFA_FETCH ; @
.WORD CFA_DUP ; DUP
.WORD CFA_NULLEQUAL ; 0=
.WORD CFA_QUERYTERMINAL ; ?TERMINAL
.WORD CFA_OR ; OR
.WORD CFA_0BRANCH ; 0BRANCH
.WORD LBL74-*
.WORD CFA_DROP ; DROP
.WORD CFA_EXIT ; ;S
PREVLINK .= NFA_WORDS
.IF FILE
;( ========================================================================= )
;( Definitionen fuer Dateibefehle )
;( ========================================================================= )
FAM_R = 4
FAM_W = 8
FAM_RW = FAM_R + FAM_W
IO_OPEN = $3
IO_GETREC = $5
IO_GETCHR = $7
IO_PUTREC = $9
IO_PUTCHR = $B
IO_CLOSE = $C
ICFLG = $340
ICCOM = $342
ICSTA = $343
ICBAL = $344
ICBAH = $345
ICBLL = $348
ICBLH = $349
ICAX1 = $34A
ICAX2 = $34B
CIOV = $E456
;( ========================================================================= )
;( Hilfsroutinen fuer die Dateibefehle )
;( ========================================================================= )
GETFILEID
LDA 0,X ; get fileid
GETFILEID0
ASL
ASL
ASL
ASL
TAY
RTS
JCIOV
STX XSAVE
TYA
TAX
JSR CIOV
TXA
TAY
LDX XSAVE
RTS
;( ========================================================================= )
;( Hilfswoerter fuer die Dateibefehle )
;( ========================================================================= )
; >>>>>>>>>>>>>>>> R/O <<<<<<<<<<<<<<<<
; CONSTANT R/O 4
NFA_RO .CBYTE $83, "R/O"
LFA_RO .WORD PREVLINK
CFA_RO .WORD DOCON
PFA_RO .WORD FAM_R
PREVLINK .= NFA_RO
; >>>>>>>>>>>>>>>> R/W <<<<<<<<<<<<<<<<
; CONSTANT R/O 12
NFA_RW .CBYTE $83, "R/W"
LFA_RW .WORD PREVLINK
CFA_RW .WORD DOCON
PFA_RW .WORD FAM_RW
PREVLINK .= NFA_RW
; >>>>>>>>>>>>>>>> W/O <<<<<<<<<<<<<<<<
; CONSTANT R/O 8
NFA_WO .CBYTE $83, "W/O"
LFA_WO .WORD PREVLINK
CFA_WO .WORD DOCON
PFA_WO .WORD FAM_W
PREVLINK .= NFA_WO
; >>>>>>>>>>>>>>>> CIO <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CIO [ ] Schnittstelle zur ATARI CIO )
;( ========================================================================= )
NFA_CIO .CBYTE $83, "CIO"
LDA_CIO .WORD PREVLINK
CFA_CIO .WORD PFA_CIO
PFA_CIO
JMP NEXT
PREVLINK .= NFA_CIO
; >>>>>>>>>>>>>>>> FREEIOCB <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( FreeIOCB [ -- freeiocb ] ermittelt naechsten freien IOCB )
;( ========================================================================= )
NFA_FREEIOCB .CBYTE $88, "FREEIOCB"
LDA_FREEIOCB .WORD PREVLINK
CFA_FREEIOCB .WORD PFA_FREEIOCB
PFA_FREEIOCB
JSR FREEIOCB0
LSR A
LSR A
LSR A
LSR A ; div 16
PHA ; iocb und
LDA #0 ; highbyte
JMP PUSH ; auf den Datenstack legen
FREEIOCB0
LDA #$70 ; bei IOCB 7 anfangen
L_FREEIOCB2
TAY
LDA ICFLG,Y ; Flag holen und
CMP #$FF
BEQ L_FREEIOCB1 ; testen ob frei (ICFLG = $FF)
TYA ; nicht frei!
SEC
SBC #$10
BNE L_FREEIOCB2
L_FREEIOCB1
TYA
RTS
PREVLINK .= NFA_FREEIOCB
; >>>>>>>>>>>>>>>> CLOSE-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CLOSE-FILE [fileid -- ior ] Datei schliessen )
;( ========================================================================= )
NFA_CLOSEFILE .CBYTE $8A, "CLOSE-FILE"
LDA_CLOSEFILE .WORD PREVLINK
CFA_CLOSEFILE .WORD PFA_CLOSEFILE
PFA_CLOSEFILE
JSR GETFILEID
LDA #IO_CLOSE
STA ICCOM,Y
JSR JCIOV
LDA ICSTA,Y
BMI CLOSEFILE1
LDA #0
CLOSEFILE1
PHA
LDA #0 ; Store ior highbyte
JMP PUT
PREVLINK .= NFA_CLOSEFILE
; >>>>>>>>>>>>>>>> CREATE-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( CREATE-FILE [caddr u fam -- ior ] Datei anlegen )
;( ========================================================================= )
NFA_CREATEFILE .CBYTE $8B, "CREATE-FILE"
LDA_CREATEFILE .WORD PREVLINK
CFA_CREATEFILE .WORD PFA_CREATEFILE
PFA_CREATEFILE
JMP NEXT
PREVLINK .= NFA_CREATEFILE
; >>>>>>>>>>>>>>>> DELETE-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( DELETE-FILE [caddr u -- ior ] Datei loeschen )
;( ========================================================================= )
NFA_DELETEFILE .CBYTE $8B, "DELETE-FILE"
LDA_DELETEFILE .WORD PREVLINK
CFA_DELETEFILE .WORD PFA_DELETEFILE
PFA_DELETEFILE
JMP NEXT
PREVLINK .= NFA_DELETEFILE
; >>>>>>>>>>>>>>>> FLUSH-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( FLUSH-FILE [fileid -- ior ] Dateibuffer schreiben )
;( ========================================================================= )
NFA_FLUSHFILE .CBYTE $8A, "FLUSH-FILE"
LDA_FLUSHFILE .WORD PREVLINK
CFA_FLUSHFILE .WORD PFA_FLUSHFILE
PFA_FLUSHFILE
JMP NEXT
PREVLINK .= NFA_FLUSHFILE
; >>>>>>>>>>>>>>>> OPEN-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( OPEN-FILE [caddr u fam -- fileid ior ] Datei oeffnen )
;( ========================================================================= )
NFA_OPENFILE .CBYTE $89, "OPEN-FILE"
LDA_OPENFILE .WORD PREVLINK
CFA_OPENFILE .WORD PFA_OPENFILE
PFA_OPENFILE
JSR FREEIOCB0 ; get free iocb
LDA #IO_OPEN
STA ICCOM,Y
LDA 4,X ; Lowbyte Filename
STA ICBAL,Y
LDA 5,X ; HighByte Filename
STA ICBAH,Y
LDA 0,X ; fam
STA ICAX1,Y
LDA #0
STA ICAX2,Y
JSR JCIOV
INX
INX
LDA ICSTA,Y
STA 0,X
BMI OPENFILE1
DEC 0,X ; ior = 0 = ok
OPENFILE1
LDA #0 ; Store ior
STA 1,X
STA 3,X
; DIV $10
TYA
CLC
LSR A
LSR A
LSR A
LSR A
STA 2,X ; Store fileid
JMP NEXT
PREVLINK .= NFA_OPENFILE
; >>>>>>>>>>>>>>>> RENAME-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( RENAME-FILE [caddr1 u1 caddr2 u2 -- ior ] Datei umbenennen )
;( ========================================================================= )
NFA_RENAMEFILE .CBYTE $8B, "RENAME-FILE"
LDA_RENAMEFILE .WORD PREVLINK
CFA_RENAMEFILE .WORD PFA_RENAMEFILE
PFA_RENAMEFILE
JMP NEXT
PREVLINK .= NFA_RENAMEFILE
; >>>>>>>>>>>>>>>> READ-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( READ-FILE [caddr u1 fileid -- u2 ior ] Datei an Adresse Lesen )
;( ========================================================================= )
NFA_READFILE .CBYTE $89, "READ-FILE"
LDA_READFILE .WORD PREVLINK
CFA_READFILE .WORD PFA_READFILE
PFA_READFILE
JSR GETFILEID
LDA 2,X ; get lowbyte length
STA ICBLL,Y
LDA 3,X ; get highbyte length
STA ICBLH,Y
LDA 4,X ; get lowbyte address
STA ICBAL,Y
LDA 5,X ; get highbyte address
STA ICBAH,Y
LDA #IO_GETCHR ; Get Characters CIO Command
STA ICCOM,Y
JSR JCIOV
INX
INX
LDA ICSTA,Y
STA 0,X
BMI READFILE1
DEC 0,X ; OK, ior = 0
READFILE1
CLC
LDA ICBLL,Y ; get real length
STA 2,X
LDA ICBLH,Y ; get real length
STA 3,X
LDA #0
STA 1,X
JMP NEXT
PREVLINK .= NFA_READFILE
; >>>>>>>>>>>>>>>> READ-LINE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( READ-LINE [caddr u1 fileid -- u2 flag ior ] Datei zeilenweise lesen )
;( ========================================================================= )
NFA_READLINE .CBYTE $89, "READ-LINE"
LDA_READLINE .WORD PREVLINK
CFA_READLINE .WORD PFA_READLINE
PFA_READLINE
JSR GETFILEID
LDA 2,X ; get lowbyte length
STA ICBLL,Y
LDA 3,X ; get highbyte length
STA ICBLH,Y
LDA 4,X ; get lowbyte address
STA ICBAL,Y
LDA 5,X ; get highbyte address
STA ICBAH,Y
LDA #IO_GETREC ; Get Record CIO Command
STA ICCOM,Y
JSR JCIOV
LDA ICSTA,Y
STA 0,X
BMI READLINE1
DEC 0,X ; OK, ior = 0
READLINE1
CLC
LDA ICBLL,Y ; get real length
STA 4,X
ADC ICBAL,Y ; calculate end of string
STA 2,X
DEC 2,X
LDA ICBLH,Y
STA 5,X
ADC ICBAH,Y
STA 3,X
LDA #0
STA (2,X)
STA 1,X
STA 2,X ; store flag = true
STA 3,X
JMP NEXT
PREVLINK .= NFA_READLINE
; >>>>>>>>>>>>>>>> REFILL <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( REFILL [ fileid -- flag ] Eingabebuffer fuellen )
;( ========================================================================= )
; : REFILL
; TIB @ 128 SOURCE-ID @ READ-LINE SWAP IN ! SWAP DROP
; ;
NFA_REFILL .CBYTE $86, "REFILL"
LDA_REFILL .WORD PREVLINK
CFA_REFILL .WORD DOCOL
PFA_REFILL
.WORD CFA_TIB
.WORD CFA_FETCH ; get Terminal Input Buffer (TIB)
.WORD CFA_LIT
.WORD $80 ; 80 Char. max
.WORD CFA_SOURCEID
.WORD CFA_FETCH ; get Channel
.WORD CFA_READLINE
.WORD CFA_SWAP
.WORD CFA_IN
.WORD CFA_STORE
.WORD CFA_SWAP
.WORD CFA_DROP
.WORD CFA_EXIT
PREVLINK .= NFA_REFILL
; >>>>>>>>>>>>>>>> WRITE-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( WRITE-FILE [caddr u fileid -- ior ] Datei von Adresse schreiben )
;( ========================================================================= )
NFA_WRITEFILE .CBYTE $8A, "WRITE-FILE"
LDA_WRITEFILE .WORD PREVLINK
CFA_WRITEFILE .WORD PFA_WRITEFILE
PFA_WRITEFILE
JSR GETFILEID
LDA #IO_PUTCHR ; Put Characters CIO Command
STA ICCOM,Y
WRITE
LDA 2,X ; get lowbyte length
STA ICBLL,Y
LDA 3,X ; get highbyte length
STA ICBLH,Y
LDA 4,X ; get lowbyte address
STA ICBAL,Y
LDA 5,X ; get highbyte address
STA ICBAH,Y
JSR JCIOV
INX
INX
INX
INX
LDA ICSTA,Y
STA 0,X
BMI WRITEFILE1
DEC 0,X ; OK, ior = 0
WRITEFILE1
LDA #0
STA 1,X
JMP NEXT
PREVLINK .= NFA_WRITEFILE
; >>>>>>>>>>>>>>>> WRITE-LINE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( WRITE-LINE [caddr u fileid -- ior ] Datei zeilenweise schreiben )
;( ========================================================================= )
NFA_WRITELINE .CBYTE $8A, "WRITE-LINE"
LDA_WRITELINE .WORD PREVLINK
CFA_WRITELINE .WORD PFA_WRITELINE
PFA_WRITELINE
JSR GETFILEID
LDA #IO_PUTREC ; Put Record CIO Command
STA ICCOM,Y
JMP WRITE
PREVLINK .= NFA_WRITELINE
; >>>>>>>>>>>>>>>> INCLUDE-FILE <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( INCLUDE-FILE [fileid -- ] Liest und interpretiert Datei aus fileid )
;( ========================================================================= )
; : INCLUDE-FILE
; SOURCE-ID !
; BEGIN
; REFILL
; 128 <
; WHILE
; INTERPRET
; REPEAT
; SOURCE-ID @ CLOSE-FILE
; QUIT ;
NFA_INCLUDEFILE .CBYTE $8C, "INCLUDE-FILE"
LDA_INCLUDEFILE .WORD PREVLINK
CFA_INCLUDEFILE .WORD DOCOL
PFA_INCLUDEFILE
.WORD CFA_SOURCEID ; SOURCE-ID
.WORD CFA_STORE ; !
INCLUDEFILE1 ; BEGIN
.WORD CFA_REFILL ; REFILL
.WORD CFA_LIT ; LITERAL
.WORD $80 ; 128
.WORD CFA_LT ; <
.WORD CFA_0BRANCH ; WHILE
.WORD INCLUDEFILE2-*
.WORD CFA_INTERPRET ; INTERPRET
.WORD CFA_BRANCH
.WORD INCLUDEFILE1-* ; REPEAT
INCLUDEFILE2 ;
.WORD CFA_SOURCEID ; SOURCE-ID
.WORD CFA_FETCH ; @
.WORD CFA_CLOSEFILE ; CLOSE-FILE
.WORD CFA_QUIT ; QUIT
.WORD CFA_EXIT ; S;
PREVLINK .= NFA_INCLUDEFILE
; >>>>>>>>>>>>>>>> INCLUDED <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( INCLUDED [caddr u -- ] Liest und interpretiert Datei - Name an caddr )
;( ========================================================================= )
; : INCLUDED
; R/O
; OPEN-FILE
; 128 < IF
; INCLUDE-FILE
; SOURCE-ID @ CLOSE-FILE
; 0 SOURCE-ID ! ( Input-Buffer SOURCE-ID zuruecksetzen )
; ENDIF
NFA_INCLUDED .CBYTE $88, "INCLUDED"
LDA_INCLUDED .WORD PREVLINK
CFA_INCLUDED .WORD DOCOL
PFA_INCLUDED
.WORD CFA_RO
.WORD CFA_OPENFILE
.WORD CFA_LIT
.WORD $80
.WORD CFA_LT
.WORD CFA_0BRANCH
.WORD INCLUDED1-*
.WORD CFA_INCLUDEFILE
.WORD CFA_SOURCEID
.WORD CFA_FETCH
.WORD CFA_CLOSEFILE
.WORD CFA_0
.WORD CFA_SOURCEID
.WORD CFA_STORE
INCLUDED1
.WORD CFA_EXIT ; S;
PREVLINK .= NFA_INCLUDED
; >>>>>>>>>>>>>>>> FILE" <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( FILE" [ -- u caddr ] Ermittelt Filename im Input Strom )
;( ========================================================================= )
; : FILE"
; 1536 BL BLANKS
; HERE BL BLANKS
; 34 WORD HERE COUNT 1536 SWAP CMOVE
; 1536 0 ;
NFA_FILE .BYTE $85,"FILE",$A2
LDA_FILE .WORD PREVLINK
CFA_FILE .WORD DOCOL
PFA_FILE
.WORD CFA_LIT ;
.WORD 1536 ; $600
.WORD CFA_BL ; BL (32)
.WORD CFA_BLANKS ; BLANKS
.WORD CFA_HERE ; HERE
.WORD CFA_BL ; BL (32)
.WORD CFA_BLANKS ; BLANKS
.WORD CFA_CLIT
.BYTE 34 ; 34 (")
.WORD CFA_WORD ; WORD
.WORD CFA_COUNT ; COUNT
.WORD CFA_LIT
.WORD 1536 ; $600
.WORD CFA_SWAP ; SWAP
.WORD CFA_CMOVE ; CMOVE
.WORD CFA_LIT
.WORD 1536 ; $600
.WORD CFA_0 ; 0
.WORD CFA_EXIT ; S;
PREVLINK .= NFA_FILE
; >>>>>>>>>>>>>>>> INCLUDE" <<<<<<<<<<<<<<<<
;( ========================================================================= )
;( INCLUDE" Liest und interpretiert Datei - Name folgt im Input Strom )
;( ========================================================================= )
; : INCLUDE"
; FILE" INCLUDED ;
; IMMEDIATE
NFA_INCLUDE .BYTE $C8,"INCLUDE",$A2
LDA_INCLUDE .WORD PREVLINK
CFA_INCLUDE .WORD DOCOL
PFA_INCLUDE
.WORD CFA_FILE ; FILE"
.WORD CFA_INCLUDED ; INCLUDED
.WORD CFA_EXIT ; ;S
PREVLINK .= NFA_INCLUDE
.ENDIF ; FILE COMMANDS
; >>>>>>>>>>>>>>>> MON <<<<<<<<<<<<<<<<
NFA_MON .CBYTE $83, "MON"
LFA_MON .WORD PREVLINK
CFA_MON .WORD PFA_MON
PFA_MON
; Im originalen FIG-Listing wird davon ausgegangen, dass das aufrufende
; Programm ein Monitor ist.
STX XSAVE ; Datenstackpointer retten
LDA DOSIN+1 ; Resetvector zurueck
STA DOSINI
LDA DOSIN+2
STA DOSINI+1
JMP (DOSVEC) ; zum DOS zurueckkehren
NOP ; nach BRK wird ein Byte uebersprungen
LDX XSAVE ; Datenstackpointer wiederherstellen
JMP NEXT ; und fertig
NFA_LASTWORD = NFA_MON
;------------------------------------------------------------------------------------------
; Hilfsroutinen
;------------------------------------------------------------------------------------------
GETCH
TYA ; Y Register retten
PHA
JSR GETCHK
TAX
PLA ; Y Register wiederherstellen
TAY
TXA
RTS
GETCHK
LDA $E425 ; PUSH address of GETKEY OS Routine
PHA ; to returnstack
LDA $E424
PHA
RTS
OUTCH
STX XSAVE
TAX
TYA ; Y Register retten
PHA
JSR OUTCHK
PLA ; Y Register wiederherstellen
TAY
LDX XSAVE
RTS
OUTCHK ; in das ATARI OS springen (CIO Routine)
LDA $E407
PHA
LDA $E406
PHA
TXA
RTS
.IF debug
;
; This is a temporary trace routine, to be used until FORTH
; is generally operating. Then NOP the terminal query
; "JSR ONEKEY". This will allow user input to the text
; interpreter. When crashes occur, the display shows IP, W,
; and the word locations of the offending code. When all is
; well, remove : TRACE, TCOLON, PRNAM, DECNP, and the
; following monitor/register equates.
;
;
;
; Monitor routines needed to trace.
;
;XBLANK EQU $D0AF ; print one blank
;CRLF EQU $D0D2 ; print a carriage return and line feed.
;HEX2 EQU $D2CE ; print accum as two hex numbers
;LETTER EQU $D2C1 ; print accum as one ASCII character
;ONEKEY EQU $D1DC ; wait for keystroke
XW = $43 ; scratch reg. to next code field add
NP = $45 ; scratch reg. pointing to name field
;
;
DEBUGFLG .BYTE 0 ; debugflg
DXSAVE .BYTE 0 ; X Register Sicherungsplatz
TRACE STX DXSAVE ; X Register Retten
PHA ; Accu retten
TYA
PHA ; Y Register retten
JSR CRLF
LDA IP+1
JSR HEX2
LDA IP
JSR HEX2 ; print IP, the interpreter pointer
JSR XBLANK
;
;
LDY #0
LDA (IP),Y
STA XW
STA NP ; fetch the next code field pointer
INY
LDA (IP),Y
STA XW+1
STA NP+1
JSR PRNAM ; print dictionary name
;
LDA XW+1
JSR HEX2 ; print code field address
LDA XW
JSR HEX2
JSR XBLANK
;
LDX DXSAVE ; print TOS Cell
LDA 1,X
JSR HEX2
LDX DXSAVE
LDA 0,X
JSR HEX2
JSR XBLANK
;
LDA DXSAVE ; print stack location in zero-page
JSR HEX2
JSR XBLANK
;
LDA #1 ; print return stack bottom in page 1
JSR HEX2
TSX
INX
TXA
JSR HEX2
JSR XBLANK
;
.IF keywait
JSR ONEKEY ; wait for operator keystroke
.ENDIF
LDX DXSAVE ; just to pinpoint early problems
PLA ; Y Register wiederherstellen
TAY
PLA ; Accu wiederherstellen
RTS
;
; TCOLON is called from DOCOLON to label each point
; where FORTH 'nests' one level.
;
TCOLON STX DXSAVE ; X Register retten
PHA ; Accu retten
TYA
PHA ; Y Register retten
LDA W
STA NP ; locate the name of the called word
LDA W+1
STA NP+1
JSR CRLF
LDA #$3A ; ':
JSR LETTER
JSR XBLANK
JSR PRNAM
;@ JSR ONEKEY ; wait for operator keystroke
LDX DXSAVE ; X Register weiderherstellen
PLA
TAY ; Y Register wiederherstellen
PLA ; Accu wiederherstellen
RTS
;
; Print name by it's code field address in NP
;
PRNAM
ysave = $3FF
JSR DECNP
JSR DECNP
JSR DECNP
LDY #0
PN1
JSR DECNP
LDA (NP),Y ; loop till D7 in name set
BPL PN1
PN2 INY
LDA (NP),Y
STY YSAVE
JSR LETTER ; print letters of name field
LDY YSAVE
LDA (NP),Y
BPL PN2
JSR XTAB
LDY #0
RTS
;
; Decrement name field pointer
;
DECNP LDA NP
BNE DECNP1
DEC NP+1
DECNP1 DEC NP
RTS
;
;**********************************************************
; Monitor routines needed to trace.
;
; print a carriage return and line feed.
;
CRLF
LDA #155
JMP OUTCH
; print one blank
;
XBLANK LDA #$20
JMP OUTCH
; print one TAB
;
XTAB LDA #127
JMP OUTCH
; print accum as two hex digits
HEX2 PHA
LSR A
LSR A
LSR A
LSR A
JSR HEX2A
PLA
HEX2A AND #$0F
JSR HXDGT
JMP OUTCH
;
;convert hex digit to ASCII
;
HXDGT CMP #$0A
BCC HXDGT1
CLC
ADC #7
HXDGT1 ADC #'0
RTS
;
; print accum as one ASCII character
;
LETTER
AND #$7F
CMP #$20 ;compare ASCII space
BCS LETTER1 ;good if >= ' '
LDA #'.
LETTER1 JMP OUTCH
;
; wait for keystroke
;
ONEKEY JMP GETCH
.ENDIF ; DEBUG
TOP .END ; Ende des Assemblerlistings
.BANK
* = $2E0
.WORD ORIG
