
\ *** Block No. 0, Hexblock 0














ende 123



\ *** Block No. 1, Hexblock 1

\ volksFORTH Loadscreen                              cas 26jan06
forth definitions
: (C [compile] ( ; IMMEDIATE  \ : ) ; IMMEDIATE

$1000 CONSTANT BASEADDR       \ change target base address here
BASEADDR DISPLACE !

TARGET DEFINITIONS BASEADDR HERE!

hex &01 &126  +THRU
decimal
\ ASSEMBLER NONRELOCATE

.UNRESOLVED                  \ if this prints unresolved
                             \ definitions, check code
CR .( SAVE-TARGET 6502-FORTH83)

\ *** Block No. 2, Hexblock 2

\ FORTH PREAMBLE AND ID                              cas 26jan06


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

HERE DUP ORIGIN!









\ *** Block No. 3, Hexblock 3

\ Coldstartvalues and user variables                 cas 26jan06
\

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

0D6 ALLOT

\ Bootlabel
," VOLKSFORTH-83 3.8 COMPILED 26JAN06CS"







\ *** Block No. 4, Hexblock 4

\ ZERO PAGE VARIABLES & NEXT                         cas 26jan06
\ adjust this to match your architecture


20 DUP     >LABEL RP     2+
   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




\ *** Block No. 5, Hexblock 5

\ 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








\ *** Block No. 6, Hexblock 6

\  Bootnext and Endtrace                             cas 26jan06
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








\ *** Block No. 7, Hexblock 7

\ ;C:  NOOP                                          cas 26jan06

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

HERE 2- >LABEL >RECOVER
\ manual forward reference for JMP command


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


\ *** Block No. 8, Hexblock 8

\ USER VARIABLES                                     cas 26jan06

CONSTANT ORIGIN  8 UALLOT DROP
                 \ FOR MULTITASKER

\ Adjust memory values for data stack and return stack here
USER S0      $5000 S0 !         USER R0      $5500 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




\ *** Block No. 9, Hexblock 9

\ 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




\ *** Block No. 10, Hexblock a

\  UP@ UP!  XPULL (XYDROP (DROP                      cas 26jan06
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







\ *** Block No. 11, Hexblock b

\ 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






\ *** Block No. 12, Hexblock c

\  R> (RDROP (NRDROP                                 cas 26jan06
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








\ *** Block No. 13, Hexblock d

\ 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




\ *** Block No. 14, Hexblock e

\ 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 ;



\ *** Block No. 15, Hexblock f

\ 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


\ *** Block No. 16, Hexblock 10

\ @ ! +!                      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


\ *** Block No. 17, Hexblock 11

\ +!   DROP                                          cas 26jan06

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







\ *** Block No. 18, Hexblock 12

\ SWAP                                               cas 26jan06
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







\ *** Block No. 19, Hexblock 13

\ DUP  ?DUP                   08MAY85BP)             cas 26jan06

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 and DUP in FORTH
\   : ?DUP   ( 16B -- 16B 16B / FALSE)
\    DUP  IF  DUP  THEN ;
\   : DUP    SP@  @  ;

\ *** Block No. 20, Hexblock 14

\ OVER ROT                    13JUN84KS)             cas 26jan06

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 OVER in FORTH
\   : ROT   >R SWAP R> SWAP ;
\   : OVER  >R DUP R> SWAP ;







\ *** Block No. 21, Hexblock 15

\ ROT                                                cas 26jan06
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





\ *** Block No. 22, Hexblock 16

\ -ROT NIP UNDER PICK ROLL    24DEC83KS)             cas 26jan06
: -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* + ! ;


\ *** Block No. 23, Hexblock 17

\ 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 ;







\ *** Block No. 24, Hexblock 18

\ + 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

\ *** Block No. 25, Hexblock 19

\ -  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 + ;




\ *** Block No. 26, Hexblock 1a

\ 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


\ *** Block No. 27, Hexblock 1b

\ D+                                                 cas 26jan06
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









\ *** Block No. 28, Hexblock 1c

\ 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


\ *** Block No. 29, Hexblock 1d

\ 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 ! ;

\ *** Block No. 30, Hexblock 1e

\ 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@ ;


\ *** Block No. 31, Hexblock 1f

\ 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

\ *** Block No. 32, Hexblock 20

\ 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


\ *** Block No. 33, Hexblock 21

\ 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 ;




\ *** Block No. 34, Hexblock 22

\ MIN MAX UMAX UMIN EXTEND DABS ABS                  cas 26jan06

| : 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 ;



\ *** Block No. 35, Hexblock 23

\ 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

\ *** Block No. 36, Hexblock 24

\ (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

\ *** Block No. 37, Hexblock 25

\ 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




\ *** Block No. 38, Hexblock 26

\ 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

\ *** Block No. 39, Hexblock 27

\ 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" ;






\ *** Block No. 40, Hexblock 28

\ 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 ;

\ *** Block No. 41, Hexblock 29

\ 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


\ *** Block No. 42, Hexblock 2a

\ 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

\ *** Block No. 43, Hexblock 2b

\ 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 ;

\ *** Block No. 44, Hexblock 2c

\ 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 + ;



\ *** Block No. 45, Hexblock 2d

\ 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 ]?

\ *** Block No. 46, Hexblock 2e

\
     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







\ *** Block No. 47, Hexblock 2f

\ 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



\ *** Block No. 48, Hexblock 30

\ /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>  ;

\ *** Block No. 49, Hexblock 31

\ 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









\ *** Block No. 50, Hexblock 32

\  CMOVE> MOVE                                       cas 26jan06
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 ;


\ *** Block No. 51, Hexblock 33

\ 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 ;





\ *** Block No. 52, Hexblock 34

\ 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  ;



\ *** Block No. 53, Hexblock 35

\ 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




\ *** Block No. 54, Hexblock 36

\ 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 ;






\ *** Block No. 55, Hexblock 37

\ 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 - ;




\ *** Block No. 56, Hexblock 38

\ 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

\ *** Block No. 57, Hexblock 39

\ 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 -  ;


\ *** Block No. 58, Hexblock 3a

\ (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

\ *** Block No. 59, Hexblock 3b

\ (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

\ *** Block No. 60, Hexblock 3c

\ (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


\ *** Block No. 61, Hexblock 3d

\ SOURCE WORD PARSE NAME      08APR85BP)

: SOURCE   ( -- ADDR LEN)
    BLK @  ?DUP IF  BLOCK B/BLK EXIT THEN  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 ;

\ *** Block No. 62, Hexblock 3e

\ 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



\ *** Block No. 63, Hexblock 3f

\ ." ( .( \ \\ 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 ! ;

\ *** Block No. 64, Hexblock 40

\ 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 ;

\ *** Block No. 65, Hexblock 41

\ ?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  ;


\ *** Block No. 66, Hexblock 42

\                             13FEB85KS)

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

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

| VARIABLE PTR      \ POINTS INTO STRING









\ *** Block No. 67, Hexblock 43

\ (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 ;

\ *** Block No. 68, Hexblock 44

\ 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! ;

\ *** Block No. 69, Hexblock 45

\ CLEARSTACK HALLOT HEAP HEAP?                       cas 26jan06

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 ;

\ *** Block No. 70, Hexblock 46

\ 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




\ *** Block No. 71, Hexblock 47

\ 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  ! ;




\ *** Block No. 72, Hexblock 48

\ 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

\ *** Block No. 73, Hexblock 49

\ 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

\ *** Block No. 74, Hexblock 4a

\ >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  ;


\ *** Block No. 75, Hexblock 4b

\ : ; 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 ;

\ *** Block No. 76, Hexblock 4c

\ 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> ! ;




\ *** Block No. 77, Hexblock 4d

\ 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 +! ;

\ *** Block No. 78, Hexblock 4e

\  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 ;




\ *** Block No. 79, Hexblock 4f

\ 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 ;





\ *** Block No. 80, Hexblock 50

\ (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

\ *** Block No. 81, Hexblock 51

\
     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












\ *** Block No. 82, Hexblock 52

\ 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

\ *** Block No. 83, Hexblock 53

\\

| : 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 ;










\ *** Block No. 84, Hexblock 54

\ FIND  ' [']                 13JAN85BP)

: 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" HAEH?"  ;

: [COMPILE]   ' , ;             IMMEDIATE RESTRICT

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

: NULLSTRING? ( STRING -- STRING FALSE  / TRUE)
    DUP C@ 0=  DUP  IF NIP THEN ;

\ *** Block No. 85, Hexblock 55

\ >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





\ *** Block No. 86, Hexblock 56

\ INTERPRET INTERACTIVE    31DEC84KS/BP)             cas 26jan06

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 !

\ *** Block No. 87, Hexblock 57

\ 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 ;



\ *** Block No. 88, Hexblock 58

\ 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


\ *** Block No. 89, Hexblock 59

\ ?STACK                      08SEP84KS)               11jan13py

| : 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" ;

\ *** Block No. 90, Hexblock 5a

\ .STATUS PUSH LOAD           08SEP84KS)

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 ;




