! 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


}}}