












ende 123


\                                                     cas21dec05
forth definitions
: (C [compile] ( ; IMMEDIATE  \ : ) ; IMMEDIATE

$2000 DISPLACE !

TARGET DEFINITIONS $2000  HERE!
hex
&01 &126  +THRU
decimal
\ ASSEMBLER NONRELOCATE
.( Unresolved: )
.UNRESOLVED cr


CR .( SAVE-TARGET 6502-FORTH83)
\ FORTH PREAMBLE AND ID       10JAN85BP)               er14dez88


ASSEMBLER
NOP  0 JMP  HERE 2- >LABEL >COLD
NOP  0 JMP  HERE 2- >LABEL >RESTART

HERE DUP ORIGIN!








\ HIER BEGINNEN DIE KALTSTARTWERTE DER                cas21dec05
\ BENUTZERVARIABLEN

0 JMP  0 JSR  HERE 2- >LABEL >WAKE
END-CODE

0D6 ALLOT

," VOLKSFORTH-83 3.8 COMPILED 21DEC05CS"







\ ZERO PAGE VARIABLES & NEXT  03APR85BP)               cs09aug05

A0 DUP     >LABEL RP     2+   .( 02 durch 8E ersetzt )
DUP     >LABEL UP     2+
DUP     >LABEL PUTA   1+
DUP     >LABEL SP     2+
DUP     >LABEL NEXT
DUP 5 + >LABEL IP
13 + >LABEL W

W 8 + >LABEL N





\ NEXT, MOVED INTO ZERO PAGE  08APR85BP)

LABEL BOOTNEXT
-1 STA              \ -1 IS DUMMY SP
IP )Y LDA  W 1+  STA
-1 LDA     W STA    \ -1 IS DUMMY IP
CLC IP LDA  2 # ADC  IP STA
CS NOT ?[ LABEL WJMP -1 ) JMP ]?
IP 1+ INC  WJMP BCS END-CODE







\
HERE BOOTNEXT - >LABEL BOOTNEXTLEN

CODE END-TRACE  ( PATCH NEXT FOR TRACE )
0A5 # LDA  NEXT 0A + STA
IP # LDA  NEXT 0B + STA
069 # LDA  NEXT 0C + STA
02 # LDA  NEXT 0D + STA
NEXT JMP   END-CODE







\ ;C:  NOOP                   24MAY84KS)

CREATE RECOVER  ASSEMBLER
PLA  W STA  PLA  W 1+ STA
W WDEC  0 JMP   END-CODE

HERE 2- >LABEL >RECOVER
\ HANDGESTRICKTE VORWAERTS REFERENZ FUER
\ DEN JMP-BEFEHL

COMPILER ASSEMBLER ALSO DEFINITIONS
H : ;C:   0 T RECOVER JSR
END-CODE  ] H ;
TARGET
CODE NOOP   NEXT HERE 2- !  END-CODE

\ USER VARIABLES              17MAR84KS)              cas09dec05

CONSTANT ORIGIN  8 UALLOT DROP
\ FOR MULTITASKER


USER S0      $7000 S0 !         USER R0      $7500 R0 !
USER DP                         USER OFFSET      0 OFFSET !
USER BASE      &10 BASE !       USER OUTPUT
USER INPUT
USER ERRORHANDLER               \ POINTER FOR  ABORT" -CODE
USER VOC-LINK
USER UDP                \ POINTS TO NEXT FREE ADDR IN USER



\ MANIPULATE SYSTEM POINTERS  29JAN85BP)

CODE SP@   ( -- ADDR)
SP LDA  N STA  SP 1+ LDA  N 1+ STA
N # LDX
LABEL XPUSH
SP 2DEC  1 ,X LDA  SP )Y STA
0 ,X LDA  0 # LDX  PUTA JMP   END-CODE

CODE SP!   ( ADDR --)
SP X) LDA  TAX  SP )Y LDA
SP 1+ STA  SP STX   0 # LDX
NEXT JMP   END-CODE



\
CODE UP@   ( -- ADDR)
UP # LDX  XPUSH JMP  END-CODE

CODE UP!   ( ADDR --)      UP # LDX
LABEL XPULL     SP )Y LDA  1 ,X STA
DEY SP )Y LDA  0 ,X STA
LABEL (XYDROP   0 # LDX  1 # LDY
LABEL (DROP     SP 2INC  NEXT JMP
END-CODE RESTRICT






\ MANIPULATE RETURNSTACK   16FEB85BP/KS)
CODE RP@ ( -- ADDR )
RP # LDX  XPUSH JMP  END-CODE

CODE RP! ( ADDR -- )
RP # LDX  XPULL JMP  END-CODE RESTRICT

CODE >R  ( 16B --  )
RP 2DEC  SP X) LDA   RP X) STA
SP )Y LDA   RP )Y STA (DROP JMP
END-CODE RESTRICT





\
CODE R>  ( -- 16B)
SP 2DEC  RP X) LDA  SP X) STA
RP )Y LDA  SP )Y STA
LABEL (RDROP     2 # LDA

LABEL (NRDROP    CLC  RP ADC  RP STA
CS ?[  RP 1+ INC  ]?
NEXT JMP  END-CODE  RESTRICT







\ R@ RDROP  EXIT  ?EXIT       08APR85BP)

CODE R@      ( -- 16B)
SP 2DEC  RP )Y LDA  SP )Y STA
RP X) LDA  PUTA JMP
END-CODE
CODE RDROP    (RDROP HERE 2- !
END-CODE   RESTRICT

CODE EXIT
RP X) LDA  IP STA
RP )Y LDA  IP 1+ STA
(RDROP JMP   END-CODE



\ EXECUTE  PERFORM            08APR85BP)

CODE ?EXIT     ( FLAG -- )
SP X) LDA  SP )Y ORA
PHP  SP 2INC  PLP
' EXIT @ BNE  NEXT JMP
END-CODE

CODE EXECUTE  ( ADDR --)
SP X) LDA   W STA
SP )Y LDA   W 1+ STA
SP 2INC     W 1- JMP   END-CODE

: PERFORM ( ADDR -- )   @ EXECUTE ;


\ C@   C! CTOGGLE             10JAN85BP)

CODE C@ ( ADDR -- 8B)

SP X) LDA  N STA   SP )Y LDA  N 1+ STA
LABEL (C@    0 # LDA  SP )Y STA
N X)  LDA   PUTA JMP   END-CODE

CODE C!  ( 16B ADDR --)
SP X) LDA   N STA   SP )Y LDA  N 1+ STA
INY  SP )Y LDA  N X) STA DEY
LABEL (2DROP
SP LDA  CLC  4 # ADC  SP STA
CS ?[  SP 1+ INC  ]?
NEXT JMP   END-CODE

\ @ ! +!                      08APR85BP)               er14dez88

: CTOGGLE   ( 8B ADDR --) UNDER C@ XOR SWAP C! ;

CODE @  ( ADDR -- 16B)
SP X) LDA  N STA  SP )Y LDA  N 1+ STA
N )Y LDA  SP )Y STA
N X) LDA PUTA JMP   END-CODE

CODE !   ( 16B ADDR --)
SP X) LDA  N STA  SP )Y LDA  N 1+ STA
INY SP )Y LDA  N X) STA
INY SP )Y LDA   1 # LDY
LABEL (!
N )Y STA  (2DROP JMP   END-CODE

\ DROP SWAP                   24MAY84KS)

CODE +!  ( N ADDR --)
SP X) LDA  N STA  SP )Y LDA  N 1+ STA
INY  SP )Y LDA  CLC  N X) ADC N X) STA
INY  SP )Y LDA  1 # LDY  N )Y ADC
(! JMP   END-CODE

CODE DROP  ( 16B --)
(DROP HERE 2- !  END-CODE






\
CODE SWAP  ( 16B1 16B2 -- 16B2 16B1 )
SP )Y LDA  TAX
3 # LDY  SP )Y LDA  N STA
TXA  SP )Y STA
N LDA  1 # LDY  SP )Y STA
INY  0 # LDX
SP )Y LDA  N STA  SP X) LDA  SP )Y STA
DEY
N LDA PUTA JMP   END-CODE






\ DUP  ?DUP                   08MAY85BP)

CODE DUP   ( 16B -- 16B 16B)
SP 2DEC
3 # LDY  SP )Y LDA  1 # LDY  SP )Y STA

INY  SP )Y LDA  DEY
PUTA JMP   END-CODE

CODE ?DUP     ( 16B -- 16B 16B / FALSE)
SP X) LDA  SP )Y ORA
0= ?[  NEXT JMP  ]?
' DUP @ JMP END-CODE
\\ : ?DUP   ( 16B -- 16B 16B / FALSE)
DUP  IF  DUP  THEN ;
: DUP    SP@  @  ;
\ OVER ROT                    13JUN84KS)

CODE OVER  ( 16B1 16B2 - 16B1 16B3 16B1)
SP 2DEC  4 # LDY  SP )Y LDA  SP X) STA
INY  SP )Y LDA  1 # LDY  SP )Y STA
NEXT JMP   END-CODE


\\ : ROT   >R SWAP R> SWAP ;
: OVER  >R DUP R> SWAP ;






\                                                      er14dez88
CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1)
3 # LDY  SP )Y LDA  N 1+ STA
1 # LDY  SP )Y LDA  3 # LDY  SP )Y STA
5 # LDY  SP )Y LDA  N STA
N 1+ LDA  SP )Y STA
1 # LDY  N LDA  SP )Y STA
INY  SP )Y LDA  N 1+ STA
SP X) LDA  SP )Y STA
4 # LDY  SP )Y LDA  SP X) STA
N 1+ LDA  SP )Y STA
1 # LDY  NEXT JMP   END-CODE




\ -ROT NIP UNDER PICK ROLL    24DEC83KS)
: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2)
ROT ROT ;