\ *** Block No. 91, Hexblock 5b

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

: +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/ ;




\ *** Block No. 92, Hexblock 5c

\ 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

\ *** Block No. 93, Hexblock 5d

\ (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


\ *** Block No. 94, Hexblock 5e

\

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

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

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









\ *** Block No. 95, Hexblock 5f

\ -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

\ *** Block No. 96, Hexblock 60

\ 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  ;






\ *** Block No. 97, Hexblock 61

\ 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 ;

\ *** Block No. 98, Hexblock 62

\ 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. ;



\ *** Block No. 99, Hexblock 63

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

: .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 ;




\ *** Block No. 100, Hexblock 64

\ 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


\ *** Block No. 101, Hexblock 65

\ BUFFER MECHANISM            15DEC83KS)             cas 26jan06

USER FILE           0 FILE !    \ ADR OF FILE CONTROL BLOCK

VARIABLE PREV       0 PREV !    \ LISTHEAD

| VARIABLE BUFFERS  0 BUFFERS ! \ SEMAPHOR

0408 CONSTANT B/BUF             \ size of buffer








\ *** Block No. 102, Hexblock 66

\\ structure of buffer (same for all volksFORTH )    cas 26jan06
 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 )




\ *** Block No. 103, Hexblock 67

\ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP)

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= ?[



\ *** Block No. 104, Hexblock 68

\   "                         11JUN85BP)

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


\ *** Block No. 105, Hexblock 69

\\ (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




\ *** Block No. 106, Hexblock 6a

\ (DISKERR                    11JUN85BP)

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


DEFER DISKERR  ' (DISKERR  IS DISKERR

DEFER R/W







\ *** Block No. 107, Hexblock 6b

\ BACKUP EMPTYBUF READBLK     11JUN85BP)
| : 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>  ;

\ *** Block No. 108, Hexblock 6c

\ TAKE MARK UPDATES? FULL? CORE?     BP)