: NIP   ( 16B1 16B2 -- 16B2) SWAP DROP ;


: UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ;

: PICK  ( N -- 16B.N )   1+ 2* SP@ + @ ;

: ROLL  ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE>  DROP ;

\\ : -ROLL ( N --)
>R DUP SP@  DUP 2+ DUP 2+ SWAP
R@ 2* CMOVE R> 1+ 2* + ! ;
\ DOUBLE WORD STACK MANIP.    21APR83KS)

: 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ;

CODE 2DROP ( 32B -- )
(2DROP HERE 2- !   END-CODE

: 2DUP  ( 32B -- 32B 32B) OVER OVER ;

\  : 2DROP ( 32B -- )     DROP DROP ;






\ + AND OR XOR                08APR85BP)
COMPILER  ASSEMBLER ALSO DEFINITIONS

H : DYADOP ( OPCODE --)  T
INY  SP X) LDA  DUP C, SP C, SP )Y STA
DEY  SP )Y LDA  3 # LDY  C, SP C, SP )Y STA
(XYDROP JMP  H ;
TARGET

CODE +     ( N1 N2 -- N3) CLC     071 DYADOP   END-CODE

CODE OR    ( 16B1 16B2 -- 16B3)   011 DYADOP   END-CODE

CODE AND   ( 16B1 16B2 -- 16B3)   031 DYADOP   END-CODE

CODE XOR   ( 16B1 16B2 -- 16B3)   051 DYADOP   END-CODE
\ -  NOT  NEGATE              24DEC83KS)

CODE -    ( N1 N2 -- N3)
INY SP )Y LDA  SEC SP X) SBC SP )Y STA INY SP )Y LDA
1 # LDY  SP )Y SBC  3 # LDY  SP )Y STA (XYDROP JMP   END-CODE

CODE NOT   ( 16B1 -- 16B2)   CLC
LABEL (NOT TXA  SP X) SBC  SP X) STA  TXA SP )Y SBC  SP )Y STA
NEXT JMP   END-CODE

CODE NEGATE   ( N1 -- N2 ) SEC  (NOT BCS   END-CODE

\ : -       NEGATE + ;



\ DNEGATE SETUP D+            14JUN84KS)

CODE DNEGATE ( D1 -- -D1)
INY  SEC
TXA  SP )Y SBC  SP )Y STA  INY
TXA  SP )Y SBC  SP )Y STA
TXA  SP X) SBC  SP X) STA  1 # LDY
TXA  SP )Y SBC  SP )Y STA
NEXT JMP  END-CODE
LABEL SETUP  ( QUAN  IN A)
.A ASL TAX TAY  DEY
[[ SP )Y LDA  N ,Y STA  DEY  0< ?]
TXA  CLC  SP ADC  SP STA
CS ?[  SP 1+ INC  ]?
0 # LDX  1 # LDY   RTS   END-CODE

\
CODE D+      ( D1 D2 -- D3)
2 # LDA  SETUP JSR  INY
SP )Y LDA  CLC N 2+  ADC SP )Y STA INY
SP )Y LDA      N 3 + ADC SP )Y STA
SP X) LDA  N    ADC SP X) STA  1 # LDY
SP )Y LDA  N 1+ ADC SP )Y STA
NEXT JMP   END-CODE








\ 1+ 2+ 3+    1- 2-           08APR85BP)

CODE 1+   ( N1 -- N2)   1 # LDA
LABEL N+  CLC  SP X) ADC
CS NOT   ?[  PUTA JMP  ]?
SP X) STA  SP )Y LDA  0 # ADC SP )Y STA
NEXT JMP  END-CODE

CODE 2+   ( N1 -- N2) 2 # LDA   N+ BNE     END-CODE

CODE 3+   ( N1 -- N2) 3 # LDA   N+ BNE     END-CODE

| CODE 4+ ( N1 -- N2) 4 # LDA   N+ BNE     END-CODE

| CODE 6+ ( N1 -- N2) 6 # LDA   N+ BNE     END-CODE

\ NUMBER CONSTANTS            24DEC83KS)
CODE 1-   ( N1 -- N2)   SEC
LABEL (1-     SP X) LDA  1 # SBC
CS ?[ PUTA JMP ]?
SP X) STA  SP )Y LDA  0 # SBC SP )Y STA
NEXT JMP  END-CODE
CODE 2-   ( N1 -- N2)  CLC (1- BCC  END-CODE

-1 CONSTANT TRUE    0 CONSTANT FALSE
' TRUE ALIAS -1     ' FALSE ALIAS 0

1 CONSTANT 1        2 CONSTANT 2
3 CONSTANT 3        4 CONSTANT 4

: ON    ( ADDR -- )  TRUE  SWAP ! ;
: OFF   ( ADDR -- )  FALSE SWAP ! ;
\ WORDS FOR NUMBER LITERALS   24MAY84KS)               cs08aug05

CODE CLIT  ( -- 8B)
SP 2DEC  IP X) LDA  SP X) STA TXA   SP )Y STA  IP WINC
NEXT JMP   END-CODE RESTRICT

CODE LIT   ( -- 16B)
SP 2DEC  IP )Y LDA  SP )Y STA IP X) LDA  SP X) STA
LABEL (BUMP   IP 2INC NEXT JMP  END-CODE RESTRICT
: LITERAL   ( 16B --) DUP 0FF00 AND
IF  COMPILE LIT   , EXIT THEN COMPILE CLIT C,  ;
IMMEDIATE RESTRICT

\\ : LIT     R> DUP 2+ >R  @  ;
: CLIT    R> DUP 1+ >R  C@ ;

\ COMPARISION CODE WORDS      13JUN84KS)
CODE 0<   ( N -- FLAG) SP )Y LDA  0< ?[
LABEL PUTTRUE    0FF # LDA  024 C, ]?
LABEL PUTFALSE   TXA  SP )Y STA
PUTA JMP   END-CODE

CODE 0=   ( 16B -- FLAG)
SP X) LDA  SP )Y ORA PUTTRUE  BEQ PUTFALSE BNE  END-CODE

CODE UWITHIN  ( U1 [LOW UP[  -- FLAG)
2 # LDA  SETUP JSR 1 # LDY  SP X) LDA  N CMP
SP )Y LDA  N 1+ SBC
CS NOT ?[ ( N>SP) SP X) LDA N 2+  CMP
SP )Y LDA N 3 + SBC
PUTTRUE BCS ]?
PUTFALSE JMP  END-CODE
\ COMPARISION CODE WORDS      13JUN84KS)

CODE <    ( N1 N2 -- FLAG)
SP X) LDA  N STA  SP )Y LDA  N 1+ STA
SP 2INC
N 1+ LDA  SP )Y EOR  ' 0< @  BMI
SP X) LDA  N CMP  SP )Y LDA  N 1+ SBC
' 0< @ 2+ JMP    END-CODE

CODE U<   ( U1 U2 -- FLAG)
SP X) LDA  N STA  SP )Y LDA  N 1+ STA
SP 2INC
SP X) LDA  N CMP  SP )Y LDA  N 1+ SBC
CS NOT ?[  PUTTRUE JMP  ]?
PUTFALSE JMP  END-CODE

\ COMPARISION WORDS           24DEC83KS)

| : 0<   8000 AND  0<> ;

: >   ( N1 N2 -- FLAG)  SWAP < ;
: 0>  ( N --     FLAG)  NEGATE 0<  ;
: 0<> ( N --     FLAG)  0= NOT ;
: U>  ( U1 U2 -- FLAG)  SWAP U< ;
: =   ( N1 N2 -- FLAG)  - 0= ;
: D0= ( D --     FLAG)  OR 0= ;
: D=  ( D1 D2 -- FLAG)  DNEGATE D+ D0= ;
: D<  ( D1 D2 -- FLAG)  ROT 2DUP -
IF > NIP NIP  ELSE 2DROP U< THEN ;



\ MIN MAX UMAX UMIN EXTEND DABS ABS  KS)

| : MINIMAX  ( N1 N2 FLAG -- N3)
RDROP  IF SWAP THEN DROP ;

: MIN   ( N1 N2 -- N3) 2DUP  > MINIMAX ;   -2 ALLOT
: MAX   ( N1 N2 -- N3) 2DUP  < MINIMAX ;   -2 ALLOT
: UMAX  ( U1 U2 -- U3) 2DUP U< MINIMAX ;   -2 ALLOT
: UMIN  ( U1 U2 -- U3) 2DUP U> MINIMAX ;   -2 ALLOT

: EXTEND  ( N -- D)     DUP 0< ;

: DABS    ( D -- UD)  EXTEND IF  DNEGATE THEN ;
: ABS     ( N -- U)   EXTEND IF   NEGATE THEN ;


\ LOOP PRIMITIVES          08FEB85BP/KS)

| : DODO  RDROP R> 2+ DUP >R ROT >R SWAP >R >R ;


: (DO  ( LIMIT STAR -- ) OVER - DODO ;  -2 ALLOT RESTRICT

: (?DO ( LIMIT START -- )
OVER - ?DUP  IF DODO THEN R> DUP @ +  >R DROP ; RESTRICT

: BOUNDS  ( START COUNT -- LIMIT START ) OVER + SWAP ;

CODE  ENDLOOP 6 # LDA (NRDROP JMP   END-CODE RESTRICT

\\ DODO PUTS  "INDEX \ LIMIT \
ADR.OF.DO"  ON RETURN-STACK
\ (LOOP (+LOOP                08APR85BP)
CODE (LOOP
CLC  1 # LDA  RP X) ADC RP X) STA
CS ?[  RP )Y LDA  0 # ADC RP )Y STA
CS ?[ NEXT JMP ]? ]?
LABEL DOLOOP  5 # LDY
RP )Y LDA  IP 1+ STA  DEY
RP )Y LDA  IP    STA  1 # LDY
NEXT JMP    END-CODE RESTRICT

CODE (+LOOP
CLC SP X) LDA  RP X) ADC  RP X) STA
SP )Y LDA  RP )Y ADC  RP )Y STA
.A ROR  SP )Y EOR
PHP  SP 2INC  PLP DOLOOP BPL
NEXT JMP    END-CODE RESTRICT
\ LOOP INDICES                08APR85BP)

CODE I  ( -- N)    0 # LDY
LABEL LOOPINDEX    SP 2DEC   CLC
RP )Y LDA  INY  INY
RP )Y ADC  SP X) STA  DEY
RP )Y LDA  INY  INY
RP )Y ADC  1 # LDY  SP )Y STA
NEXT JMP   END-CODE RESTRICT

CODE J  ( -- N)
6 # LDY  LOOPINDEX BNE
END-CODE  RESTRICT



\ BRANCHING                   24DEC83KS)

CODE BRANCH
CLC  IP    LDA  IP X) ADC  N STA
IP 1+ LDA  IP )Y ADC  IP 1+ STA  N LDA IP STA
NEXT JMP     END-CODE RESTRICT

CODE ?BRANCH
SP X) LDA  SP )Y ORA PHP  SP 2INC  PLP
' BRANCH @ BEQ    (BUMP JMP  END-CODE   RESTRICT

\\  : BRANCH   R> DUP @ + >R ; RESTRICT

: ?BRANCH
0= R> OVER NOT OVER 2+  AND -ROT
DUP @ + AND OR >R ;       RESTRICT
\ RESOLVE LOOPS AND BRANCHES  03FEB85BP)

: >MARK     ( -- ADDR)  HERE   0 , ;

: >RESOLVE  ( ADDR --)  HERE OVER -   SWAP !  ;

: <MARK     ( -- ADDR)  HERE ;

: <RESOLVE  ( ADDR --)  HERE - ,  ;

: ?PAIRS  ( N1 N2 -- ) -  ABORT" UNSTRUCTURED" ;





\ CASE?                       04MAY85BP)

LABEL  PUSHA
0 # CMP  0< ?[ PHA  0FF # LDA ][
LABEL  PUSH0A   PHA   0  # LDA  ]?
LABEL  PUSH     TAX   SP 2DEC
TXA  1 # LDY  SP )Y STA
PLA  0 # LDX   PUTA JMP

CODE CASE?
( 16B1 16B2 -- 16B1 FALSE / TRUE )
1 # LDA  SETUP JSR N LDA  SP X) CMP
0= ?[   N 1+ LDA  SP )Y CMP 0= ?[ PUTTRUE JMP ]?  ]?
TXA  PUSH0A JMP   END-CODE
\\ : CASE?
( 16B1 16B2 -- 16B1 FALSE / TRUE ) OVER = DUP  IF  NIP  THEN ;
\ BRANCHING                   03FEB85BP)

: IF     COMPILE ?BRANCH >MARK  1 ;          IMMEDIATE RESTRICT
: THEN   ABS 1   ?PAIRS  >RESOLVE ;          IMMEDIATE RESTRICT
: ELSE   1 ?PAIRS  COMPILE BRANCH >MARK
SWAP >RESOLVE  -1 ;                 IMMEDIATE RESTRICT
: BEGIN  <MARK 2 ;                           IMMEDIATE RESTRICT
: WHILE  2 ?PAIRS  2   COMPILE ?BRANCH
>MARK -2  2SWAP  ;                  IMMEDIATE RESTRICT
| : (REPTIL   <RESOLVE   BEGIN DUP -2
= WHILE  DROP >RESOLVE  REPEAT  ;

: REPEAT 2 ?PAIRS   COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT

: UNTIL  2 ?PAIRS  COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT

\ LOOPS                    29JAN85KS/BP)

: DO     COMPILE (DO  >MARK  3 ;     IMMEDIATE RESTRICT

: ?DO    COMPILE (?DO >MARK  3 ;     IMMEDIATE RESTRICT

: LOOP   3 ?PAIRS  COMPILE (LOOP
COMPILE ENDLOOP  >RESOLVE ; IMMEDIATE RESTRICT

: +LOOP  3 ?PAIRS  COMPILE (+LOOP
COMPILE ENDLOOP  >RESOLVE ; IMMEDIATE RESTRICT

: LEAVE  ENDLOOP R> 2- DUP @ + >R ;            RESTRICT

\\ RETURNSTACK: CALLADR \ INDEX
LIMIT \ ADR OF DO
\ UM*                      BP/KS13.2.85)
CODE UM*  ( U1 U2 -- UD)
SP )Y LDA N STA  SP X) LDA  N 1+ STA
INY N 2 + STX N 3 + STX  010 # LDX
[[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL
CS ?[ CLC SP )Y LDA  N 3 + ADC  N 3 + STA
INY  SP )Y LDA DEY N 2 + ADC   N 2 + STA
CS ?[  N 1+ INC  0= ?[  N   INC  ]? ]? ]?
DEX  0= ?]
N 3 + LDA   SP )Y STA   INY N 2 + LDA   SP )Y STA   1 # LDY
N     LDA   SP )Y STA       N 1+ LDA    SP X) STA
NEXT JMP   END-CODE

\\ : UM*   ( U1 U2 -- UD3) >R 0 0 0 R>  010 0
DO  DUP 2/ >R  1 AND IF 2OVER D+ THEN
>R >R 2DUP D+ R> R> R>  LOOP DROP 2SWAP 2DROP ;
\ M* 2*                       04JUL84KS)

: M*     ( N1 N2 -- D)
DUP 0< DUP >R IF NEGATE THEN
SWAP DUP  0<  IF NEGATE R> NOT >R THEN
UM*  R> IF DNEGATE THEN ;

: *      ( N N -- PROD)   UM* DROP ;

CODE 2*  ( N1 -- N2)
SP X) LDA  .A ASL  SP X) STA
SP )Y LDA  .A ROL  SP )Y STA
NEXT JMP    END-CODE
| : 2*   DUP + ;


\ UM/MOD                      04JUL84KS)

| : DIVOVL
TRUE ABORT" DIVISION OVERFLOW" ;

CODE UM/MOD  ( UD U -- UREM UQUOT)
SP X) LDA  N 5 + STA
SP )Y LDA  N 4 + STA   SP 2INC
SP X) LDA  N 1+  STA
SP )Y LDA  N     STA   INY
SP )Y LDA  N 3 + STA   INY
SP )Y LDA  N 2+  STA   011 # LDX  CLC
[[ N 6 + ROR  SEC  N 1+ LDA  N 5 + SBC
TAY  N LDA  N 4 + SBC
CS NOT ?[  N 6 + ROL ]?
CS ?[ N STA  N 1+ STY ]?
\
N 3 + ROL N 2+ ROL N 1+ ROL N ROL
DEX  0= ?]
1 # LDY  N ROR  N 1+ ROR
CS ?[ ;C: DIVOVL ; ASSEMBLER ]?
N 2+  LDA SP )Y STA INY
N 1+  LDA SP )Y STA INY
N     LDA SP )Y STA 1 # LDY
N 3 + LDA
PUTA JMP    END-CODE






\ 2/ M/MOD                    24DEC83KS)

: M/MOD  ( D N -- MOD QUOT)
DUP >R ABS  OVER
0< IF  UNDER + SWAP  THEN
UM/MOD R@
0< IF NEGATE OVER IF SWAP R@ + SWAP 1-
THEN THEN RDROP ;

CODE 2/  ( N1 -- N2)
SP )Y LDA  .A ASL
SP )Y LDA  .A ROR  SP )Y STA
SP X) LDA  .A ROR
PUTA JMP      END-CODE


\ /MOD / MOD */MOD */ U/MOD  UD/MOD  KS)

: /MOD  ( N1 N2 -- REM QUOT)  >R EXTEND R> M/MOD ;

: /     ( N1 N2 -- QUOT)     /MOD NIP ;

: MOD   ( N1 N2 -- REM)      /MOD DROP ;

: */MOD ( N1 N2 N3 -- REM QUOT)  >R M*  R> M/MOD ;

: */    ( N1 N2 N3 -- QUOT)  */MOD NIP ;

: U/MOD  ( U1 U2  -- UREM UQUOT)  0 SWAP UM/MOD ;

: UD/MOD ( UD1 U2 -- UREM UDQUOT)
>R  0  R@  UM/MOD  R> SWAP >R  UM/MOD  R>  ;
\ CMOVE CMOVE> (CMOVE>       BP 08APR85)

CODE CMOVE  ( FROM TO QUAN --)
3 # LDA SETUP JSR  DEY
[[ [[  N CPY  0= ?[  N 1+ DEC  0< ?[
1 # LDY  NEXT JMP  ]? ]?
N 4 + )Y LDA  N 2+ )Y STA INY 0= ?]
N 5 + INC N 3 + INC  ]]  END-CODE








\
CODE CMOVE> ( FROM TO QUAN --)
3 # LDA SETUP JSR
CLC N 1+ LDA  N 3 + ADC  N 3 + STA
CLC N 1+ LDA  N 5 + ADC  N 5 + STA
N 1+ INC  N LDY  CLC CS ?[
LABEL (CMOVE>
DEY  N 4 + )Y LDA  N 2+ )Y STA ]?
TYA  (CMOVE> BNE
N 3 + DEC  N 5 + DEC  N 1+ DEC
(CMOVE> BNE  1 # LDY
NEXT JMP   END-CODE

: MOVE   ( FROM TO QUAN --) >R 2DUP U<  IF R> CMOVE> EXIT THEN
R> CMOVE ;

\ PLACE COUNT  ERASE       16FEB85BP/KS)

: PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ;

CODE COUNT ( ADDR -- ADDR+1 LEN)
SP X) LDA N STA CLC 1 # ADC SP X) STA
SP )Y LDA N 1+ STA  0 # ADC SP )Y STA
SP 2DEC  (C@ JMP   END-CODE

\ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+  SWAP C@ ;

: ERASE ( ADDR QUAN --)      0 FILL ;




\ FILL                        11JUN85BP)