| : 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 No. 109, Hexblock 6d

\ BLOCK & BUFFER MANIPULATION 11JUN85BP)

: (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 No. 110, Hexblock 6e

\ BLOCK & BUFFER MANIPULATION 09SEP84KS)

: 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 ;


\ *** Block No. 111, Hexblock 6f

\ MOVING BLOCKS               15DEC83KS)             cas 26jan06
| : (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" NO!!"  BLKMOVE ;

\ *** Block No. 112, Hexblock 70

\ ALLOCATING BUFFERS          23SEP83KS)               12jan13py

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 ;


\ *** Block No. 113, Hexblock 71

\ 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  ;

\ *** Block No. 114, Hexblock 72

\ 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



\ *** Block No. 115, Hexblock 73

\ 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 ;


\ *** Block No. 116, Hexblock 74

\  FORGET-WORDS                                      cas 26jan06

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











\ *** Block No. 117, Hexblock 75

\ 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 ! ;





\ *** Block No. 118, Hexblock 76

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

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

: BYE       FLUSH EMPTY (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 ;



\ *** Block No. 119, Hexblock 77

\ 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


\ *** Block No. 120, Hexblock 78

\ 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





\ *** Block No. 121, Hexblock 79

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

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

DEFER  'COLD    ' NOOP IS 'COLD

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

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


\ *** Block No. 122, Hexblock 7a

\ COLD BOOTSYSTEM RESTART     09JUL85WE)
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= ?]
LABEL WARMBOOT  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
LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE


\ *** Block No. 123, Hexblock 7b

\ ( RESTART  PARAM.-PASSING TO FORTH   BP)

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












\ *** Block No. 124, Hexblock 7c

\ CODE FOR PARAMETER-PASSING TO FORTH                cas 26jan06

\ Include system dependent Input / Output code
\ (Keyboard and Screen)
include systemio.fb


HOST  ' TRANSIENT 8 + @
TRANSIENT  FORTH  CONTEXT @ 6 + !
TARGET

FORTH ALSO DEFINITIONS

: FORTH-83 ;  \ LAST WORD IN DICTIONARY



\ *** Block No. 125, Hexblock 7d

\ 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

\ *** Block No. 126, Hexblock 7e

\
NEXT   CONSTANT NEXT
XYNEXT CONSTANT XYNEXT
(2DROP CONSTANT POPTWO
(DROP  CONSTANT POP












\ *** Block No. 127, Hexblock 7f

\ SYSTEM PATCHUP              05JAN85BP)             cas 26jan06

FORTH DEFINITIONS

\ change memory layout for stacks and buffers here
6000 ' LIMIT >BODY !
$5800 S0 !  $5B00 R0 !

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

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



\ *** Block No. 128, Hexblock 80


















\ *** Block No. 129, Hexblock 81


















\ *** Block No. 130, Hexblock 82


















\ *** Block No. 131, Hexblock 83

