CODE FILL  ( ADDR QUAN 8B -- )
3 # LDA SETUP JSR  DEY
N LDA  N 3 + LDX
0<> ?[  [[ [[ N 4 + )Y STA INY 0= ?]
N 5 + INC    DEX 0= ?]
]?  N 2+ LDX
0<> ?[  [[ N 4 + )Y STA INY DEX 0= ?]
]? 1 # LDY
NEXT JMP   END-CODE

\\ : FILL  ( ADDR QUAN 8B --)   SWAP ?DUP
IF  >R OVER C! DUP 1+ R> 1- CMOVE   EXIT  THEN  2DROP  ;


\ HERE PAD ALLOT , C, COMPILE 24DEC83KS)

: HERE  ( -- ADDR)   DP @ ;

: PAD   ( -- ADDR)   HERE 042 + ;

: ALLOT ( N --)      DP +! ;

: ,     ( 16B --)    HERE !  2  ALLOT ;

: C,    ( 8B --)     HERE C! 1  ALLOT ;

: COMPILE            R> DUP 2+ >R @ , ; RESTRICT



\ INPUT STRINGS               24DEC83KS)

VARIABLE #TIB   0 #TIB !
VARIABLE >TIB   $100 >TIB !   \  050 ALLOT
VARIABLE >IN    0 >IN !
VARIABLE BLK    0 BLK !
VARIABLE SPAN   0 SPAN !

: TIB   ( -- ADDR )    >TIB @ ;

: QUERY TIB  050 EXPECT SPAN @ #TIB !  >IN OFF  BLK OFF ;





\ SCAN SKIP /STRING           12OCT84BP)

: SCAN  ( ADDR0 LEN0 CHAR -- ADDR1 LEN1)  >R
BEGIN  DUP  WHILE  OVER C@ R@ -
WHILE  1- SWAP 1+ SWAP  REPEAT RDROP ;

: SKIP  ( ADDR LEN DEL -- ADDR1 LEN1)  >R
BEGIN  DUP  WHILE  OVER C@ R@ =
WHILE  1- SWAP 1+ SWAP  REPEAT     RDROP ;


: /STRING  ( ADDR0 LEN0 +N - ADDR1 LEN1)
OVER UMIN ROT OVER + -ROT - ;



\ CAPITAL                     03APR85BP)
(C LABEL (CAPITAL  \ FOR COMMODORE ONLY
PHA  0DF # AND    \ 2ND UPPER TO LOWER
ASCII A # CMP
CS ?[  ASCII Z  1+ # CMP
CC ?[  PLA CLC ASCII A ASCII A - # ADC RTS
]? ]?  PLA  RTS  END-CODE )

LABEL (CAPITAL  \ FOR ASCII ONLY
ASCII a # CMP
CS ?[  ASCII z  1+ # CMP
CC ?[      SEC  ASCII a ASCII A - # SBC
]? ]?  RTS  END-CODE

CODE CAPITAL  ( CHAR -- CHAR' )
SP X) LDA  (CAPITAL JSR  SP X) STA NEXT JMP    END-CODE
\ CAPITALIZE                  03APR85BP)

CODE CAPITALIZE  ( STRING -- STRING )
SP X) LDA N    STA  SP )Y LDA  N 1+ STA
N X) LDA N 2+ STA   DEY
[[ N 2+ CPY  0= ?[ 1 # LDY  NEXT JMP ]?
INY N )Y LDA  (CAPITAL JSR  N )Y STA
]]   END-CODE

\\ : CAPITALIZE  ( STRING -- STRING )
DUP  COUNT  BOUNDS ?DO  I C@  CAPITAL  I C!  THEN  LOOP ;

\\ CAPITAL ( CHAR -- CHAR )
ASCII A  ASCII Z 1+  UWITHIN
IF  I C@  [ ASCII A  ASCII A - ]  LITERAL -  ;

\ (WORD                       08APR85BP)

| CODE (WORD   ( CHAR ADR0 LEN0 -- ADR)
\ N   : LENGTH OF SOURCE
\ N+2 : PTR IN SOURCE / NEXT CHAR
\ N+4 : STRING START ADRESS
\ N+6 : STRING LENGTH
N 6 + STX        \ 0 =: STRING_LENGTH
3 # LDY [[ SP )Y LDA  N ,Y STA DEY  0< ?]
1 # LDY  CLC  >IN    LDA  N 2+  ADC  N 2+  STA
\ >IN+ADR0 =: N+2
>IN 1+ LDA  N 3 + ADC  N 3 + STA SEC  N LDA  >IN  SBC  N  STA
\ LEN0->IN =: N
N 1+ LDA  >IN 1+ SBC  N 1+ STA
CC ?[ SP X) LDA  >IN    STA  \ STREAM EXHAUSTED
SP )Y LDA  >IN 1+ STA
\ (WORD                       08APR85BP)

][ 4 # LDY  [[  N LDA  N 1+ ORA         \ SKIP CHAR'S
0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0
0=     ?[[ N 2+ WINC  N WDEC ]]?
N 2+  LDA  N 4 + STA       \ SAVE STRING_START_ADRESS
N 3 + LDA  N 5 + STA
[[  N 2+ X) LDA  SP )Y CMP PHP      \ SCAN FOR CHAR
N 2+ WINC  N WDEC PLP
0= NOT ?[[ N 6 + INC     \ COUNT STRING_LENGTH
N LDA N 1+ ORA
0= ?]  ]? ]?              \ FROM COUNT = 0 IN SKIP)
SEC 2 # LDY
\ ADR_AFTER_STRING - ADR0 =: >IN)
N 2+  LDA  SP )Y SBC  >IN    STA  INY
N 3 + LDA  SP )Y SBC  >IN 1+ STA
\ (WORD                       08APR85BP)

]? \ FROM 1ST ][, STREAM WAS EXHAUSTED
\ WHEN WORD CALLED)
CLC  4 # LDA  SP ADC  SP STA
CS ?[ SP 1+ INC ]?  \ 2DROP
USER' DP # LDY  UP )Y LDA
SP X) STA N    STA  INY
UP )Y LDA 1 # LDY
SP )Y STA N 1+ STA        \ DP @
DEY N 6 + LDA  \ STORE COUNT BYTE FIRST
[[  N )Y STA  N 4 + )Y LDA  INY
N 6 + DEC  0< ?]
020 # LDA  N )Y STA       \ ADD A BLANK
1 # LDY   NEXT JMP   END-CODE

\ SOURCE WORD PARSE NAME      08APR85BP)              cas21dec05

: SOURCE   ( -- ADDR LEN)
TIB #TIB @  ;

: WORD  ( CHAR -- ADDR)   SOURCE (WORD ;

: PARSE ( CHAR -- ADDR LEN) >R SOURCE  >IN @  /STRING OVER SWAP
R> SCAN >R OVER - DUP R> 0<> - >IN +! ;

: NAME   ( -- ADDR)  BL WORD  CAPITALIZE  EXIT  ;

\\ : WORD  ( CHAR -- ADDR)        >R
SOURCE  OVER SWAP  >IN @  /STRING  R@ SKIP  OVER  SWAP  R>
SCAN >R  ROT OVER SWAP  - R> 0<> -  >IN !
OVER - HERE PLACE  BL HERE COUNT + C! HERE ;
\ STATE ASCII ,"  ("  "       24DEC83KS)

VARIABLE STATE    0 STATE !

: ASCII   BL WORD 1+ C@ STATE @
IF [COMPILE] LITERAL THEN ; IMMEDIATE

: ,"      ASCII "  PARSE  HERE OVER 1+  ALLOT PLACE  ;

: "LIT    R> R> UNDER COUNT + >R >R ;  RESTRICT

: ("      "LIT ; RESTRICT

: "       COMPILE ("  ,"  ; IMMEDIATE RESTRICT


\ ." ( .( \ \\ HEX DECIMAL    08SEP84KS)
: (."    "LIT COUNT TYPE ; RESTRICT

: ."     COMPILE (." ," ;  IMMEDIATE RESTRICT

: (      ASCII )  PARSE 2DROP ;          IMMEDIATE

: .(     ASCII )  PARSE TYPE ;           IMMEDIATE

: \      >IN @  C/L /  1+ C/L *  >IN ! ; IMMEDIATE

: \\        B/BLK >IN ! ;  IMMEDIATE

: \NEEDS    NAME FIND NIP  IF  [COMPILE] \  THEN ;

: HEX       010 BASE ! ;        : DECIMAL    0A BASE ! ;
\ NUMBER CONV.:  DIGIT?  ACCUMULATE  KS)
: DIGIT?  ( CHAR -- DIGIT TRUE/ FALSE )
ASCII 0 -   DUP 9 U>
IF [ ASCII A ASCII 9 - 1- ] LITERAL -  DUP 9 U>
IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN
BASE @  OVER  U>  ?DUP  ?EXIT    THEN DROP  FALSE ;

: ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR)
SWAP >R SWAP  BASE @ UM*  DROP  ROT  BASE @ UM*  D+  R>  ;

: CONVERT  ( +D1 ADDR0 -- +D2 ADDR2)
1+  BEGIN  COUNT DIGIT? WHILE  ACCUMULATE    REPEAT  1- ;

| : END?   ( -- FLAG )  PTR @  0= ;
| : CHAR   ( ADDR0 -- ADDR1 CHAR )   COUNT   -1 PTR +!  ;
| : PREVIOUS  ( ADDR0 -- ADDR0 CHAR) 1-  COUNT ;
\ ?NONUM ?NUM FIXBASE?        13FEB85KS)

VARIABLE DPL   -1 DPL !

| : ?NONUM   ( FLAG -- EXIT IF TRUE )
IF RDROP 2DROP DROP RDROP FALSE THEN ;

| : ?NUM     ( FLAG -- EXIT IF TRUE )
IF RDROP DROP R> IF  DNEGATE  THEN
ROT DROP  DPL @ 1+  ?DUP ?EXIT DROP TRUE THEN ;
| : FIXBASE? ( CHAR - CHAR FALSE /  NEWBASE TRUE )
ASCII & CASE?  IF 0A TRUE EXIT THEN
ASCII $ CASE?  IF 10 TRUE EXIT THEN
ASCII H CASE?  IF 10 TRUE EXIT THEN
ASCII % CASE?  IF  2 TRUE EXIT THEN FALSE  ;

\                             13FEB85KS)

| : PUNCTUATION?   ( CHAR -- FLAG)
ASCII , OVER = SWAP ASCII . =  OR ;

| : ?DPL   DPL @ -1 = ?EXIT  1 DPL +! ;

| VARIABLE PTR      \ POINTS INTO STRING








\ (NUMBER  NUMBER             13FEB85KS)
: NUMBER?   ( STRING - STRING FALSE / N 0< / D 0> )
BASE PUSH  DUP COUNT  PTR !  DPL ON
0 >R  ( +SIGN)
0.0 ROT           END? ?NONUM CHAR
ASCII - CASE?
IF RDROP TRUE >R  END? ?NONUM CHAR THEN FIXBASE?
IF  BASE !        END? ?NONUM CHAR THEN
BEGIN   DIGIT?  0= ?NONUM
BEGIN  ACCUMULATE  ?DPL  END? ?NUM
CHAR DIGIT?  0= UNTIL
PREVIOUS  PUNCTUATION?  0= ?NONUM
DPL OFF   END? ?NUM CHAR
REPEAT ;
: NUMBER  ( STRING -- D )
NUMBER?  ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ;
\ HIDE REVEAL IMMEDIATE RESTRICT     KS)
VARIABLE LAST     0 LAST !

| : LAST?   ( -- FALSE / ACF TRUE) LAST @ ?DUP ;

: HIDE    LAST?  IF 2- @ CURRENT @ ! THEN ;

: REVEAL  LAST?  IF 2-   CURRENT @ ! THEN ;

: RECURSIVE   REVEAL  ;   IMMEDIATE RESTRICT

| : FLAG!  ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN   DROP ;

: IMMEDIATE  040 FLAG! ;

: RESTRICT   080 FLAG! ;
\ CLEARSTACK HALLOT HEAP HEAP?11FEB85BP)

CODE CLEARSTACK USER' S0 # LDY
UP )Y LDA  SP    STA  INY UP )Y LDA  SP 1+ STA
1 # LDY  NEXT JMP   END-CODE

: HALLOT ( QUAN -- )  S0 @ OVER - SWAP
SP@ 2+  DUP ROT -  DUP S0 !
2 PICK OVER -  MOVE  CLEARSTACK  S0 ! ;

: HEAP   ( -- ADDR)        S0 @  6+ ;

: HEAP?  ( ADDR -- FLAG)   HEAP UP@ UWITHIN ;

| : HEAPMOVE   ( FROM -- FROM) DUP HERE  OVER -
DUP HALLOT  HEAP SWAP CMOVE HEAP OVER - LAST +!  REVEAL ;
\ DOES>  ;                 30DEC84KS/BP)

LABEL (DODOES>   RP 2DEC
IP 1+ LDA RP )Y STA  IP LDA  RP X) STA  \ PUT IP ON RP
CLC  W X) LDA  3 # ADC IP STA
TXA  W )Y ADC  IP 1+ STA  \ W@ + 3 -> IP
LABEL DOCREATE
2 # LDA  CLC W ADC PHA TXA W 1+ ADC  PUSH JMP END-CODE

| : (;CODE    R> LAST @  NAME>  ! ;

: DOES> COMPILE (;CODE  04C C,
COMPILE (DODOES> ;  IMMEDIATE RESTRICT



\ 6502-ALIGN  ?HEAD  \        08SEP84BP)

| : 6502-ALIGN/1   ( ADR -- ADR' ) DUP  0FF AND  0FF =  - ;


| : 6502-ALIGN/2   ( LFA -- LFA )
HERE  0FF AND 0FF =
IF  DUP DUP 1+  HERE OVER - 1+ CMOVE>  \ LFA NOW INVALID
1 LAST +! 1 ALLOT  THEN  ;

VARIABLE ?HEAD    0 ?HEAD !

: |     ?HEAD @   ?EXIT   -1 ?HEAD  ! ;



\ WARNING   CREATE            30DEC84BP)

VARIABLE WARNING  0 WARNING !

| : EXISTS?
WARNING @ ?EXIT
LAST @  CURRENT @  (FIND  NIP
IF SPACE  LAST @ .NAME ." EXISTS " ?CR THEN  ;

: CREATE  HERE BLK @ ,  CURRENT @ @ ,
NAME  C@ DUP 1 020  UWITHIN NOT  ABORT" INVALID NAME"
HERE  LAST ! 1+ ALLOT  EXISTS? ?HEAD @
IF 1 ?HEAD +!  DUP  6502-ALIGN/1 , \ POINTER TO CODE
HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP !
ELSE  6502-ALIGN/2  DROP THEN  REVEAL  0 ,
;CODE  DOCREATE JMP END-CODE
\ NFA?                        30DEC84BP)
| CODE NFA?  ( VOCABTHREAD  CFA -- NFA / FALSE)
SP X) LDA  N 4 + STA  SP )Y LDA  N 5 + STA   SP 2INC
[[ [[ SP X) LDA  N 2+  STA  SP )Y LDA  N 3 + STA
N 2+ ORA  0= ?[ PUTFALSE JMP ]?
N 2+ )Y LDA SP )Y STA  N 1+ STA
N 2+ X) LDA SP X) STA  N STA
N 1+ ORA  0= ?[  NEXT JMP  ]?  \ N=LINK
N 2INC N X) LDA PHA SEC 01F # AND
N ADC  N STA  CS ?[ N 1+ INC ]?
PLA  020 # AND  0= NOT
?[ N )Y LDA  PHA
N X) LDA N STA PLA N 1+ STA ]?
N LDA     N 4 + CMP  0= ?]  \ VOCABTHREAD=0
N 1+ LDA  N 5 + CMP  0= ?]  \ D.H. LEERES VOCABULARY
' 2+ @ JMP       END-CODE       \  IN NFA? IST ERLAUBT
\ >NAME NAME> >BODY .NAME     03FEB85BP)

: >NAME   ( CFA -- NFA / FALSE)  VOC-LINK
BEGIN @ DUP WHILE 2DUP 4 - SWAP
NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ;

| : (NAME>  ( NFA -- CFA) COUNT 01F  AND + ;

: NAME> ( NFA -- CFA)  DUP (NAME> SWAP C@ 020 AND IF @ THEN ;

: >BODY   ( CFA -- PFA)   2+ ;

: .NAME   ( NFA --)
?DUP IF DUP HEAP?  IF ." |" THEN COUNT 01F AND TYPE
ELSE  ." ???" THEN  SPACE  ;

\ : ; CONSTANT VARIABLE    09JAN85KS/BP)

: :  CREATE  HIDE  CURRENT @ CONTEXT ! ] 0
;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE
RP 2DEC IP    LDA  RP X) STA IP 1+ LDA  RP )Y STA
W LDA  CLC  2 # ADC  IP STA  TXA   W 1+ ADC  IP 1+ STA
NEXT JMP   END-CODE

: ;        0 ?PAIRS  COMPILE EXIT
[COMPILE] [ REVEAL ; IMMEDIATE RESTRICT

: CONSTANT  ( 16B --)  CREATE ,
;CODE  SP 2DEC  2 # LDY W )Y LDA  SP X) STA  INY
W )Y LDA   1 # LDY   SP )Y STA NEXT JMP   END-CODE

: VARIABLE   CREATE  2 ALLOT ;
\ UALLOT USER ALIAS        10JAN85KS/BP)

: UALLOT ( QUAN -- OFFSET)
DUP UDP @ +  0FF U> ABORT" USERAREA FULL"
UDP  @ SWAP UDP +! ;

: USER  CREATE   2 UALLOT C,
;CODE  SP 2DEC  2 # LDY W )Y LDA  CLC UP    ADC  SP X) STA
TXA  INY UP 1+ ADC  1 # LDY  SP )Y STA   NEXT JMP   END-CODE

: ALIAS  ( CFA --)
CREATE LAST @ DUP C@ 020 AND
IF   -2 ALLOT  ELSE  020 FLAG! THEN  (NAME> ! ;



\ VOC-LINK VP CURRENT CONTEXT ALSO   BP)
CREATE   VP       10 ALLOT

VARIABLE CURRENT

: CONTEXT ( -- ADR  )  VP DUP @ + 2+ ;

| : THRU.VOCSTACK  ( -- FROM TO ) VP 2+ CONTEXT ;
\ "ONLY FORTH ALSO ASSEMBLER" GIVES VP :
\  COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER

: ALSO     VP @
0A > ERROR" VOCABULARY STACK FULL"
CONTEXT @   2 VP +!  CONTEXT ! ;

: TOSS   -2 VP +! ;
\  VOCABULARY FORTH ONLY FORTH-83 KS/BP)

: VOCABULARY CREATE  0 , 0 ,
HERE VOC-LINK @ ,  VOC-LINK ! DOES>  CONTEXT ! ;

\ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK

VOCABULARY FORTH

VOCABULARY ONLY
] DOES>  [ ONLYPATCH ]  0 VP ! CONTEXT !  ALSO  ;  ' ONLY !

: ONLYFORTH  ONLY FORTH ALSO DEFINITIONS ;



\ DEFINITIONS ORDER WORDS  13JAN84BP/KS)

: DEFINITIONS   CONTEXT @ CURRENT ! ;

| : .VOC  ( ADR -- ) @ 2- >NAME .NAME ;

: ORDER
THRU.VOCSTACK  DO  I .VOC  -2  +LOOP  2 SPACES  CURRENT .VOC ;

: WORDS      CONTEXT @
BEGIN  @ DUP STOP? 0= AND
WHILE  ?CR DUP 2+ .NAME SPACE REPEAT DROP ;




\ (FIND                       08APR85BP)

CODE (FIND  ( STRING THREAD
-- STRING FALSE / NAMEFIELD TRUE)
3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?]
N 2+ X) LDA 01F # AND N 4 + STA
LABEL FINDLOOP   0 # LDY
N )Y LDA   TAX   INY
N )Y LDA  N 1+ STA  N STX  N ORA
0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]?
INY N )Y LDA  01F # AND  N 4 + CMP
FINDLOOP BNE       \ COUNTBYTE MATCH
CLC 2 # LDA N    ADC N 5 + STA
0 # LDA N 1+ ADC N 6 + STA
N 4  + LDY
[[ N 2+ )Y LDA N 5 + )Y CMP
\
FINDLOOP BNE   DEY  0= ?]
3 # LDY N 6 + LDA  SP )Y STA   DEY
N 5 + LDA  SP )Y STA
DEY  0 # LDX    PUTTRUE JMP   END-CODE











\ FOUND                       29JAN85BP)

| CODE FOUND  ( NFA -- CFA N )
SP X) LDA N STA  SP )Y LDA N 1+ STA
N X) LDA N 2+ STA  01F # AND  SEC N ADC N STA
CS ?[ N 1+ INC ]?
N 2+ LDA 020 # AND
0= ?[ N    LDA  SP X) STA N 1+ LDA
][ N X) LDA  SP X) STA N )Y LDA   ]?  SP )Y STA
SP 2DEC   N 2+ LDA   0< ?[  INY  ]?
.A ASL
0< NOT ?[ TYA 0FF # EOR TAY INY  ]?
TYA SP X) STA
0< ?[ 0FF # LDA  24 C, ]?
TXA  1 # LDY  SP )Y STA
NEXT JMP  END-CODE
\\

| : FOUND  ( NFA -- CFA N )
DUP   C@ >R   (NAME>
R@ 020 AND  IF @ THEN
-1  R@ 080 AND  IF 1- THEN
R> 040 AND  IF NEGATE THEN ;









\ FIND  ' [']                 13JAN85BP)              cas21dec05

: FIND ( STRING -- CFA N / STRING FALSE)
CONTEXT DUP @ OVER 2- @ = IF 2- THEN
BEGIN  UNDER @ (FIND IF NIP FOUND EXIT THEN
OVER VP 2+ U>
WHILE  SWAP 2-  REPEAT NIP FALSE ;

: '  ( -- CFA ) NAME FIND 0= ABORT" WHAT?"  ;

: [COMPILE]   ' , ;             IMMEDIATE RESTRICT

: [']     ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT

: NULLSTRING? ( STRING -- STRING FALSE  / TRUE)
DUP C@ 0=  DUP  IF NIP THEN ;
\ >INTERPRET                  28FEB85BP)

LABEL JUMP
INY CLC W )Y LDA 2 # ADC IP    STA
INY     W )Y LDA 0 # ADC IP 1+ STA
1 # LDY  NEXT JMP   END-CODE
VARIABLE >INTERPRET

JUMP  ' >INTERPRET !

\\ MAKE VARIABLE >INTERPRET TO SPECIAL
DEFER




\ INTERPRET INTERACTIVE    31DEC84KS/BP)              cas21dec05

DEFER  NOTFOUND

: NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?"   ;  \ STRING NOT 0

' NO.EXTENSIONS  IS  NOTFOUND

: INTERPRET     >INTERPRET ;  -2 ALLOT

| : INTERACTIVE  ?STACK  NAME FIND  ?DUP
IF 1 AND IF EXECUTE >INTERPRET THEN
ABORT" COMPILE ONLY"  THEN  NULLSTRING? ?EXIT    NUMBER?
0= IF  NOTFOUND  THEN  >INTERPRET ;  -2 ALLOT

' INTERACTIVE  >INTERPRET !
\ COMPILING [ ]               20DEC84BP)

| : COMPILING
?STACK  NAME FIND   ?DUP
IF   0> IF  EXECUTE >INTERPRET  THEN
, >INTERPRET THEN
NULLSTRING? ?EXIT  NUMBER?   ?DUP
IF 0> IF SWAP [COMPILE] LITERAL THEN
[COMPILE] LITERAL
ELSE  NOTFOUND THEN    >INTERPRET ; -2 ALLOT

: [    ['] INTERACTIVE  IS >INTERPRET STATE OFF ;  IMMEDIATE

: ]    ['] COMPILING    IS >INTERPRET STATE ON ;


\ PERFOM  DEFER IS            03FEB85BP)

| : CRASH   TRUE ABORT" CRASH" ;

: DEFER   CREATE  ['] CRASH ,
;CODE  2 # LDY  W )Y LDA  PHA INY W )Y LDA
W 1+ STA  PLA W STA  1 # LDY W 1- JMP  END-CODE

: (IS            R>  DUP  2+ >R @ ! ;

| : DEF?  ( CFA -- ) @ ['] NOTFOUND   @ OVER =
SWAP ['] >INTERPRET @ = OR NOT  ABORT" NOT DEFERRED" ;

: IS      ( ADR -- )  ' DUP  DEF?  >BODY
STATE  @  IF  COMPILE (IS , EXIT  THEN !  ; IMMEDIATE

\ ?STACK                      08SEP84KS)

| : STACKFULL   ( -- )
DEPTH 20 > ABORT" TIGHT STACK"
REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN
(FORGET THEN  TRUE ABORT" DICTIONARY FULL" ;

CODE ?STACK USER' DP # LDY
SEC SP    LDA  UP )Y  SBC N STA  INY SP 1+ LDA  UP )Y SBC
0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]?
USER' S0 # LDY UP )Y LDA SP    CMP INY
UP )Y LDA SP 1+ SBC   1 # LDY  CS ?[  NEXT JMP ]?
;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT

\\  : ?STACK  SP@  HERE - 100 U< IF STACKFULL THEN
SP@  S0 @ U> ABORT" STACK EMPTY" ;
\ .STATUS PUSH LOAD           08SEP84KS)              cas21dec05

DEFER .STATUS    ' NOOP IS .STATUS

| CREATE PULL  0  ] R> R> ! ;

: PUSH ( ADDR -- )
R> SWAP DUP >R @ >R  PULL >R >R  ;  RESTRICT

\\
: LOAD   ( BLK --)
?DUP 0= ?EXIT BLK PUSH  BLK !
>IN PUSH  >IN OFF  .STATUS INTERPRET ;



\ +LOAD THRU +THRU --> RDEPTH DEPTH  KS)              cas21dec05

\ : +LOAD  ( OFFSET --)  BLK @  + LOAD ;

\ : THRU  ( FROM TO --)      1+  SWAP  DO  I LOAD  LOOP ;

\ : +THRU  ( OFF0 OFF1 --)   1+  SWAP  DO  I +LOAD LOOP ;

\ : -->  1 BLK +! >IN OFF .STATUS  ;  IMMEDIATE

: RDEPTH  ( -- +N)  R0 @  RP@ 2+ - 2/ ;

: DEPTH   ( -- +N)  SP@ S0 @ SWAP - 2/ ;



\ QUIT (QUIT ABORT            07JUN85BP)

| : PROMPT  STATE @  IF ."  COMPILING"  EXIT  THEN  ."  OK" ;

: (QUIT
BEGIN .STATUS CR QUERY INTERPRET PROMPT  REPEAT ;  -2 ALLOT

DEFER 'QUIT    ' (QUIT  IS 'QUIT

: QUIT     R0 @ RP! [COMPILE] [ 'QUIT ;  -2 ALLOT

: STANDARDI/O   [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ;

DEFER 'ABORT   ' NOOP IS 'ABORT

: ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT
\ (ERROR ABORT" ERROR"        20MAR85BP)

VARIABLE SCR    1 SCR !

VARIABLE R#     0 R#  !

: (ERROR  ( STRING -- )
STANDARDI/O SPACE HERE .NAME COUNT TYPE  SPACE ?CR
BLK @  ?DUP IF  SCR !  >IN @  R# ! THEN QUIT ; -2 ALLOT

' (ERROR  ERRORHANDLER  !

: (ABORT"    "LIT SWAP IF
>R CLEARSTACK R> ERRORHANDLER PERFORM
EXIT THEN  DROP ;  RESTRICT

\

| : (ERR"  "LIT SWAP
IF ERRORHANDLER  PERFORM EXIT THEN DROP ;    RESTRICT

: ABORT"  COMPILE (ABORT" ," ;   IMMEDIATE  RESTRICT

: ERROR"  COMPILE (ERR"   ," ;    IMMEDIATE  RESTRICT








\ -TRAILING                   08APR85BP)

020 CONSTANT BL

CODE -TRAILING  ( ADDR N1 -- ADR  N2 )
TYA   SETUP JSR
SP X) LDA  N 2+ STA   CLC
SP )Y LDA  N 1+ ADC  N 3 + STA
N LDY  CLC   CS ?[
LABEL (-TRAIL
DEY  N 2+ )Y LDA  BL # CMP
0<> ?[ INY  0= ?[ N 1+ INC ]?
TYA PHA  N 1+ LDA PUSH JMP ]?
]?   TYA   (-TRAIL BNE
N 3 + DEC N 1 + DEC  (-TRAIL BPL
TYA PUSH0A JMP   END-CODE
\ SPACE SPACES             29JAN85KS/BP)

: SPACE            BL EMIT ;

: SPACES  ( U --)  0  ?DO SPACE LOOP ;

\\
: -TRAILING  ( ADDR N1 -- ADDR N2)
2DUP  BOUNDS
?DO 2DUP + 1- C@ BL -
IF LEAVE THEN  1- LOOP  ;





\ HOLD <# #> SIGN # #S        24DEC83KS)
| : HLD  ( -- ADDR)    PAD 2- ;

: HOLD  ( CHAR -- )     -1 HLD +! HLD @ C! ;

: <#                   HLD HLD ! ;

: #>    ( 32B -- ADDR +N ) 2DROP HLD @  HLD OVER - ;

: SIGN  ( N -- )  0< IF ASCII  - HOLD THEN ;

: #     ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER <
IF [ ASCII A ASCII 9 - 1- ] LITERAL +
THEN  ASCII 0  +  HOLD ;

: #S    ( +D -- 0 0 ) BEGIN # 2DUP  D0= UNTIL ;
\ PRINT NUMBERS               24DEC83KS)

: D.R  -ROT UNDER DABS <# #S ROT SIGN #>
ROT OVER MAX OVER - SPACES TYPE  ;

: .R    SWAP EXTEND ROT D.R ;

: U.R   0 SWAP D.R ;

: D.    0 D.R SPACE ;

: .     EXTEND D. ;

: U.    0 D. ;


\ .S LIST C/L L/S             24DEC83KS)              cas21dec05

: .S   SP@  S0 @  OVER - 020 UMIN BOUNDS ?DO I @ U.  2 +LOOP ;

40 CONSTANT C/L    \ SCREEN LINE LENGTH

10 CONSTANT L/S    \ LINES PER SCREEN
\\
: LIST   ( BLK --)
SCR ! ." SCR " SCR @ DUP U.
." DR "  DRV? .
L/S 0 DO CR I 2 .R SPACE SCR @  BLOCK
I C/L * + C/L -TRAILING TYPE  LOOP CR ;



\ MULTITASKER PRIMITIVES      BP03NOV85)
CODE PAUSE   NEXT HERE 2- !  END-CODE

: LOCK  ( ADDR --)
DUP @  UP@ =  IF  DROP EXIT  THEN
BEGIN  DUP @  WHILE  PAUSE  REPEAT UP@ SWAP ! ;

: UNLOCK  ( ADDR --)   DUP LOCK OFF ;

LABEL WAKE    WAKE >WAKE !
PLA  SEC  5 # SBC  UP    STA   PLA       0 # SBC  UP 1+ STA
04C # LDA  UP X) STA           6 # LDY  UP )Y LDA SP    STA
INY  UP )Y LDA SP 1+ STA 1 # LDY
SP X) LDA  RP STA         SP )Y LDA  RP 1+ STA   SP 2INC
IP  # LDX  XPULL JMP END-CODE

\ BUFFER MECHANISM            15DEC83KS)

USER FILE           0 FILE !    \ ADR OF FILE CONTROL BLOCK

VARIABLE PREV       0 PREV !    \ LISTHEAD

| VARIABLE BUFFERS  0 BUFFERS ! \ SEMAPHOR

0408 CONSTANT B/BUF             \ PHYSIKALISCHE GROESSE







\\ STRUCTUR EINES BUFFERS:
0 : LINK
2 : FILE
6 : BLOCKNR
8 : STATUSFLAGS
0A : DATA .. 1 KB ..

STATUSFLAG BITS: 15   1 -> UPDATED

FILE = -1 EMPTY BUFFER
= 0 NO FCB , DIRECT ACCESS
= ELSE  ADR OF FCB
( SYSTEM   DEPENDENT )



\ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP)              cas21dec05
\\
LABEL THISBUFFER?        2 # LDY
[[  N 4 + )Y LDA N 2- ,Y CMP
0= ?[[  INY  6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER )

| CODE (CORE? ( BLK FILE -- ADDR / BLK  FILE )
\ N-AREA : 0 BLK 2 FILE 4 BUFFER
\          6 PREDECESSOR
3 # LDY
[[ SP )Y LDA  N ,Y STA  DEY  0< ?]
USER' OFFSET # LDY  CLC  UP )Y LDA  N 2+  ADC  N 2+  STA
INY  UP )Y LDA  N 3 + ADC  N 3 + STA  PREV    LDA  N 4 + STA
PREV 1+ LDA  N 5 + STA  THISBUFFER? JSR    0= ?[


\   "                         11JUN85BP)              cas21dec05
\\
LABEL BLOCKFOUND     SP 2INC  1 # LDY
8 #   LDA  CLC N 4 + ADC SP X) STA
N 5 + LDA        0 # ADC SP )Y STA
' EXIT @ JMP  ]?
[[ N 4 + LDA  N 6 + STA N 5 + LDA  N 7 + STA
N 6 + X) LDA  N 4 + STA  1 # LDY
N 6 + )Y LDA  N 5 + STA  N 4 + ORA
0= ?[ ( LIST EMPTY )  NEXT JMP ]?
THISBUFFER? JSR 0= ?] \ FOUND, RELINK
N 4 + X) LDA  N 6 + X) STA  1 # LDY N 4 + )Y LDA  N 6 + )Y STA
PREV    LDA  N 4 + X) STA   PREV 1+ LDA  N 4 + )Y STA
N 4 + LDA  PREV    STA      N 5 + LDA  PREV 1+ STA
BLOCKFOUND JMP    END-CODE

\\ (CORE?                       23SEP85BP
| : this? ( blk file bufadr -- flag )
DUP 4+ @  SWAP 2+ @  D= ;

| : (CORE?  ( BLK FILE -- DATAADDR / BLK FILE )
BEGIN  OVER OFFSET @ + OVER  PREV @
THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN
2DUP >R OFFSET @ + >R PREV @
BEGIN  DUP @ ?DUP
0= IF RDROP RDROP DROP EXIT THEN
DUP R> R> 2DUP >R >R  ROT THIS? 0=
WHILE  NIP  REPEAT DUP @ ROT !  PREV @ OVER !  PREV !
RDROP RDROP REPEAT ;    -2 ALLOT



\ (DISKERR                    11JUN85BP)              cas21dec05
\\
: (DISKERR   ." ERROR !  R TO RETRY "
KEY DUP ASCII R =  SWAP ASCII R =
OR NOT  ABORT" ABORTED"  ;


DEFER DISKERR  ' (DISKERR  IS DISKERR

DEFER R/W






\\ BACKUP EMPTYBUF READBLK     11JUN85BP)             cas21dec05
| : BACKUP   ( BUFADDR --)
DUP 6+ @  0<
IF  2+  DUP @ 1+               \ BUFFER EMPTY IF FILE = -1
IF INPUT PUSH OUTPUT PUSH STANDARDI/O
BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W
WHILE ." WRITE " DISKERR
REPEAT   THEN
080 OVER 4+ 1+ CTOGGLE  THEN DROP ;

| : EMPTYBUF  ( BUFADDR --)   2+ DUP ON 4+ OFF ;

| : READBLK ( BLK FILE ADDR -- BLK FILE ADDR)
DUP EMPTYBUF  INPUT PUSH  OUTPUT PUSH  STANDARDI/O >R
BEGIN OVER OFFSET @ + OVER R@ 8 +  -ROT   1  R/W
WHILE ." READ " DISKERR REPEAT  R>  ;
\\ TAKE MARK UPDATES? FULL? CORE?     BP)             cas21dec05

| : TAKE   ( -- BUFADDR)    PREV
BEGIN  DUP @  WHILE  @  DUP 2+ @ -1 = UNTIL
BUFFERS LOCK   DUP BACKUP ;

| : MARK ( BLK FILE BUFADDR -- BLK FILE )
2+ >R 2DUP R@ !  OFFSET @ +  R@ 2+ !
R> 4+ OFF  BUFFERS UNLOCK ;

| : UPDATES?  ( -- BUFADDR / FLAG)
PREV  BEGIN  @ DUP  WHILE  DUP 6+ @ 0<  UNTIL ;

| : FULL?   ( -- FLAG)  PREV BEGIN @ DUP @ 0= UNTIL  6+ @ 0< ;

: CORE?  ( BLK FILE -- ADDR /FALSE)  (CORE? 2DROP FALSE ;
\\ BLOCK & BUFFER MANIPULATION 11JUN85BP)             cas21dec05

: (BUFFER ( BLK FILE -- ADDR)
BEGIN  (CORE? TAKE MARK  REPEAT ;   -2 ALLOT

: (BLOCK  ( BLK FILE -- ADDR)
BEGIN  (CORE? TAKE READBLK MARK REPEAT ;   -2 ALLOT

| CODE FILE@  ( -- N ) USER' FILE # LDY
UP )Y LDA  PHA  INY  UP )Y LDA PUSH JMP  END-CODE

: BUFFER  ( BLK -- ADDR ) FILE@  (BUFFER ;

: BLOCK   ( BLK -- ADDR ) FILE@  (BLOCK ;


\\ BLOCK & BUFFER MANIPULATION 09SEP84KS)             cas21dec05

: UPDATE   080 PREV @  6+ 1+ C! ;

: SAVE-BUFFERS
BUFFERS LOCK BEGIN   UPDATES? ?DUP WHILE BACKUP REPEAT
BUFFERS UNLOCK  ;

: EMPTY-BUFFERS
BUFFERS LOCK  PREV
BEGIN @ ?DUP
WHILE DUP EMPTYBUF
REPEAT  BUFFERS UNLOCK ;

: FLUSH    SAVE-BUFFERS EMPTY-BUFFERS ;

\\ MOVING BLOCKS               15DEC83KS)             cas21dec05
| : (COPY   ( FROM TO --) DUP FILE@
CORE? IF PREV @ EMPTYBUF THEN
FULL? IF  SAVE-BUFFERS   THEN
OFFSET @ + SWAP BLOCK 2- 2- !  UPDATE ;

| : BLKMOVE  ( FROM TO QUAN --) SAVE-BUFFERS >R
OVER R@ + OVER U> >R  2DUP U< R> AND
IF  R@ R@ D+  R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP
ELSE          R> 0 ?DO 2DUP (COPY 1 1 D+   LOOP
THEN  SAVE-BUFFERS 2DROP ;

: COPY    ( FROM TO --)   1 BLKMOVE ;

: CONVEY  ( [BLK1 BLK2] [TO.BLK --)
SWAP  1+  2 PICK -   DUP 0> NOT ABORT" NEIN"  BLKMOVE ;
\ ALLOCATING BUFFERS          23SEP83KS)              cas21dec05

F000 CONSTANT LIMIT     VARIABLE FIRST
\\
: ALLOTBUFFER   ( -- )
FIRST @ R0 @  - B/BUF 2+ U< ?EXIT
B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF
PREV  @ OVER !  PREV !   ;

: FREEBUFFER    ( -- )
FIRST @   LIMIT B/BUF - U<
IF SAVE-BUFFERS BEGIN  DUP @ FIRST @  - WHILE  @  REPEAT
FIRST @  @ SWAP ! B/BUF FIRST +! THEN ;

: ALL-BUFFERS BEGIN  FIRST @ ALLOTBUFFER FIRST @  = UNTIL ;

\ ENDPOINTS OF FORGET      04JAN85BP/KS)
| : \? ( NFA -- FLAG )   C@  020  AND ;

| : FORGET?  ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ?
NAME> UNDER 1+ U< SWAP  HEAP?  OR ;

|  : ENDPOINTS  ( ADDR -- ADDR SYMB)
HEAP   VOC-LINK @ >R
BEGIN R> @ ?DUP    \ THROUGH ALL VOCABS
WHILE DUP >R 4 - >R \ LINK ON RETURNST.
BEGIN R> @ >R OVER 1- DUP R@  U<    \ UNTIL LINK  OR
SWAP  R@ 2+ NAME> U< AND \ CODE UNDER ADR
WHILE  R@ HEAP?  [ 2DUP ] UNTIL  \ SEARCH FOR A NAME IN HEAP
R@ 2+ \?  IF  OVER R@ 2+ FORGET?
IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB
THEN REPEAT RDROP   REPEAT  ;
\ REMOVE                       23JUL85WE

| CODE REMOVE ( DIC SYMB THR - DIC SYMB)
5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY
CLC UP )Y LDA 6 # ADC N 6 + STA
INY UP )Y LDA 0 # ADC N 7 + STA  1 # LDY
[[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA  0<>
?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS
?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC
][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC
]? CC
?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA
][ N 8 + LDA    N    STA N 9 + LDA N 1+ STA ]?
]]? (DROP JMP   END-CODE


\ REMOVE-     FORGET-WORDS    29APR85BP)

| : REMOVE-WORDS ( DIC SYMB -- DIC SYMB)
VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT  ;

| : REMOVE-TASKS  ( DIC --)
UP@  BEGIN  1+ DUP @ UP@ - WHILE  2DUP @ SWAP HERE UWITHIN
IF DUP @ 1+ @ OVER ! 1-  ELSE  @ THEN REPEAT  2DROP ;

| : REMOVE-VOCS  ( DIC SYMB -- DIC SYMB)
VOC-LINK REMOVE THRU.VOCSTACK
DO  2DUP I @  -ROT  UWITHIN
IF   [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP
2DUP   CURRENT @  -ROT   UWITHIN
IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ;

\

| : FORGET-WORDS    ( DIC SYMB --)
OVER REMOVE-TASKS REMOVE-VOCS
REMOVE-WORDS
HEAP SWAP - HALLOT DP !  0 LAST ! ;










\ DELETING WORDS FROM DICT.   13JAN83KS)

: CLEAR HERE   DUP UP@ FORGET-WORDS   DP ! ;

: (FORGET ( ADR --) DUP  HEAP? ABORT" IS SYMBOL"
ENDPOINTS FORGET-WORDS ;

: FORGET  ' DUP [ DP ] LITERAL @ U<  ABORT" PROTECTED"
>NAME DUP HEAP? IF  NAME>  ELSE  2- 2-  THEN (FORGET ;

: EMPTY  [ DP ] LITERAL @
UP@ FORGET-WORDS [ UDP ] LITERAL @  UDP ! ;




\ SAVE BYE STOP? ?CR       20OCT84KS/BP)              cas21dec05

: SAVE
HERE UP@ FORGET-WORDS VOC-LINK @
BEGIN  DUP 2- 2-  @  OVER 2- !  @ ?DUP 0=  UNTIL
UP@ ORIGIN 0100 CMOVE   ;

: BYE (BYE ;

| : END?    KEY   #CR   (C 3 ) = IF TRUE RDROP THEN ;

: STOP?   ( -- FLAG) KEY? IF END? END? THEN FALSE ;

: ?CR   COL  C/L 0A -  U> IF CR THEN ;


\ IN/OUTPUT STRUCTURE         02MAR85BP)
| : OUT:  CREATE DUP C,  2+ DOES> C@ OUTPUT @ +  PERFORM ;

: OUTPUT:  CREATE  ]      DOES>  OUTPUT ! ;
0  OUT: EMIT   OUT: CR     OUT: TYPE
OUT: DEL    OUT: PAGE   OUT: AT    OUT: AT?  DROP

: ROW   ( -- ROW)  AT? DROP ;
: COL   ( -- COL)  AT? NIP ;

| : IN:    CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ;

: INPUT:  CREATE ]        DOES> INPUT ! ;

0  IN: KEY   IN: KEY?   IN: DECODE  IN: EXPECT   DROP

\ ALIAS  ONLY DEFINITIONEN    29JAN85BP)

ONLY DEFINITIONS FORTH

: SEAL  0 ['] ONLY  >BODY  ! ;  \ KILL ALL WORDS IN ONLY)

' ONLY  ALIAS ONLY
' FORTH ALIAS FORTH
' WORDS ALIAS WORDS
' ALSO  ALIAS ALSO
' DEFINITIONS ALIAS DEFINITIONS
HOST TARGET




\ 'COLD                       07JUN85BP)              cas21dec05
| : INIT-VOCABULARYS   VOC-LINK @
BEGIN  DUP  2- @  OVER 4 - ! @ ?DUP 0= UNTIL ;

| : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ;

DEFER  'COLD    ' NOOP IS 'COLD

| : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH
." volksFORTH-83  REV 3.81.02" CR   RESTART ; -2 ALLOT

DEFER 'RESTART  ' NOOP IS 'RESTART
| : (RESTART ['] (QUIT IS 'QUIT
'RESTART  [ ERRORHANDLER ] LITERAL @ ERRORHANDLER !
[']  NOOP IS 'ABORT ABORT  ;  -2 ALLOT

\ COLD BOOTSYSTEM RESTART     09JUL85WE)              cas09dec05
CODE COLD        HERE >COLD !
' (COLD >BODY 100 U/MOD # LDA PHA  # LDA PHA
LABEL BOOTSYSTEM  CLI 0 # LDY
CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA
[[ ORIGIN ,Y LDA N )Y STA INY 0= ?]
$C lda  HERE 9 + sta  $D lda HERE 5 + sta
LABEL WARMBOOT  $e474 jsr BOOTNEXTLEN 1- # LDY
[[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?]
CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA
USER' S0 # LDY  UP )Y LDA SP STA INY  UP )Y LDA SP 1+ STA
USER' R0 # LDY  UP )Y LDA RP STA INY  UP )Y LDA RP 1+ STA
0 # LDX 1 # LDY TXA RP X) STA RP )Y STA
PLA IP STA PLA IP 1+ STA  warmboot 100 U/MOD # lda $D sta
# lda $C sta
LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE
\ ( RESTART  PARAM.-PASSING TO FORTH   BP)

CODE RESTART       HERE >RESTART !
' (RESTART >BODY 100 U/MOD
# LDA  PHA  # LDA PHA WARMBOOT JMP   END-CODE











\ CODE FOR PARAMETER-PASSING TO FORTH                  er14dez88


include serial.scr


HOST  ' TRANSIENT 8 + @
TRANSIENT  FORTH  CONTEXT @ 6 + !
TARGET     \ KOTZ WUERG !

FORTH ALSO DEFINITIONS

: FORTH-83 ;  \ LAST WORD IN DICTIONARY



\ SYSTEM DEPENDENT CONSTANTS      BP/KS)

VOCABULARY ASSEMBLER
ASSEMBLER DEFINITIONS
TRANSIENT  ASSEMBLER
PUSHA  CONSTANT PUSHA           \ PUT A SIGN-EXTENDED ON STACK
PUSH0A CONSTANT PUSH0A          \ PUT A ON STACK
PUSH   CONSTANT PUSH            \ MSB IN A AND LSB ON JSR-STACK
RP     CONSTANT RP
UP     CONSTANT UP
SP     CONSTANT SP
IP     CONSTANT IP
N      CONSTANT N
PUTA   CONSTANT PUTA
W      CONSTANT W
SETUP  CONSTANT SETUP
\
NEXT   CONSTANT NEXT
XYNEXT CONSTANT XYNEXT
(2DROP CONSTANT POPTWO
(DROP  CONSTANT POP











\ SYSTEM PATCHUP              05JAN85BP)              cas09dec05

FORTH DEFINITIONS

A000 ' LIMIT >BODY !
$9800 S0 !  $9B00 R0 !

S0 @ DUP S0 2- !      6 + S0 7 - !
HERE DP !

HOST  TUDP @          TARGET  UDP !
HOST  TVOC-LINK @     TARGET  VOC-LINK !
HOST  MOVE-THREADS



































































