Screen 0 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13 ende 123                                                        
14                                                                 
15                                                                 
Screen 1 not modified     
 0 \ volksFORTH Loadscreen                             cas2013apr05
 1 forth definitions                                               
 2 : (C [compile] ( ; IMMEDIATE  \ : ) ; IMMEDIATE                 
 3                                                                 
 4 $0300 CONSTANT BASEADDR       \ base address of forth image     
 5 $7F00 CONSTANT TOPADDR                                          
 6 BASEADDR DISPLACE !                                             
 7 TARGET DEFINITIONS BASEADDR HERE!                               
 8                                                                 
 9 hex &01 &126  +THRU                                             
10 decimal                                                         
11 \ ASSEMBLER NONRELOCATE                                         
12                                                                 
13 .UNRESOLVED                  \ if this prints unresolved        
14                              \ definitions, check code          
15 CR .( SAVE-TARGET 6502-FORTH83)                                 
Screen 2 not modified     
 0 \ FORTH PREAMBLE AND ID                              cas20130405
 1                                                                 
 2                                                                 
 3 ASSEMBLER                                                       
 4   NOP  0 JMP  HERE 2- >LABEL >COLD                              
 5   NOP  0 JMP  HERE 2- >LABEL >RESTART                           
 6                                                                 
 7 HERE DUP ORIGIN!                                                
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 3 not modified     
 0 \ Coldstartvalues and user variables                cas2013apr05
 1 \                                                               
 2                                                                 
 3 0 JMP  0 JSR  HERE 2- >LABEL >WAKE                              
 4  END-CODE                                                       
 5                                                                 
 6 0D6 ALLOT                                                       
 7                                                                 
 8 \ Bootlabel                                                     
 9 ," VolksForth-83 3.8 COMPILED 05apr13CS"                        
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 4 not modified     
 0 \ ZERO PAGE VARIABLES & NEXT                         cas 26jan06
 1 \ adjust this to match your architecture                        
 2                                                                 
 3                                                                 
 4 20 DUP     >LABEL RP     2+                                     
 5    DUP     >LABEL UP     2+                                     
 6    DUP     >LABEL PUTA   1+                                     
 7    DUP     >LABEL SP     2+                                     
 8    DUP     >LABEL NEXT                                          
 9    DUP 5 + >LABEL IP                                            
10       13 + >LABEL W                                             
11                                                                 
12      W 8 + >LABEL N                                             
13                                                                 
14                                                                 
15                                                                 
Screen 5 not modified     
 0 \ NEXT, MOVED INTO ZERO PAGE  08APR85BP)                        
 1                                                                 
 2 LABEL BOOTNEXT                                                  
 3    -1 STA              \ -1 IS DUMMY SP                         
 4    IP )Y LDA  W 1+  STA                                         
 5    -1 LDA     W STA    \ -1 IS DUMMY IP                         
 6    CLC IP LDA  2 # ADC  IP STA                                  
 7      CS NOT ?[ LABEL WJMP -1 ) JMP ]?                           
 8    IP 1+ INC  WJMP BCS END-CODE                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 6 not modified     
 0 \  Bootnext and Endtrace                             cas 26jan06
 1 HERE BOOTNEXT - >LABEL BOOTNEXTLEN                              
 2                                                                 
 3 CODE END-TRACE  ( PATCH NEXT FOR TRACE )                        
 4  0A5 # LDA  NEXT 0A + STA                                       
 5   IP # LDA  NEXT 0B + STA                                       
 6  069 # LDA  NEXT 0C + STA                                       
 7   02 # LDA  NEXT 0D + STA                                       
 8  NEXT JMP   END-CODE                                            
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 7 not modified     
 0 \ ;C:  NOOP                                          cas 26jan06
 1                                                                 
 2 CREATE RECOVER  ASSEMBLER                                       
 3  PLA  W STA  PLA  W 1+ STA                                      
 4  W WDEC  0 JMP   END-CODE                                       
 5                                                                 
 6 HERE 2- >LABEL >RECOVER                                         
 7 \ manual forward reference for JMP command                      
 8                                                                 
 9                                                                 
10 COMPILER ASSEMBLER ALSO DEFINITIONS                             
11  H : ;C:   0 T RECOVER JSR                                      
12  END-CODE  ] H ;                                                
13 TARGET                                                          
14 CODE NOOP   NEXT HERE 2- !  END-CODE                            
15                                                                 
Screen 8 not modified     
 0 \ USER VARIABLES                                    cas2013apr05
 1                                                                 
 2 CONSTANT ORIGIN  8 UALLOT DROP                                  
 3                  \ FOR MULTITASKER                              
 4                                                                 
 5 \ Adjust memory values for data stack and return stack here     
 6 USER S0   TOPADDR $F00 - S0 !   USER R0  TOPADDR $480 - R0 !    
 7 USER DP                         USER OFFSET      0 OFFSET !     
 8 USER BASE      &10 BASE !       USER OUTPUT                     
 9 USER INPUT                                                      
10 USER ERRORHANDLER               \ POINTER FOR  ABORT" -CODE     
11 USER VOC-LINK                                                   
12 USER UDP                \ POINTS TO NEXT FREE ADDR IN USER      
13                                                                 
14                                                                 
15                                                                 
Screen 9 not modified     
 0 \ MANIPULATE SYSTEM POINTERS  29JAN85BP)                        
 1                                                                 
 2 CODE SP@   ( -- ADDR)                                           
 3  SP LDA  N STA  SP 1+ LDA  N 1+ STA                             
 4  N # LDX                                                        
 5 LABEL XPUSH                                                     
 6  SP 2DEC  1 ,X LDA  SP )Y STA                                   
 7  0 ,X LDA  0 # LDX  PUTA JMP   END-CODE                         
 8                                                                 
 9 CODE SP!   ( ADDR --)                                           
10  SP X) LDA  TAX  SP )Y LDA                                      
11  SP 1+ STA  SP STX   0 # LDX                                    
12  NEXT JMP   END-CODE                                            
13                                                                 
14                                                                 
15                                                                 
Screen 10 not modified     
 0 \  UP@ UP!  XPULL (XYDROP (DROP                      cas 26jan06
 1 CODE UP@   ( -- ADDR)                                           
 2  UP # LDX  XPUSH JMP  END-CODE                                  
 3                                                                 
 4 CODE UP!   ( ADDR --)      UP # LDX                             
 5 LABEL XPULL     SP )Y LDA  1 ,X STA                             
 6             DEY SP )Y LDA  0 ,X STA                             
 7 LABEL (XYDROP   0 # LDX  1 # LDY                                
 8 LABEL (DROP     SP 2INC  NEXT JMP                               
 9 END-CODE RESTRICT                                               
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 11 not modified     
 0 \ MANIPULATE RETURNSTACK   16FEB85BP/KS)                        
 1 CODE RP@ ( -- ADDR )                                            
 2  RP # LDX  XPUSH JMP  END-CODE                                  
 3                                                                 
 4 CODE RP! ( ADDR -- )                                            
 5  RP # LDX  XPULL JMP  END-CODE RESTRICT                         
 6                                                                 
 7 CODE >R  ( 16B --  )                                            
 8  RP 2DEC  SP X) LDA   RP X) STA                                 
 9  SP )Y LDA   RP )Y STA (DROP JMP                                
10 END-CODE RESTRICT                                               
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 12 not modified     
 0 \  R> (RDROP (NRDROP                                 cas 26jan06
 1 CODE R>  ( -- 16B)                                              
 2  SP 2DEC  RP X) LDA  SP X) STA                                  
 3           RP )Y LDA  SP )Y STA                                  
 4 LABEL (RDROP     2 # LDA                                        
 5                                                                 
 6 LABEL (NRDROP    CLC  RP ADC  RP STA                            
 7     CS ?[  RP 1+ INC  ]?                                        
 8  NEXT JMP  END-CODE  RESTRICT                                   
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 13 not modified     
 0 \ R@ RDROP  EXIT  ?EXIT       08APR85BP)                        
 1                                                                 
 2 CODE R@      ( -- 16B)                                          
 3  SP 2DEC  RP )Y LDA  SP )Y STA                                  
 4           RP X) LDA  PUTA JMP                                   
 5 END-CODE                                                        
 6 CODE RDROP    (RDROP HERE 2- !                                  
 7 END-CODE   RESTRICT                                             
 8                                                                 
 9 CODE EXIT                                                       
10  RP X) LDA  IP STA                                              
11  RP )Y LDA  IP 1+ STA                                           
12  (RDROP JMP   END-CODE                                          
13                                                                 
14                                                                 
15                                                                 
Screen 14 not modified     
 0 \ EXECUTE  PERFORM            08APR85BP)                        
 1                                                                 
 2 CODE ?EXIT     ( FLAG -- )                                      
 3  SP X) LDA  SP )Y ORA                                           
 4  PHP  SP 2INC  PLP                                              
 5  ' EXIT @ BNE  NEXT JMP                                         
 6 END-CODE                                                        
 7                                                                 
 8 CODE EXECUTE  ( ADDR --)                                        
 9  SP X) LDA   W STA                                              
10  SP )Y LDA   W 1+ STA                                           
11  SP 2INC     W 1- JMP   END-CODE                                
12                                                                 
13 : PERFORM ( ADDR -- )   @ EXECUTE ;                             
14                                                                 
15                                                                 
Screen 15 not modified     
 0 \ C@   C! CTOGGLE             10JAN85BP)                        
 1                                                                 
 2 CODE C@ ( ADDR -- 8B)                                           
 3                                                                 
 4  SP X) LDA  N STA   SP )Y LDA  N 1+ STA                         
 5 LABEL (C@    0 # LDA  SP )Y STA                                 
 6  N X)  LDA   PUTA JMP   END-CODE                                
 7                                                                 
 8 CODE C!  ( 16B ADDR --)                                         
 9  SP X) LDA   N STA   SP )Y LDA  N 1+ STA                        
10  INY  SP )Y LDA  N X) STA DEY                                   
11 LABEL (2DROP                                                    
12  SP LDA  CLC  4 # ADC  SP STA                                   
13    CS ?[  SP 1+ INC  ]?                                         
14  NEXT JMP   END-CODE                                            
15                                                                 
Screen 16 not modified     
 0 \ @ ! +!                      08APR85BP)               er14dez88
 1                                                                 
 2 : CTOGGLE   ( 8B ADDR --) UNDER C@ XOR SWAP C! ;                
 3                                                                 
 4 CODE @  ( ADDR -- 16B)                                          
 5  SP X) LDA  N STA  SP )Y LDA  N 1+ STA                          
 6  N )Y LDA  SP )Y STA                                            
 7  N X) LDA PUTA JMP   END-CODE                                   
 8                                                                 
 9 CODE !   ( 16B ADDR --)                                         
10  SP X) LDA  N STA  SP )Y LDA  N 1+ STA                          
11  INY SP )Y LDA  N X) STA                                        
12  INY SP )Y LDA   1 # LDY                                        
13 LABEL (!                                                        
14  N )Y STA  (2DROP JMP   END-CODE                                
15                                                                 
Screen 17 not modified     
 0 \ +!   DROP                                          cas 26jan06
 1                                                                 
 2 CODE +!  ( N ADDR --)                                           
 3  SP X) LDA  N STA  SP )Y LDA  N 1+ STA                          
 4  INY  SP )Y LDA  CLC  N X) ADC N X) STA                         
 5  INY  SP )Y LDA  1 # LDY  N )Y ADC                              
 6  (! JMP   END-CODE                                              
 7                                                                 
 8 CODE DROP  ( 16B --)                                            
 9  (DROP HERE 2- !  END-CODE                                      
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 18 not modified     
 0 \ SWAP                                               cas 26jan06
 1 CODE SWAP  ( 16B1 16B2 -- 16B2 16B1 )                           
 2  SP )Y LDA  TAX                                                 
 3  3 # LDY  SP )Y LDA  N STA                                      
 4  TXA  SP )Y STA                                                 
 5  N LDA  1 # LDY  SP )Y STA                                      
 6  INY  0 # LDX                                                   
 7  SP )Y LDA  N STA  SP X) LDA  SP )Y STA                         
 8  DEY                                                            
 9  N LDA PUTA JMP   END-CODE                                      
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 19 not modified     
 0 \ DUP  ?DUP                   08MAY85BP)             cas 26jan06
 1                                                                 
 2 CODE DUP   ( 16B -- 16B 16B)                                    
 3  SP 2DEC                                                        
 4  3 # LDY  SP )Y LDA  1 # LDY  SP )Y STA                         
 5  INY  SP )Y LDA  DEY                                            
 6  PUTA JMP   END-CODE                                            
 7                                                                 
 8 CODE ?DUP     ( 16B -- 16B 16B / FALSE)                         
 9  SP X) LDA  SP )Y ORA                                           
10    0= ?[  NEXT JMP  ]?                                          
11  ' DUP @ JMP END-CODE                                           
12 \\ ?DUP and DUP in FORTH                                        
13 \   : ?DUP   ( 16B -- 16B 16B / FALSE)                          
14 \    DUP  IF  DUP  THEN ;                                       
15 \   : DUP    SP@  @  ;                                          
Screen 20 not modified     
 0 \ OVER ROT                    13JUN84KS)             cas 26jan06
 1                                                                 
 2 CODE OVER  ( 16B1 16B2 - 16B1 16B3 16B1)                        
 3  SP 2DEC  4 # LDY  SP )Y LDA  SP X) STA                         
 4  INY  SP )Y LDA  1 # LDY  SP )Y STA                             
 5  NEXT JMP   END-CODE                                            
 6                                                                 
 7 \\ ROT OVER in FORTH                                            
 8 \   : ROT   >R SWAP R> SWAP ;                                   
 9 \   : OVER  >R DUP R> SWAP ;                                    
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 21 not modified     
 0 \ ROT                                                cas 26jan06
 1 CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1)                    
 2  3 # LDY  SP )Y LDA  N 1+ STA                                   
 3  1 # LDY  SP )Y LDA  3 # LDY  SP )Y STA                         
 4  5 # LDY  SP )Y LDA  N STA                                      
 5  N 1+ LDA  SP )Y STA                                            
 6  1 # LDY  N LDA  SP )Y STA                                      
 7  INY  SP )Y LDA  N 1+ STA                                       
 8  SP X) LDA  SP )Y STA                                           
 9  4 # LDY  SP )Y LDA  SP X) STA                                  
10  N 1+ LDA  SP )Y STA                                            
11  1 # LDY  NEXT JMP   END-CODE                                   
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 22 not modified     
 0 \ -ROT NIP UNDER PICK ROLL    24DEC83KS)             cas 26jan06
 1 : -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2)                      
 2         ROT ROT ;                                               
 3                                                                 
 4 : NIP   ( 16B1 16B2 -- 16B2) SWAP DROP ;                        
 5                                                                 
 6 : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ;              
 7                                                                 
 8 : PICK  ( N -- 16B.N )   1+ 2* SP@ + @ ;                        
 9                                                                 
10 : ROLL  ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE>  DROP ;  
11                                                                 
12 \\ : -ROLL ( N --)                                              
13  >R DUP SP@  DUP 2+ DUP 2+ SWAP                                 
14  R@ 2* CMOVE R> 1+ 2* + ! ;                                     
15                                                                 
Screen 23 not modified     
 0 \ DOUBLE WORD STACK MANIP.    21APR83KS)                        
 1                                                                 
 2 : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ;               
 3                                                                 
 4 CODE 2DROP ( 32B -- )                                           
 5  (2DROP HERE 2- !   END-CODE                                    
 6                                                                 
 7 : 2DUP  ( 32B -- 32B 32B) OVER OVER ;                           
 8                                                                 
 9 \  : 2DROP ( 32B -- )     DROP DROP ;                           
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 24 not modified     
 0 \ + AND OR XOR                08APR85BP)                        
 1 COMPILER  ASSEMBLER ALSO DEFINITIONS                            
 2                                                                 
 3 H : DYADOP ( OPCODE --)  T                                      
 4    INY  SP X) LDA  DUP C, SP C, SP )Y STA                       
 5    DEY  SP )Y LDA  3 # LDY  C, SP C, SP )Y STA                  
 6    (XYDROP JMP  H ;                                             
 7 TARGET                                                          
 8                                                                 
 9 CODE +     ( N1 N2 -- N3) CLC     071 DYADOP   END-CODE         
10                                                                 
11 CODE OR    ( 16B1 16B2 -- 16B3)   011 DYADOP   END-CODE         
12                                                                 
13 CODE AND   ( 16B1 16B2 -- 16B3)   031 DYADOP   END-CODE         
14                                                                 
15 CODE XOR   ( 16B1 16B2 -- 16B3)   051 DYADOP   END-CODE         
Screen 25 not modified     
 0 \ -  NOT  NEGATE              24DEC83KS)                        
 1                                                                 
 2 CODE -    ( N1 N2 -- N3)                                        
 3  INY SP )Y LDA  SEC SP X) SBC SP )Y STA INY SP )Y LDA           
 4  1 # LDY  SP )Y SBC  3 # LDY  SP )Y STA (XYDROP JMP   END-CODE  
 5                                                                 
 6 CODE NOT   ( 16B1 -- 16B2)   CLC                                
 7 LABEL (NOT TXA  SP X) SBC  SP X) STA  TXA SP )Y SBC  SP )Y STA  
 8        NEXT JMP   END-CODE                                      
 9                                                                 
10 CODE NEGATE   ( N1 -- N2 ) SEC  (NOT BCS   END-CODE             
11                                                                 
12 \ : -       NEGATE + ;                                          
13                                                                 
14                                                                 
15                                                                 
Screen 26 not modified     
 0 \ DNEGATE SETUP D+            14JUN84KS)                        
 1                                                                 
 2 CODE DNEGATE ( D1 -- -D1)                                       
 3  INY  SEC                                                       
 4  TXA  SP )Y SBC  SP )Y STA  INY                                 
 5  TXA  SP )Y SBC  SP )Y STA                                      
 6  TXA  SP X) SBC  SP X) STA  1 # LDY                             
 7  TXA  SP )Y SBC  SP )Y STA                                      
 8  NEXT JMP  END-CODE                                             
 9 LABEL SETUP  ( QUAN  IN A)                                      
10  .A ASL TAX TAY  DEY                                            
11     [[ SP )Y LDA  N ,Y STA  DEY  0< ?]                          
12  TXA  CLC  SP ADC  SP STA                                       
13     CS ?[  SP 1+ INC  ]?                                        
14  0 # LDX  1 # LDY   RTS   END-CODE                              
15                                                                 
Screen 27 not modified     
 0 \ D+                                                 cas 26jan06
 1 CODE D+      ( D1 D2 -- D3)                                     
 2  2 # LDA  SETUP JSR  INY                                        
 3  SP )Y LDA  CLC N 2+  ADC SP )Y STA INY                         
 4  SP )Y LDA      N 3 + ADC SP )Y STA                             
 5  SP X) LDA  N    ADC SP X) STA  1 # LDY                         
 6  SP )Y LDA  N 1+ ADC SP )Y STA                                  
 7  NEXT JMP   END-CODE                                            
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 28 not modified     
 0 \ 1+ 2+ 3+    1- 2-           08APR85BP)                        
 1                                                                 
 2 CODE 1+   ( N1 -- N2)   1 # LDA                                 
 3 LABEL N+  CLC  SP X) ADC                                        
 4  CS NOT   ?[  PUTA JMP  ]?                                      
 5  SP X) STA  SP )Y LDA  0 # ADC SP )Y STA                        
 6  NEXT JMP  END-CODE                                             
 7                                                                 
 8 CODE 2+   ( N1 -- N2) 2 # LDA   N+ BNE     END-CODE             
 9                                                                 
10 CODE 3+   ( N1 -- N2) 3 # LDA   N+ BNE     END-CODE             
11                                                                 
12 | CODE 4+ ( N1 -- N2) 4 # LDA   N+ BNE     END-CODE             
13                                                                 
14 | CODE 6+ ( N1 -- N2) 6 # LDA   N+ BNE     END-CODE             
15                                                                 
Screen 29 not modified     
 0 \ NUMBER CONSTANTS            24DEC83KS)                        
 1 CODE 1-   ( N1 -- N2)   SEC                                     
 2 LABEL (1-     SP X) LDA  1 # SBC                                
 3    CS ?[ PUTA JMP ]?                                            
 4  SP X) STA  SP )Y LDA  0 # SBC SP )Y STA                        
 5  NEXT JMP  END-CODE                                             
 6 CODE 2-   ( N1 -- N2)  CLC (1- BCC  END-CODE                    
 7                                                                 
 8 -1 CONSTANT TRUE    0 CONSTANT FALSE                            
 9 ' TRUE ALIAS -1     ' FALSE ALIAS 0                             
10                                                                 
11 1 CONSTANT 1        2 CONSTANT 2                                
12 3 CONSTANT 3        4 CONSTANT 4                                
13                                                                 
14 : ON    ( ADDR -- )  TRUE  SWAP ! ;                             
15 : OFF   ( ADDR -- )  FALSE SWAP ! ;                             
Screen 30 not modified     
 0 \ WORDS FOR NUMBER LITERALS   24MAY84KS)               cs08aug05
 1                                                                 
 2 CODE CLIT  ( -- 8B)                                             
 3  SP 2DEC  IP X) LDA  SP X) STA TXA   SP )Y STA  IP WINC         
 4  NEXT JMP   END-CODE RESTRICT                                   
 5                                                                 
 6 CODE LIT   ( -- 16B)                                            
 7  SP 2DEC  IP )Y LDA  SP )Y STA IP X) LDA  SP X) STA             
 8 LABEL (BUMP   IP 2INC NEXT JMP  END-CODE RESTRICT               
 9 : LITERAL   ( 16B --) DUP 0FF00 AND                             
10    IF  COMPILE LIT   , EXIT THEN COMPILE CLIT C,  ;             
11                                          IMMEDIATE RESTRICT     
12                                                                 
13 \\ : LIT     R> DUP 2+ >R  @  ;                                 
14    : CLIT    R> DUP 1+ >R  C@ ;                                 
15                                                                 
Screen 31 not modified     
 0 \ COMPARISION CODE WORDS      13JUN84KS)                        
 1 CODE 0<   ( N -- FLAG) SP )Y LDA  0< ?[                         
 2      LABEL PUTTRUE    0FF # LDA  024 C, ]?                      
 3      LABEL PUTFALSE   TXA  SP )Y STA                            
 4                       PUTA JMP   END-CODE                       
 5                                                                 
 6 CODE 0=   ( 16B -- FLAG)                                        
 7  SP X) LDA  SP )Y ORA PUTTRUE  BEQ PUTFALSE BNE  END-CODE       
 8                                                                 
 9 CODE UWITHIN  ( U1 [LOW UP[  -- FLAG)                           
10  2 # LDA  SETUP JSR 1 # LDY  SP X) LDA  N CMP                   
11           SP )Y LDA  N 1+ SBC                                   
12   CS NOT ?[ ( N>SP) SP X) LDA N 2+  CMP                         
13                     SP )Y LDA N 3 + SBC                         
14            PUTTRUE BCS ]?                                       
15  PUTFALSE JMP  END-CODE                                         
Screen 32 not modified     
 0 \ COMPARISION CODE WORDS      13JUN84KS)                        
 1                                                                 
 2 CODE <    ( N1 N2 -- FLAG)                                      
 3  SP X) LDA  N STA  SP )Y LDA  N 1+ STA                          
 4  SP 2INC                                                        
 5  N 1+ LDA  SP )Y EOR  ' 0< @  BMI                               
 6  SP X) LDA  N CMP  SP )Y LDA  N 1+ SBC                          
 7  ' 0< @ 2+ JMP    END-CODE                                      
 8                                                                 
 9 CODE U<   ( U1 U2 -- FLAG)                                      
10  SP X) LDA  N STA  SP )Y LDA  N 1+ STA                          
11  SP 2INC                                                        
12  SP X) LDA  N CMP  SP )Y LDA  N 1+ SBC                          
13    CS NOT ?[  PUTTRUE JMP  ]?                                   
14               PUTFALSE JMP  END-CODE                            
15                                                                 
Screen 33 not modified     
 0 \ COMPARISION WORDS           24DEC83KS)                        
 1                                                                 
 2 | : 0<   8000 AND  0<> ;                                        
 3                                                                 
 4 : >   ( N1 N2 -- FLAG)  SWAP < ;                                
 5 : 0>  ( N --     FLAG)  NEGATE 0<  ;                            
 6 : 0<> ( N --     FLAG)  0= NOT ;                                
 7 : U>  ( U1 U2 -- FLAG)  SWAP U< ;                               
 8 : =   ( N1 N2 -- FLAG)  - 0= ;                                  
 9 : D0= ( D --     FLAG)  OR 0= ;                                 
10 : D=  ( D1 D2 -- FLAG)  DNEGATE D+ D0= ;                        
11 : D<  ( D1 D2 -- FLAG)  ROT 2DUP -                              
12                         IF > NIP NIP  ELSE 2DROP U< THEN ;      
13                                                                 
14                                                                 
15                                                                 
Screen 34 not modified     
 0 \ MIN MAX UMAX UMIN EXTEND DABS ABS                  cas 26jan06
 1                                                                 
 2 | : MINIMAX  ( N1 N2 FLAG -- N3)                                
 3    RDROP  IF SWAP THEN DROP ;                                   
 4                                                                 
 5 : MIN   ( N1 N2 -- N3) 2DUP  > MINIMAX ;   -2 ALLOT             
 6 : MAX   ( N1 N2 -- N3) 2DUP  < MINIMAX ;   -2 ALLOT             
 7 : UMAX  ( U1 U2 -- U3) 2DUP U< MINIMAX ;   -2 ALLOT             
 8 : UMIN  ( U1 U2 -- U3) 2DUP U> MINIMAX ;   -2 ALLOT             
 9                                                                 
10 : EXTEND  ( N -- D)     DUP 0< ;                                
11                                                                 
12 : DABS    ( D -- UD)  EXTEND IF  DNEGATE THEN ;                 
13 : ABS     ( N -- U)   EXTEND IF   NEGATE THEN ;                 
14                                                                 
15                                                                 
Screen 35 not modified     
 0 \ LOOP PRIMITIVES          08FEB85BP/KS)                        
 1                                                                 
 2 | : DODO  RDROP R> 2+ DUP >R ROT >R SWAP >R >R ;                
 3                                                                 
 4                                                                 
 5 : (DO  ( LIMIT STAR -- ) OVER - DODO ;  -2 ALLOT RESTRICT       
 6                                                                 
 7 : (?DO ( LIMIT START -- )                                       
 8  OVER - ?DUP  IF DODO THEN R> DUP @ +  >R DROP ; RESTRICT       
 9                                                                 
10 : BOUNDS  ( START COUNT -- LIMIT START ) OVER + SWAP ;          
11                                                                 
12 CODE  ENDLOOP 6 # LDA (NRDROP JMP   END-CODE RESTRICT           
13                                                                 
14 \\ DODO PUTS  "INDEX \ LIMIT \                                  
15  ADR.OF.DO"  ON RETURN-STACK                                    
Screen 36 not modified     
 0 \ (LOOP (+LOOP                08APR85BP)                        
 1 CODE (LOOP                                                      
 2  CLC  1 # LDA  RP X) ADC RP X) STA                              
 3    CS ?[  RP )Y LDA  0 # ADC RP )Y STA                          
 4       CS ?[ NEXT JMP ]? ]?                                      
 5 LABEL DOLOOP  5 # LDY                                           
 6  RP )Y LDA  IP 1+ STA  DEY                                      
 7  RP )Y LDA  IP    STA  1 # LDY                                  
 8  NEXT JMP    END-CODE RESTRICT                                  
 9                                                                 
10 CODE (+LOOP                                                     
11  CLC SP X) LDA  RP X) ADC  RP X) STA                            
12      SP )Y LDA  RP )Y ADC  RP )Y STA                            
13  .A ROR  SP )Y EOR                                              
14  PHP  SP 2INC  PLP DOLOOP BPL                                   
15  NEXT JMP    END-CODE RESTRICT                                  
Screen 37 not modified     
 0 \ LOOP INDICES                08APR85BP)                        
 1                                                                 
 2 CODE I  ( -- N)    0 # LDY                                      
 3 LABEL LOOPINDEX    SP 2DEC   CLC                                
 4  RP )Y LDA  INY  INY                                            
 5  RP )Y ADC  SP X) STA  DEY                                      
 6  RP )Y LDA  INY  INY                                            
 7  RP )Y ADC  1 # LDY  SP )Y STA                                  
 8  NEXT JMP   END-CODE RESTRICT                                   
 9                                                                 
10 CODE J  ( -- N)                                                 
11  6 # LDY  LOOPINDEX BNE                                         
12             END-CODE  RESTRICT                                  
13                                                                 
14                                                                 
15                                                                 
Screen 38 not modified     
 0 \ BRANCHING                   24DEC83KS)                        
 1                                                                 
 2 CODE BRANCH                                                     
 3  CLC  IP    LDA  IP X) ADC  N STA                               
 4       IP 1+ LDA  IP )Y ADC  IP 1+ STA  N LDA IP STA             
 5  NEXT JMP     END-CODE RESTRICT                                 
 6                                                                 
 7 CODE ?BRANCH                                                    
 8  SP X) LDA  SP )Y ORA PHP  SP 2INC  PLP                         
 9  ' BRANCH @ BEQ    (BUMP JMP  END-CODE   RESTRICT               
10                                                                 
11 \\  : BRANCH   R> DUP @ + >R ; RESTRICT                         
12                                                                 
13     : ?BRANCH                                                   
14      0= R> OVER NOT OVER 2+  AND -ROT                           
15      DUP @ + AND OR >R ;       RESTRICT                         
Screen 39 not modified     
 0 \ RESOLVE LOOPS AND BRANCHES  03FEB85BP)                        
 1                                                                 
 2 : >MARK     ( -- ADDR)  HERE   0 , ;                            
 3                                                                 
 4 : >RESOLVE  ( ADDR --)  HERE OVER -   SWAP !  ;                 
 5                                                                 
 6 : <MARK     ( -- ADDR)  HERE ;                                  
 7                                                                 
 8 : <RESOLVE  ( ADDR --)  HERE - ,  ;                             
 9                                                                 
10 : ?PAIRS  ( N1 N2 -- ) -  ABORT" UNSTRUCTURED" ;                
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 40 not modified     
 0 \ CASE?                       04MAY85BP)                        
 1                                                                 
 2 LABEL  PUSHA                                                    
 3  0 # CMP  0< ?[ PHA  0FF # LDA ][                               
 4 LABEL  PUSH0A   PHA   0  # LDA  ]?                              
 5 LABEL  PUSH     TAX   SP 2DEC                                   
 6  TXA  1 # LDY  SP )Y STA                                        
 7  PLA  0 # LDX   PUTA JMP                                        
 8                                                                 
 9 CODE CASE?                                                      
10  ( 16B1 16B2 -- 16B1 FALSE / TRUE )                             
11  1 # LDA  SETUP JSR N LDA  SP X) CMP                            
12   0= ?[   N 1+ LDA  SP )Y CMP 0= ?[ PUTTRUE JMP ]?  ]?          
13  TXA  PUSH0A JMP   END-CODE                                     
14 \\ : CASE?                                                      
15  ( 16B1 16B2 -- 16B1 FALSE / TRUE ) OVER = DUP  IF  NIP  THEN ; 
Screen 41 not modified     
 0 \ BRANCHING                   03FEB85BP)                        
 1                                                                 
 2 : IF     COMPILE ?BRANCH >MARK  1 ;          IMMEDIATE RESTRICT 
 3 : THEN   ABS 1   ?PAIRS  >RESOLVE ;          IMMEDIATE RESTRICT 
 4 : ELSE   1 ?PAIRS  COMPILE BRANCH >MARK                         
 5          SWAP >RESOLVE  -1 ;                 IMMEDIATE RESTRICT 
 6 : BEGIN  <MARK 2 ;                           IMMEDIATE RESTRICT 
 7 : WHILE  2 ?PAIRS  2   COMPILE ?BRANCH                          
 8          >MARK -2  2SWAP  ;                  IMMEDIATE RESTRICT 
 9 | : (REPTIL   <RESOLVE   BEGIN DUP -2                           
10     = WHILE  DROP >RESOLVE  REPEAT  ;                           
11                                                                 
12 : REPEAT 2 ?PAIRS   COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT 
13                                                                 
14 : UNTIL  2 ?PAIRS  COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT 
15                                                                 
Screen 42 not modified     
 0 \ LOOPS                    29JAN85KS/BP)                        
 1                                                                 
 2 : DO     COMPILE (DO  >MARK  3 ;     IMMEDIATE RESTRICT         
 3                                                                 
 4 : ?DO    COMPILE (?DO >MARK  3 ;     IMMEDIATE RESTRICT         
 5                                                                 
 6 : LOOP   3 ?PAIRS  COMPILE (LOOP                                
 7          COMPILE ENDLOOP  >RESOLVE ; IMMEDIATE RESTRICT         
 8                                                                 
 9 : +LOOP  3 ?PAIRS  COMPILE (+LOOP                               
10          COMPILE ENDLOOP  >RESOLVE ; IMMEDIATE RESTRICT         
11                                                                 
12 : LEAVE  ENDLOOP R> 2- DUP @ + >R ;            RESTRICT         
13                                                                 
14 \\ RETURNSTACK: CALLADR \ INDEX                                 
15                   LIMIT \ ADR OF DO                             
Screen 43 not modified     
 0 \ UM*                      BP/KS13.2.85)                        
 1 CODE UM*  ( U1 U2 -- UD)                                        
 2  SP )Y LDA N STA  SP X) LDA  N 1+ STA                           
 3  INY N 2 + STX N 3 + STX  010 # LDX                             
 4   [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL                          
 5    CS ?[ CLC SP )Y LDA  N 3 + ADC  N 3 + STA                    
 6              INY  SP )Y LDA DEY N 2 + ADC   N 2 + STA           
 7            CS ?[  N 1+ INC  0= ?[  N   INC  ]? ]? ]?            
 8     DEX  0= ?]                                                  
 9  N 3 + LDA   SP )Y STA   INY N 2 + LDA   SP )Y STA   1 # LDY    
10  N     LDA   SP )Y STA       N 1+ LDA    SP X) STA              
11  NEXT JMP   END-CODE                                            
12                                                                 
13 \\ : UM*   ( U1 U2 -- UD3) >R 0 0 0 R>  010 0                   
14   DO  DUP 2/ >R  1 AND IF 2OVER D+ THEN                         
15       >R >R 2DUP D+ R> R> R>  LOOP DROP 2SWAP 2DROP ;           
Screen 44 not modified     
 0 \ M* 2*                       04JUL84KS)                        
 1                                                                 
 2 : M*     ( N1 N2 -- D)                                          
 3  DUP 0< DUP >R IF NEGATE THEN                                   
 4  SWAP DUP  0<  IF NEGATE R> NOT >R THEN                         
 5  UM*  R> IF DNEGATE THEN ;                                      
 6                                                                 
 7 : *      ( N N -- PROD)   UM* DROP ;                            
 8                                                                 
 9 CODE 2*  ( N1 -- N2)                                            
10  SP X) LDA  .A ASL  SP X) STA                                   
11  SP )Y LDA  .A ROL  SP )Y STA                                   
12  NEXT JMP    END-CODE                                           
13 | : 2*   DUP + ;                                                
14                                                                 
15                                                                 
Screen 45 not modified     
 0 \ UM/MOD                      04JUL84KS)                        
 1                                                                 
 2 | : DIVOVL                                                      
 3    TRUE ABORT" DIVISION OVERFLOW" ;                             
 4                                                                 
 5 CODE UM/MOD  ( UD U -- UREM UQUOT)                              
 6  SP X) LDA  N 5 + STA                                           
 7  SP )Y LDA  N 4 + STA   SP 2INC                                 
 8  SP X) LDA  N 1+  STA                                           
 9  SP )Y LDA  N     STA   INY                                     
10  SP )Y LDA  N 3 + STA   INY                                     
11  SP )Y LDA  N 2+  STA   011 # LDX  CLC                          
12   [[ N 6 + ROR  SEC  N 1+ LDA  N 5 + SBC                        
13      TAY  N LDA  N 4 + SBC                                      
14     CS NOT ?[  N 6 + ROL ]?                                     
15       CS ?[ N STA  N 1+ STY ]?                                  
Screen 46 not modified     
 0 \                                                               
 1      N 3 + ROL N 2+ ROL N 1+ ROL N ROL                          
 2   DEX  0= ?]                                                    
 3  1 # LDY  N ROR  N 1+ ROR                                       
 4    CS ?[ ;C: DIVOVL ; ASSEMBLER ]?                              
 5  N 2+  LDA SP )Y STA INY                                        
 6  N 1+  LDA SP )Y STA INY                                        
 7  N     LDA SP )Y STA 1 # LDY                                    
 8  N 3 + LDA                                                      
 9  PUTA JMP    END-CODE                                           
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 47 not modified     
 0 \ 2/ M/MOD                    24DEC83KS)                        
 1                                                                 
 2 : M/MOD  ( D N -- MOD QUOT)                                     
 3  DUP >R ABS  OVER                                               
 4    0< IF  UNDER + SWAP  THEN                                    
 5  UM/MOD R@                                                      
 6  0< IF NEGATE OVER IF SWAP R@ + SWAP 1-                         
 7  THEN THEN RDROP ;                                              
 8                                                                 
 9 CODE 2/  ( N1 -- N2)                                            
10  SP )Y LDA  .A ASL                                              
11  SP )Y LDA  .A ROR  SP )Y STA                                   
12  SP X) LDA  .A ROR                                              
13  PUTA JMP      END-CODE                                         
14                                                                 
15                                                                 
Screen 48 not modified     
 0 \ /MOD / MOD */MOD */ U/MOD  UD/MOD  KS)                        
 1                                                                 
 2 : /MOD  ( N1 N2 -- REM QUOT)  >R EXTEND R> M/MOD ;              
 3                                                                 
 4 : /     ( N1 N2 -- QUOT)     /MOD NIP ;                         
 5                                                                 
 6 : MOD   ( N1 N2 -- REM)      /MOD DROP ;                        
 7                                                                 
 8 : */MOD ( N1 N2 N3 -- REM QUOT)  >R M*  R> M/MOD ;              
 9                                                                 
10 : */    ( N1 N2 N3 -- QUOT)  */MOD NIP ;                        
11                                                                 
12 : U/MOD  ( U1 U2  -- UREM UQUOT)  0 SWAP UM/MOD ;               
13                                                                 
14 : UD/MOD ( UD1 U2 -- UREM UDQUOT)                               
15      >R  0  R@  UM/MOD  R> SWAP >R  UM/MOD  R>  ;               
Screen 49 not modified     
 0 \ CMOVE CMOVE> (CMOVE>       BP 08APR85)                        
 1                                                                 
 2 CODE CMOVE  ( FROM TO QUAN --)                                  
 3  3 # LDA SETUP JSR  DEY                                         
 4  [[ [[  N CPY  0= ?[  N 1+ DEC  0< ?[                           
 5                 1 # LDY  NEXT JMP  ]? ]?                        
 6      N 4 + )Y LDA  N 2+ )Y STA INY 0= ?]                        
 7      N 5 + INC N 3 + INC  ]]  END-CODE                          
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 50 not modified     
 0 \  CMOVE> MOVE                                       cas 26jan06
 1 CODE CMOVE> ( FROM TO QUAN --)                                  
 2  3 # LDA SETUP JSR                                              
 3  CLC N 1+ LDA  N 3 + ADC  N 3 + STA                             
 4  CLC N 1+ LDA  N 5 + ADC  N 5 + STA                             
 5  N 1+ INC  N LDY  CLC CS ?[                                     
 6 LABEL (CMOVE>                                                   
 7  DEY  N 4 + )Y LDA  N 2+ )Y STA ]?                              
 8  TYA  (CMOVE> BNE                                               
 9  N 3 + DEC  N 5 + DEC  N 1+ DEC                                 
10  (CMOVE> BNE  1 # LDY                                           
11  NEXT JMP   END-CODE                                            
12                                                                 
13 : MOVE   ( FROM TO QUAN --) >R 2DUP U<  IF R> CMOVE> EXIT THEN  
14                             R> CMOVE ;                          
15                                                                 
Screen 51 not modified     
 0 \ PLACE COUNT  ERASE       16FEB85BP/KS)                        
 1                                                                 
 2 : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ;      
 3                                                                 
 4 CODE COUNT ( ADDR -- ADDR+1 LEN)                                
 5  SP X) LDA N STA CLC 1 # ADC SP X) STA                          
 6  SP )Y LDA N 1+ STA  0 # ADC SP )Y STA                          
 7  SP 2DEC  (C@ JMP   END-CODE                                    
 8                                                                 
 9 \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+  SWAP C@ ;                
10                                                                 
11 : ERASE ( ADDR QUAN --)      0 FILL ;                           
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 52 not modified     
 0 \ FILL                        11JUN85BP)                        
 1                                                                 
 2 CODE FILL  ( ADDR QUAN 8B -- )                                  
 3  3 # LDA SETUP JSR  DEY                                         
 4  N LDA  N 3 + LDX                                               
 5   0<> ?[  [[ [[ N 4 + )Y STA INY 0= ?]                          
 6                 N 5 + INC    DEX 0= ?]                          
 7       ]?  N 2+ LDX                                              
 8   0<> ?[  [[ N 4 + )Y STA INY DEX 0= ?]                         
 9       ]? 1 # LDY                                                
10  NEXT JMP   END-CODE                                            
11                                                                 
12 \\ : FILL  ( ADDR QUAN 8B --)   SWAP ?DUP                       
13        IF  >R OVER C! DUP 1+ R> 1- CMOVE   EXIT  THEN  2DROP  ; 
14                                                                 
15                                                                 
Screen 53 not modified     
 0 \ HERE PAD ALLOT , C, COMPILE 24DEC83KS)                        
 1                                                                 
 2 : HERE  ( -- ADDR)   DP @ ;                                     
 3                                                                 
 4 : PAD   ( -- ADDR)   HERE 042 + ;                               
 5                                                                 
 6 : ALLOT ( N --)      DP +! ;                                    
 7                                                                 
 8 : ,     ( 16B --)    HERE !  2  ALLOT ;                         
 9                                                                 
10 : C,    ( 8B --)     HERE C! 1  ALLOT ;                         
11                                                                 
12 : COMPILE            R> DUP 2+ >R @ , ; RESTRICT                
13                                                                 
14                                                                 
15                                                                 
Screen 54 not modified     
 0 \ INPUT STRINGS               24DEC83KS)                        
 1                                                                 
 2 VARIABLE #TIB   0 #TIB !                                        
 3 VARIABLE >TIB   $100 >TIB !   \  050 ALLOT                      
 4 VARIABLE >IN    0 >IN !                                         
 5 VARIABLE BLK    0 BLK !                                         
 6 VARIABLE SPAN   0 SPAN !                                        
 7                                                                 
 8 : TIB   ( -- ADDR )    >TIB @ ;                                 
 9                                                                 
10 : QUERY TIB  050 EXPECT SPAN @ #TIB !  >IN OFF  BLK OFF ;       
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 55 not modified     
 0 \ SCAN SKIP /STRING           12OCT84BP)                        
 1                                                                 
 2 : SCAN  ( ADDR0 LEN0 CHAR -- ADDR1 LEN1)  >R                    
 3      BEGIN  DUP  WHILE  OVER C@ R@ -                            
 4      WHILE  1- SWAP 1+ SWAP  REPEAT RDROP ;                     
 5                                                                 
 6 : SKIP  ( ADDR LEN DEL -- ADDR1 LEN1)  >R                       
 7      BEGIN  DUP  WHILE  OVER C@ R@ =                            
 8      WHILE  1- SWAP 1+ SWAP  REPEAT     RDROP ;                 
 9                                                                 
10                                                                 
11 : /STRING  ( ADDR0 LEN0 +N - ADDR1 LEN1)                        
12      OVER UMIN ROT OVER + -ROT - ;                              
13                                                                 
14                                                                 
15                                                                 
Screen 56 not modified     
 0 \ CAPITAL                     03APR85BP)                        
 1 (C LABEL (CAPITAL  \ FOR COMMODORE ONLY                         
 2  PHA  0DF # AND    \ 2ND UPPER TO LOWER                         
 3  ASCII A # CMP                                                  
 4  CS ?[  ASCII Z  1+ # CMP                                       
 5     CC ?[  PLA CLC ASCII A ASCII A - # ADC RTS                  
 6   ]? ]?  PLA  RTS  END-CODE )                                   
 7                                                                 
 8 LABEL (CAPITAL  \ FOR ASCII ONLY                                
 9  ASCII a # CMP                                                  
10  CS ?[  ASCII z  1+ # CMP                                       
11     CC ?[      SEC  ASCII a ASCII A - # SBC                     
12   ]? ]?  RTS  END-CODE                                          
13                                                                 
14 CODE CAPITAL  ( CHAR -- CHAR' )                                 
15  SP X) LDA  (CAPITAL JSR  SP X) STA NEXT JMP    END-CODE        
Screen 57 not modified     
 0 \ CAPITALIZE                  03APR85BP)                        
 1                                                                 
 2 CODE CAPITALIZE  ( STRING -- STRING )                           
 3  SP X) LDA N    STA  SP )Y LDA  N 1+ STA                        
 4   N X) LDA N 2+ STA   DEY                                       
 5  [[ N 2+ CPY  0= ?[ 1 # LDY  NEXT JMP ]?                        
 6    INY N )Y LDA  (CAPITAL JSR  N )Y STA                         
 7  ]]   END-CODE                                                  
 8                                                                 
 9 \\ : CAPITALIZE  ( STRING -- STRING )                           
10       DUP  COUNT  BOUNDS ?DO  I C@  CAPITAL  I C!  THEN  LOOP ; 
11                                                                 
12 \\ CAPITAL ( CHAR -- CHAR )                                     
13    ASCII A  ASCII Z 1+  UWITHIN                                 
14    IF  I C@  [ ASCII A  ASCII A - ]  LITERAL -  ;               
15                                                                 
Screen 58 not modified     
 0 \ (WORD                       08APR85BP)                        
 1                                                                 
 2 | CODE (WORD   ( CHAR ADR0 LEN0 -- ADR)                         
 3        \ N   : LENGTH OF SOURCE                                 
 4        \ N+2 : PTR IN SOURCE / NEXT CHAR                        
 5        \ N+4 : STRING START ADRESS                              
 6        \ N+6 : STRING LENGTH                                    
 7  N 6 + STX        \ 0 =: STRING_LENGTH                          
 8  3 # LDY [[ SP )Y LDA  N ,Y STA DEY  0< ?]                      
 9  1 # LDY  CLC  >IN    LDA  N 2+  ADC  N 2+  STA                 
10                   \ >IN+ADR0 =: N+2                             
11  >IN 1+ LDA  N 3 + ADC  N 3 + STA SEC  N LDA  >IN  SBC  N  STA  
12                   \ LEN0->IN =: N                               
13    N 1+ LDA  >IN 1+ SBC  N 1+ STA                               
14   CC ?[ SP X) LDA  >IN    STA  \ STREAM EXHAUSTED               
15         SP )Y LDA  >IN 1+ STA                                   
Screen 59 not modified     
 0 \ (WORD                       08APR85BP)                        
 1                                                                 
 2 ][ 4 # LDY  [[  N LDA  N 1+ ORA         \ SKIP CHAR'S           
 3        0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0       
 4        0=     ?[[ N 2+ WINC  N WDEC ]]?                         
 5     N 2+  LDA  N 4 + STA       \ SAVE STRING_START_ADRESS       
 6     N 3 + LDA  N 5 + STA                                        
 7     [[  N 2+ X) LDA  SP )Y CMP PHP      \ SCAN FOR CHAR         
 8         N 2+ WINC  N WDEC PLP                                   
 9     0= NOT ?[[ N 6 + INC     \ COUNT STRING_LENGTH              
10        N LDA N 1+ ORA                                           
11     0= ?]  ]? ]?              \ FROM COUNT = 0 IN SKIP)         
12  SEC 2 # LDY                                                    
13        \ ADR_AFTER_STRING - ADR0 =: >IN)                        
14  N 2+  LDA  SP )Y SBC  >IN    STA  INY                          
15  N 3 + LDA  SP )Y SBC  >IN 1+ STA                               
Screen 60 not modified     
 0 \ (WORD                       08APR85BP)                        
 1                                                                 
 2 ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED                          
 3    \ WHEN WORD CALLED)                                          
 4  CLC  4 # LDA  SP ADC  SP STA                                   
 5   CS ?[ SP 1+ INC ]?  \ 2DROP                                   
 6  USER' DP # LDY  UP )Y LDA                                      
 7  SP X) STA N    STA  INY                                        
 8  UP )Y LDA 1 # LDY                                              
 9  SP )Y STA N 1+ STA        \ DP @                               
10  DEY N 6 + LDA  \ STORE COUNT BYTE FIRST                        
11  [[  N )Y STA  N 4 + )Y LDA  INY                                
12      N 6 + DEC  0< ?]                                           
13  020 # LDA  N )Y STA       \ ADD A BLANK                        
14  1 # LDY   NEXT JMP   END-CODE                                  
15                                                                 
Screen 61 not modified     
 0 \ SOURCE WORD PARSE NAME      08APR85BP)                        
 1                                                                 
 2 : SOURCE   ( -- ADDR LEN)                                       
 3     BLK @  ?DUP IF  BLOCK B/BLK EXIT THEN  TIB #TIB @  ;        
 4                                                                 
 5 : WORD  ( CHAR -- ADDR)   SOURCE (WORD ;                        
 6                                                                 
 7 : PARSE ( CHAR -- ADDR LEN) >R SOURCE  >IN @  /STRING OVER SWAP 
 8                   R> SCAN >R OVER - DUP R> 0<> - >IN +! ;       
 9                                                                 
10 : NAME   ( -- ADDR)  BL WORD  CAPITALIZE  EXIT  ;               
11                                                                 
12 \\ : WORD  ( CHAR -- ADDR)        >R                            
13  SOURCE  OVER SWAP  >IN @  /STRING  R@ SKIP  OVER  SWAP  R>     
14  SCAN >R  ROT OVER SWAP  - R> 0<> -  >IN !                      
15  OVER - HERE PLACE  BL HERE COUNT + C! HERE ;                   
Screen 62 not modified     
 0 \ STATE ASCII ,"  ("  "       24DEC83KS)                        
 1                                                                 
 2 VARIABLE STATE    0 STATE !                                     
 3                                                                 
 4 : ASCII   BL WORD 1+ C@ STATE @                                 
 5           IF [COMPILE] LITERAL THEN ; IMMEDIATE                 
 6                                                                 
 7 : ,"      ASCII "  PARSE  HERE OVER 1+  ALLOT PLACE  ;          
 8                                                                 
 9 : "LIT    R> R> UNDER COUNT + >R >R ;  RESTRICT                 
10                                                                 
11 : ("      "LIT ; RESTRICT                                       
12                                                                 
13 : "       COMPILE ("  ,"  ; IMMEDIATE RESTRICT                  
14                                                                 
15                                                                 
Screen 63 not modified     
 0 \ ." ( .( \ \\ HEX DECIMAL    08SEP84KS)                        
 1 : (."    "LIT COUNT TYPE ; RESTRICT                             
 2                                                                 
 3 : ."     COMPILE (." ," ;  IMMEDIATE RESTRICT                   
 4                                                                 
 5 : (      ASCII )  PARSE 2DROP ;          IMMEDIATE              
 6                                                                 
 7 : .(     ASCII )  PARSE TYPE ;           IMMEDIATE              
 8                                                                 
 9 : \      >IN @  C/L /  1+ C/L *  >IN ! ; IMMEDIATE              
10                                                                 
11 : \\        B/BLK >IN ! ;  IMMEDIATE                            
12                                                                 
13 : \NEEDS    NAME FIND NIP  IF  [COMPILE] \  THEN ;              
14                                                                 
15 : HEX       010 BASE ! ;        : DECIMAL    0A BASE ! ;        
Screen 64 not modified     
 0 \ NUMBER CONV.:  DIGIT?  ACCUMULATE  KS)                        
 1 : DIGIT?  ( CHAR -- DIGIT TRUE/ FALSE )                         
 2  ASCII 0 -   DUP 9 U>                                           
 3  IF [ ASCII A ASCII 9 - 1- ] LITERAL -  DUP 9 U>                
 4      IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN                        
 5    BASE @  OVER  U>  ?DUP  ?EXIT    THEN DROP  FALSE ;          
 6                                                                 
 7 : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR)                         
 8  SWAP >R SWAP  BASE @ UM*  DROP  ROT  BASE @ UM*  D+  R>  ;     
 9                                                                 
10 : CONVERT  ( +D1 ADDR0 -- +D2 ADDR2)                            
11     1+  BEGIN  COUNT DIGIT? WHILE  ACCUMULATE    REPEAT  1- ;   
12                                                                 
13 | : END?   ( -- FLAG )  PTR @  0= ;                             
14 | : CHAR   ( ADDR0 -- ADDR1 CHAR )   COUNT   -1 PTR +!  ;       
15 | : PREVIOUS  ( ADDR0 -- ADDR0 CHAR) 1-  COUNT ;                
Screen 65 not modified     
 0 \ ?NONUM ?NUM FIXBASE?        13FEB85KS)                        
 1                                                                 
 2 VARIABLE DPL   -1 DPL !                                         
 3                                                                 
 4 | : ?NONUM   ( FLAG -- EXIT IF TRUE )                           
 5      IF RDROP 2DROP DROP RDROP FALSE THEN ;                     
 6                                                                 
 7 | : ?NUM     ( FLAG -- EXIT IF TRUE )                           
 8      IF RDROP DROP R> IF  DNEGATE  THEN                         
 9      ROT DROP  DPL @ 1+  ?DUP ?EXIT DROP TRUE THEN ;            
10 | : FIXBASE? ( CHAR - CHAR FALSE /  NEWBASE TRUE )              
11      ASCII & CASE?  IF 0A TRUE EXIT THEN                        
12      ASCII $ CASE?  IF 10 TRUE EXIT THEN                        
13      ASCII H CASE?  IF 10 TRUE EXIT THEN                        
14      ASCII % CASE?  IF  2 TRUE EXIT THEN FALSE  ;               
15                                                                 
Screen 66 not modified     
 0 \                             13FEB85KS)                        
 1                                                                 
 2 | : PUNCTUATION?   ( CHAR -- FLAG)                              
 3      ASCII , OVER = SWAP ASCII . =  OR ;                        
 4                                                                 
 5 | : ?DPL   DPL @ -1 = ?EXIT  1 DPL +! ;                         
 6                                                                 
 7 | VARIABLE PTR      \ POINTS INTO STRING                        
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 67 not modified     
 0 \ (NUMBER  NUMBER             13FEB85KS)                        
 1 : NUMBER?   ( STRING - STRING FALSE / N 0< / D 0> )             
 2      BASE PUSH  DUP COUNT  PTR !  DPL ON                        
 3      0 >R  ( +SIGN)                                             
 4      0.0 ROT           END? ?NONUM CHAR                         
 5      ASCII - CASE?                                              
 6      IF RDROP TRUE >R  END? ?NONUM CHAR THEN FIXBASE?           
 7      IF  BASE !        END? ?NONUM CHAR THEN                    
 8      BEGIN   DIGIT?  0= ?NONUM                                  
 9        BEGIN  ACCUMULATE  ?DPL  END? ?NUM                       
10           CHAR DIGIT?  0= UNTIL                                 
11        PREVIOUS  PUNCTUATION?  0= ?NONUM                        
12        DPL OFF   END? ?NUM CHAR                                 
13      REPEAT ;                                                   
14 : NUMBER  ( STRING -- D )                                       
15      NUMBER?  ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ;             
Screen 68 not modified     
 0 \ HIDE REVEAL IMMEDIATE RESTRICT     KS)                        
 1 VARIABLE LAST     0 LAST !                                      
 2                                                                 
 3 | : LAST?   ( -- FALSE / ACF TRUE) LAST @ ?DUP ;                
 4                                                                 
 5 : HIDE    LAST?  IF 2- @ CURRENT @ ! THEN ;                     
 6                                                                 
 7 : REVEAL  LAST?  IF 2-   CURRENT @ ! THEN ;                     
 8                                                                 
 9 : RECURSIVE   REVEAL  ;   IMMEDIATE RESTRICT                    
10                                                                 
11 | : FLAG!  ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN   DROP ;  
12                                                                 
13 : IMMEDIATE  040 FLAG! ;                                        
14                                                                 
15 : RESTRICT   080 FLAG! ;                                        
Screen 69 not modified     
 0 \ CLEARSTACK HALLOT HEAP HEAP?                       cas 26jan06
 1                                                                 
 2 CODE CLEARSTACK USER' S0 # LDY                                  
 3      UP )Y LDA  SP    STA  INY UP )Y LDA  SP 1+ STA             
 4      1 # LDY  NEXT JMP   END-CODE                               
 5                                                                 
 6 : HALLOT ( QUAN -- )  S0 @ OVER - SWAP                          
 7      SP@ 2+  DUP ROT -  DUP S0 !                                
 8      2 PICK OVER -  MOVE  CLEARSTACK  S0 ! ;                    
 9                                                                 
10 : HEAP   ( -- ADDR)        S0 @  6+ ;                           
11                                                                 
12 : HEAP?  ( ADDR -- FLAG)   HEAP UP@ UWITHIN ;                   
13                                                                 
14 | : HEAPMOVE   ( FROM -- FROM) DUP HERE  OVER -                 
15       DUP HALLOT  HEAP SWAP CMOVE HEAP OVER - LAST +!  REVEAL ; 
Screen 70 not modified     
 0 \ DOES>  ;                 30DEC84KS/BP)                        
 1                                                                 
 2 LABEL (DODOES>   RP 2DEC                                        
 3       IP 1+ LDA RP )Y STA  IP LDA  RP X) STA  \ PUT IP ON RP    
 4       CLC  W X) LDA  3 # ADC IP STA                             
 5       TXA  W )Y ADC  IP 1+ STA  \ W@ + 3 -> IP                  
 6 LABEL DOCREATE                                                  
 7       2 # LDA  CLC W ADC PHA TXA W 1+ ADC  PUSH JMP END-CODE    
 8                                                                 
 9 | : (;CODE    R> LAST @  NAME>  ! ;                             
10                                                                 
11 : DOES> COMPILE (;CODE  04C C,                                  
12     COMPILE (DODOES> ;  IMMEDIATE RESTRICT                      
13                                                                 
14                                                                 
15                                                                 
Screen 71 not modified     
 0 \ 6502-ALIGN  ?HEAD  \        08SEP84BP)                        
 1                                                                 
 2 | : 6502-ALIGN/1   ( ADR -- ADR' ) DUP  0FF AND  0FF =  - ;     
 3                                                                 
 4                                                                 
 5 | : 6502-ALIGN/2   ( LFA -- LFA )                               
 6    HERE  0FF AND 0FF =                                          
 7    IF  DUP DUP 1+  HERE OVER - 1+ CMOVE>  \ LFA NOW INVALID     
 8        1 LAST +! 1 ALLOT  THEN  ;                               
 9                                                                 
10 VARIABLE ?HEAD    0 ?HEAD !                                     
11                                                                 
12 : |     ?HEAD @   ?EXIT   -1 ?HEAD  ! ;                         
13                                                                 
14                                                                 
15                                                                 
Screen 72 not modified     
 0 \ WARNING   CREATE            30DEC84BP)                        
 1                                                                 
 2 VARIABLE WARNING  0 WARNING !                                   
 3                                                                 
 4 | : EXISTS?                                                     
 5     WARNING @ ?EXIT                                             
 6     LAST @  CURRENT @  (FIND  NIP                               
 7     IF SPACE  LAST @ .NAME ." EXISTS " ?CR THEN  ;              
 8                                                                 
 9 : CREATE  HERE BLK @ ,  CURRENT @ @ ,                           
10     NAME  C@ DUP 1 020  UWITHIN NOT  ABORT" INVALID NAME"       
11     HERE  LAST ! 1+ ALLOT  EXISTS? ?HEAD @                      
12     IF 1 ?HEAD +!  DUP  6502-ALIGN/1 , \ POINTER TO CODE        
13        HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP !                     
14     ELSE  6502-ALIGN/2  DROP THEN  REVEAL  0 ,                  
15     ;CODE  DOCREATE JMP END-CODE                                
Screen 73 not modified     
 0 \ NFA?                        30DEC84BP)                        
 1 | CODE NFA?  ( VOCABTHREAD  CFA -- NFA / FALSE)                 
 2     SP X) LDA  N 4 + STA  SP )Y LDA  N 5 + STA   SP 2INC        
 3     [[ [[ SP X) LDA  N 2+  STA  SP )Y LDA  N 3 + STA            
 4         N 2+ ORA  0= ?[ PUTFALSE JMP ]?                         
 5         N 2+ )Y LDA SP )Y STA  N 1+ STA                         
 6         N 2+ X) LDA SP X) STA  N STA                            
 7         N 1+ ORA  0= ?[  NEXT JMP  ]?  \ N=LINK                 
 8         N 2INC N X) LDA PHA SEC 01F # AND                       
 9         N ADC  N STA  CS ?[ N 1+ INC ]?                         
10          PLA  020 # AND  0= NOT                                 
11          ?[ N )Y LDA  PHA                                       
12             N X) LDA N STA PLA N 1+ STA ]?                      
13         N LDA     N 4 + CMP  0= ?]  \ VOCABTHREAD=0             
14         N 1+ LDA  N 5 + CMP  0= ?]  \ D.H. LEERES VOCABULARY    
15     ' 2+ @ JMP       END-CODE       \  IN NFA? IST ERLAUBT      
Screen 74 not modified     
 0 \ >NAME NAME> >BODY .NAME     03FEB85BP)                        
 1                                                                 
 2 : >NAME   ( CFA -- NFA / FALSE)  VOC-LINK                       
 3     BEGIN @ DUP WHILE 2DUP 4 - SWAP                             
 4         NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ;          
 5                                                                 
 6 | : (NAME>  ( NFA -- CFA) COUNT 01F  AND + ;                    
 7                                                                 
 8 : NAME> ( NFA -- CFA)  DUP (NAME> SWAP C@ 020 AND IF @ THEN ;   
 9                                                                 
10 : >BODY   ( CFA -- PFA)   2+ ;                                  
11                                                                 
12 : .NAME   ( NFA --)                                             
13     ?DUP IF DUP HEAP?  IF ." |" THEN COUNT 01F AND TYPE         
14          ELSE  ." ???" THEN  SPACE  ;                           
15                                                                 
Screen 75 not modified     
 0 \ : ; CONSTANT VARIABLE    09JAN85KS/BP)                        
 1                                                                 
 2 : :  CREATE  HIDE  CURRENT @ CONTEXT ! ] 0                      
 3        ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE           
 4        RP 2DEC IP    LDA  RP X) STA IP 1+ LDA  RP )Y STA        
 5        W LDA  CLC  2 # ADC  IP STA  TXA   W 1+ ADC  IP 1+ STA   
 6        NEXT JMP   END-CODE                                      
 7                                                                 
 8 : ;        0 ?PAIRS  COMPILE EXIT                               
 9  [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT                        
10                                                                 
11 : CONSTANT  ( 16B --)  CREATE ,                                 
12      ;CODE  SP 2DEC  2 # LDY W )Y LDA  SP X) STA  INY           
13      W )Y LDA   1 # LDY   SP )Y STA NEXT JMP   END-CODE         
14                                                                 
15 : VARIABLE   CREATE  2 ALLOT ;                                  
Screen 76 not modified     
 0 \ UALLOT USER ALIAS        10JAN85KS/BP)                        
 1                                                                 
 2 : UALLOT ( QUAN -- OFFSET)                                      
 3     DUP UDP @ +  0FF U> ABORT" USERAREA FULL"                   
 4     UDP  @ SWAP UDP +! ;                                        
 5                                                                 
 6 : USER  CREATE   2 UALLOT C,                                    
 7    ;CODE  SP 2DEC  2 # LDY W )Y LDA  CLC UP    ADC  SP X) STA   
 8    TXA  INY UP 1+ ADC  1 # LDY  SP )Y STA   NEXT JMP   END-CODE 
 9                                                                 
10 : ALIAS  ( CFA --)                                              
11    CREATE LAST @ DUP C@ 020 AND                                 
12    IF   -2 ALLOT  ELSE  020 FLAG! THEN  (NAME> ! ;              
13                                                                 
14                                                                 
15                                                                 
Screen 77 not modified     
 0 \ VOC-LINK VP CURRENT CONTEXT ALSO   BP)                        
 1 CREATE   VP       10 ALLOT                                      
 2                                                                 
 3 VARIABLE CURRENT                                                
 4                                                                 
 5 : CONTEXT ( -- ADR  )  VP DUP @ + 2+ ;                          
 6                                                                 
 7 | : THRU.VOCSTACK  ( -- FROM TO ) VP 2+ CONTEXT ;               
 8 \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP :                        
 9 \  COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER                          
10                                                                 
11 : ALSO     VP @                                                 
12  0A > ERROR" VOCABULARY STACK FULL"                             
13  CONTEXT @   2 VP +!  CONTEXT ! ;                               
14                                                                 
15 : TOSS   -2 VP +! ;                                             
Screen 78 not modified     
 0 \  VOCABULARY FORTH ONLY FORTH-83 KS/BP)                        
 1                                                                 
 2 : VOCABULARY CREATE  0 , 0 ,                                    
 3     HERE VOC-LINK @ ,  VOC-LINK ! DOES>  CONTEXT ! ;            
 4                                                                 
 5 \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK                  
 6                                                                 
 7 VOCABULARY FORTH                                                
 8                                                                 
 9 VOCABULARY ONLY                                                 
10 ] DOES>  [ ONLYPATCH ]  0 VP ! CONTEXT !  ALSO  ;  ' ONLY !     
11                                                                 
12 : ONLYFORTH  ONLY FORTH ALSO DEFINITIONS ;                      
13                                                                 
14                                                                 
15                                                                 
Screen 79 not modified     
 0 \ DEFINITIONS ORDER WORDS  13JAN84BP/KS)                        
 1                                                                 
 2 : DEFINITIONS   CONTEXT @ CURRENT ! ;                           
 3                                                                 
 4 | : .VOC  ( ADR -- ) @ 2- >NAME .NAME ;                         
 5                                                                 
 6 : ORDER                                                         
 7  THRU.VOCSTACK  DO  I .VOC  -2  +LOOP  2 SPACES  CURRENT .VOC ; 
 8                                                                 
 9 : WORDS      CONTEXT @                                          
10    BEGIN  @ DUP STOP? 0= AND                                    
11    WHILE  ?CR DUP 2+ .NAME SPACE REPEAT DROP ;                  
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 80 not modified     
 0 \ (FIND                       08APR85BP)                        
 1                                                                 
 2 CODE (FIND  ( STRING THREAD                                     
 3        -- STRING FALSE / NAMEFIELD TRUE)                        
 4  3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?]                        
 5  N 2+ X) LDA 01F # AND N 4 + STA                                
 6 LABEL FINDLOOP   0 # LDY                                        
 7  N )Y LDA   TAX   INY                                           
 8  N )Y LDA  N 1+ STA  N STX  N ORA                               
 9   0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]?                         
10  INY N )Y LDA  01F # AND  N 4 + CMP                             
11   FINDLOOP BNE       \ COUNTBYTE MATCH                          
12  CLC 2 # LDA N    ADC N 5 + STA                                 
13      0 # LDA N 1+ ADC N 6 + STA                                 
14  N 4  + LDY                                                     
15   [[ N 2+ )Y LDA N 5 + )Y CMP                                   
Screen 81 not modified     
 0 \                                                               
 1      FINDLOOP BNE   DEY  0= ?]                                  
 2  3 # LDY N 6 + LDA  SP )Y STA   DEY                             
 3          N 5 + LDA  SP )Y STA                                   
 4  DEY  0 # LDX    PUTTRUE JMP   END-CODE                         
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 82 not modified     
 0 \ FOUND                       29JAN85BP)                        
 1                                                                 
 2 | CODE FOUND  ( NFA -- CFA N )                                  
 3  SP X) LDA N STA  SP )Y LDA N 1+ STA                            
 4   N X) LDA N 2+ STA  01F # AND  SEC N ADC N STA                 
 5   CS ?[ N 1+ INC ]?                                             
 6  N 2+ LDA 020 # AND                                             
 7  0= ?[ N    LDA  SP X) STA N 1+ LDA                             
 8     ][ N X) LDA  SP X) STA N )Y LDA   ]?  SP )Y STA             
 9   SP 2DEC   N 2+ LDA   0< ?[  INY  ]?                           
10  .A ASL                                                         
11   0< NOT ?[ TYA 0FF # EOR TAY INY  ]?                           
12   TYA SP X) STA                                                 
13   0< ?[ 0FF # LDA  24 C, ]?                                     
14  TXA  1 # LDY  SP )Y STA                                        
15  NEXT JMP  END-CODE                                             
Screen 83 not modified     
 0 \\                                                              
 1                                                                 
 2 | : FOUND  ( NFA -- CFA N )                                     
 3       DUP   C@ >R   (NAME>                                      
 4             R@ 020 AND  IF @ THEN                               
 5         -1  R@ 080 AND  IF 1- THEN                              
 6             R> 040 AND  IF NEGATE THEN ;                        
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 84 not modified     
 0 \ FIND  ' [']                 13JAN85BP)            cas2013apr05
 1                                                                 
 2 : FIND ( STRING -- CFA N / STRING FALSE)                        
 3    CONTEXT DUP @ OVER 2- @ = IF 2- THEN                         
 4    BEGIN  UNDER @ (FIND IF NIP FOUND EXIT THEN                  
 5      OVER VP 2+ U>                                              
 6    WHILE  SWAP 2-  REPEAT NIP FALSE ;                           
 7                                                                 
 8 : '  ( -- CFA ) NAME FIND 0= ABORT" WHAT?" ;                    
 9                                                                 
10 : [COMPILE]   ' , ;             IMMEDIATE RESTRICT              
11                                                                 
12 : [']     ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT              
13                                                                 
14 : NULLSTRING? ( STRING -- STRING FALSE  / TRUE)                 
15     DUP C@ 0=  DUP  IF NIP THEN ;                               
Screen 85 not modified     
 0 \ >INTERPRET                  28FEB85BP)                        
 1                                                                 
 2 LABEL JUMP                                                      
 3  INY CLC W )Y LDA 2 # ADC IP    STA                             
 4  INY     W )Y LDA 0 # ADC IP 1+ STA                             
 5  1 # LDY  NEXT JMP   END-CODE                                   
 6 VARIABLE >INTERPRET                                             
 7                                                                 
 8 JUMP  ' >INTERPRET !                                            
 9                                                                 
10 \\ MAKE VARIABLE >INTERPRET TO SPECIAL                          
11    DEFER                                                        
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 86 not modified     
 0 \ INTERPRET INTERACTIVE    31DEC84KS/BP)             cas 26jan06
 1                                                                 
 2 DEFER  NOTFOUND                                                 
 3                                                                 
 4 : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?"   ;  \ STRING NOT 0 
 5                                                                 
 6 ' NO.EXTENSIONS  IS  NOTFOUND                                   
 7                                                                 
 8 : INTERPRET     >INTERPRET ;  -2 ALLOT                          
 9                                                                 
10 | : INTERACTIVE  ?STACK  NAME FIND  ?DUP                        
11      IF 1 AND IF EXECUTE >INTERPRET THEN                        
12       ABORT" COMPILE ONLY"  THEN  NULLSTRING? ?EXIT    NUMBER?  
13   0= IF  NOTFOUND  THEN  >INTERPRET ;  -2 ALLOT                 
14                                                                 
15 ' INTERACTIVE  >INTERPRET !                                     
Screen 87 not modified     
 0 \ COMPILING [ ]               20DEC84BP)                        
 1                                                                 
 2 | : COMPILING                                                   
 3  ?STACK  NAME FIND   ?DUP                                       
 4  IF   0> IF  EXECUTE >INTERPRET  THEN                           
 5   , >INTERPRET THEN                                             
 6  NULLSTRING? ?EXIT  NUMBER?   ?DUP                              
 7    IF 0> IF SWAP [COMPILE] LITERAL THEN                         
 8     [COMPILE] LITERAL                                           
 9    ELSE  NOTFOUND THEN    >INTERPRET ; -2 ALLOT                 
10                                                                 
11 : [    ['] INTERACTIVE  IS >INTERPRET STATE OFF ;  IMMEDIATE    
12                                                                 
13 : ]    ['] COMPILING    IS >INTERPRET STATE ON ;                
14                                                                 
15                                                                 
Screen 88 not modified     
 0 \ PERFOM  DEFER IS            03FEB85BP)                        
 1                                                                 
 2 | : CRASH   TRUE ABORT" CRASH" ;                                
 3                                                                 
 4 : DEFER   CREATE  ['] CRASH ,                                   
 5     ;CODE  2 # LDY  W )Y LDA  PHA INY W )Y LDA                  
 6     W 1+ STA  PLA W STA  1 # LDY W 1- JMP  END-CODE             
 7                                                                 
 8 : (IS            R>  DUP  2+ >R @ ! ;                           
 9                                                                 
10 | : DEF?  ( CFA -- ) @ ['] NOTFOUND   @ OVER =                  
11      SWAP ['] >INTERPRET @ = OR NOT  ABORT" NOT DEFERRED" ;     
12                                                                 
13 : IS      ( ADR -- )  ' DUP  DEF?  >BODY                        
14      STATE  @  IF  COMPILE (IS , EXIT  THEN !  ; IMMEDIATE      
15                                                                 
Screen 89 not modified     
 0 \ ?STACK                      08SEP84KS)                        
 1                                                                 
 2 | : STACKFULL   ( -- )                                          
 3  DEPTH 20 > ABORT" TIGHT STACK"                                 
 4  REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN               
 5        (FORGET THEN  TRUE ABORT" DICTIONARY FULL" ;             
 6                                                                 
 7 CODE ?STACK USER' DP # LDY                                      
 8       SEC SP    LDA  UP )Y  SBC N STA  INY SP 1+ LDA  UP )Y SBC 
 9   0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]?                    
10      USER' S0 # LDY UP )Y LDA SP    CMP INY                     
11      UP )Y LDA SP 1+ SBC   1 # LDY  CS ?[  NEXT JMP ]?          
12      ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT                    
13                                                                 
14 \\  : ?STACK  SP@  HERE - 100 U< IF STACKFULL THEN              
15          SP@  S0 @ U> ABORT" STACK EMPTY" ;                     
Screen 90 not modified     
 0 \ .STATUS PUSH LOAD           08SEP84KS)                        
 1                                                                 
 2 DEFER .STATUS    ' NOOP IS .STATUS                              
 3                                                                 
 4 | CREATE PULL  0  ] R> R> ! ;                                   
 5                                                                 
 6 : PUSH ( ADDR -- )                                              
 7     R> SWAP DUP >R @ >R  PULL >R >R  ;  RESTRICT                
 8                                                                 
 9                                                                 
10 : LOAD   ( BLK --)                                              
11     ?DUP 0= ?EXIT BLK PUSH  BLK !                               
12     >IN PUSH  >IN OFF  .STATUS INTERPRET ;                      
13                                                                 
14                                                                 
15                                                                 
Screen 91 not modified     
 0 \ +LOAD THRU +THRU --> RDEPTH DEPTH  KS)                        
 1                                                                 
 2 : +LOAD  ( OFFSET --)  BLK @  + LOAD ;                          
 3                                                                 
 4 : THRU  ( FROM TO --)      1+  SWAP  DO  I LOAD  LOOP ;         
 5                                                                 
 6 : +THRU  ( OFF0 OFF1 --)   1+  SWAP  DO  I +LOAD LOOP ;         
 7                                                                 
 8 : -->  1 BLK +! >IN OFF .STATUS  ;  IMMEDIATE                   
 9                                                                 
10 : RDEPTH  ( -- +N)  R0 @  RP@ 2+ - 2/ ;                         
11                                                                 
12 : DEPTH   ( -- +N)  SP@ S0 @ SWAP - 2/ ;                        
13                                                                 
14                                                                 
15                                                                 
Screen 92 not modified     
 0 \ QUIT (QUIT ABORT            07JUN85BP)                        
 1                                                                 
 2 | : PROMPT  STATE @  IF ."  COMPILING"  EXIT  THEN  ."  OK" ;   
 3                                                                 
 4 : (QUIT                                                         
 5     BEGIN .STATUS CR QUERY INTERPRET PROMPT  REPEAT ;  -2 ALLOT 
 6                                                                 
 7 DEFER 'QUIT    ' (QUIT  IS 'QUIT                                
 8                                                                 
 9 : QUIT     R0 @ RP! [COMPILE] [ 'QUIT ;  -2 ALLOT               
10                                                                 
11 : STANDARDI/O   [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ;             
12                                                                 
13 DEFER 'ABORT   ' NOOP IS 'ABORT                                 
14                                                                 
15 : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT 
Screen 93 not modified     
 0 \ (ERROR ABORT" ERROR"        20MAR85BP)                        
 1                                                                 
 2 VARIABLE SCR    1 SCR !                                         
 3                                                                 
 4 VARIABLE R#     0 R#  !                                         
 5                                                                 
 6 : (ERROR  ( STRING -- )                                         
 7     STANDARDI/O SPACE HERE .NAME COUNT TYPE  SPACE ?CR          
 8     BLK @  ?DUP IF  SCR !  >IN @  R# ! THEN QUIT ; -2 ALLOT     
 9                                                                 
10 ' (ERROR  ERRORHANDLER  !                                       
11                                                                 
12 : (ABORT"    "LIT SWAP IF                                       
13      >R CLEARSTACK R> ERRORHANDLER PERFORM                      
14      EXIT THEN  DROP ;  RESTRICT                                
15                                                                 
Screen 94 not modified     
 0 \                                                               
 1                                                                 
 2 | : (ERR"  "LIT SWAP                                            
 3       IF ERRORHANDLER  PERFORM EXIT THEN DROP ;    RESTRICT     
 4                                                                 
 5 : ABORT"  COMPILE (ABORT" ," ;   IMMEDIATE  RESTRICT            
 6                                                                 
 7 : ERROR"  COMPILE (ERR"   ," ;    IMMEDIATE  RESTRICT           
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 95 not modified     
 0 \ -TRAILING                   08APR85BP)                        
 1                                                                 
 2 020 CONSTANT BL                                                 
 3                                                                 
 4 CODE -TRAILING  ( ADDR N1 -- ADR  N2 )                          
 5  TYA   SETUP JSR                                                
 6  SP X) LDA  N 2+ STA   CLC                                      
 7  SP )Y LDA  N 1+ ADC  N 3 + STA                                 
 8  N LDY  CLC   CS ?[                                             
 9 LABEL (-TRAIL                                                   
10  DEY  N 2+ )Y LDA  BL # CMP                                     
11   0<> ?[ INY  0= ?[ N 1+ INC ]?                                 
12          TYA PHA  N 1+ LDA PUSH JMP ]?                          
13  ]?   TYA   (-TRAIL BNE                                         
14  N 3 + DEC N 1 + DEC  (-TRAIL BPL                               
15  TYA PUSH0A JMP   END-CODE                                      
Screen 96 not modified     
 0 \ SPACE SPACES             29JAN85KS/BP)                        
 1                                                                 
 2 : SPACE            BL EMIT ;                                    
 3                                                                 
 4 : SPACES  ( U --)  0  ?DO SPACE LOOP ;                          
 5                                                                 
 6 \\                                                              
 7 : -TRAILING  ( ADDR N1 -- ADDR N2)                              
 8  2DUP  BOUNDS                                                   
 9     ?DO 2DUP + 1- C@ BL -                                       
10       IF LEAVE THEN  1- LOOP  ;                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 97 not modified     
 0 \ HOLD <# #> SIGN # #S        24DEC83KS)                        
 1 | : HLD  ( -- ADDR)    PAD 2- ;                                 
 2                                                                 
 3 : HOLD  ( CHAR -- )     -1 HLD +! HLD @ C! ;                    
 4                                                                 
 5 : <#                   HLD HLD ! ;                              
 6                                                                 
 7 : #>    ( 32B -- ADDR +N ) 2DROP HLD @  HLD OVER - ;            
 8                                                                 
 9 : SIGN  ( N -- )  0< IF ASCII  - HOLD THEN ;                    
10                                                                 
11 : #     ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER <               
12    IF [ ASCII A ASCII 9 - 1- ] LITERAL +                        
13    THEN  ASCII 0  +  HOLD ;                                     
14                                                                 
15 : #S    ( +D -- 0 0 ) BEGIN # 2DUP  D0= UNTIL ;                 
Screen 98 not modified     
 0 \ PRINT NUMBERS               24DEC83KS)                        
 1                                                                 
 2 : D.R  -ROT UNDER DABS <# #S ROT SIGN #>                        
 3         ROT OVER MAX OVER - SPACES TYPE  ;                      
 4                                                                 
 5 : .R    SWAP EXTEND ROT D.R ;                                   
 6                                                                 
 7 : U.R   0 SWAP D.R ;                                            
 8                                                                 
 9 : D.    0 D.R SPACE ;                                           
10                                                                 
11 : .     EXTEND D. ;                                             
12                                                                 
13 : U.    0 D. ;                                                  
14                                                                 
15                                                                 
Screen 99 not modified     
 0 \ .S LIST C/L L/S             24DEC83KS)                        
 1                                                                 
 2 : .S   SP@  S0 @  OVER - 020 UMIN BOUNDS ?DO I @ U.  2 +LOOP ;  
 3                                                                 
 4 40 CONSTANT C/L    \ SCREEN LINE LENGTH                         
 5                                                                 
 6 10 CONSTANT L/S    \ LINES PER SCREEN                           
 7                                                                 
 8 : LIST   ( BLK --)                                              
 9    SCR ! ." SCR " SCR @ DUP U.                                  
10        ." DR "  DRV? .                                          
11    L/S 0 DO CR I 2 .R SPACE SCR @  BLOCK                        
12             I C/L * + C/L -TRAILING TYPE  LOOP CR ;             
13                                                                 
14                                                                 
15                                                                 
Screen 100 not modified     
 0 \ MULTITASKER PRIMITIVES      BP03NOV85)                        
 1 CODE PAUSE   NEXT HERE 2- !  END-CODE                           
 2                                                                 
 3 : LOCK  ( ADDR --)                                              
 4  DUP @  UP@ =  IF  DROP EXIT  THEN                              
 5  BEGIN  DUP @  WHILE  PAUSE  REPEAT UP@ SWAP ! ;                
 6                                                                 
 7 : UNLOCK  ( ADDR --)   DUP LOCK OFF ;                           
 8                                                                 
 9 LABEL WAKE    WAKE >WAKE !                                      
10  PLA  SEC  5 # SBC  UP    STA   PLA       0 # SBC  UP 1+ STA    
11  04C # LDA  UP X) STA           6 # LDY  UP )Y LDA SP    STA    
12      INY  UP )Y LDA SP 1+ STA 1 # LDY                           
13  SP X) LDA  RP STA         SP )Y LDA  RP 1+ STA   SP 2INC       
14  IP  # LDX  XPULL JMP END-CODE                                  
15                                                                 
Screen 101 not modified     
 0 \ BUFFER MECHANISM            15DEC83KS)             cas 26jan06
 1                                                                 
 2 USER FILE           0 FILE !    \ ADR OF FILE CONTROL BLOCK     
 3                                                                 
 4 VARIABLE PREV       0 PREV !    \ LISTHEAD                      
 5                                                                 
 6 | VARIABLE BUFFERS  0 BUFFERS ! \ SEMAPHOR                      
 7                                                                 
 8 0408 CONSTANT B/BUF             \ size of buffer                
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 102 not modified     
 0 \\ structure of buffer (same for all volksFORTH )    cas 26jan06
 1  0 : LINK                                                       
 2  2 : FILE                                                       
 3  6 : BLOCKNR                                                    
 4  8 : STATUSFLAGS                                                
 5 0A : DATA .. 1 KB ..                                            
 6                                                                 
 7 STATUSFLAG BITS: 15   1 -> UPDATED                              
 8                                                                 
 9 FILE = -1 EMPTY BUFFER                                          
10      = 0 NO FCB , DIRECT ACCESS                                 
11      = ELSE  ADR OF FCB                                         
12      ( SYSTEM   DEPENDENT )                                     
13                                                                 
14                                                                 
15                                                                 
Screen 103 not modified     
 0 \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP)                        
 1                                                                 
 2 LABEL THISBUFFER?        2 # LDY                                
 3    [[  N 4 + )Y LDA N 2- ,Y CMP                                 
 4  0= ?[[  INY  6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER )      
 5                                                                 
 6 | CODE (CORE? ( BLK FILE -- ADDR / BLK  FILE )                  
 7  \ N-AREA : 0 BLK 2 FILE 4 BUFFER                               
 8  \          6 PREDECESSOR                                       
 9  3 # LDY                                                        
10    [[ SP )Y LDA  N ,Y STA  DEY  0< ?]                           
11  USER' OFFSET # LDY  CLC  UP )Y LDA  N 2+  ADC  N 2+  STA       
12  INY  UP )Y LDA  N 3 + ADC  N 3 + STA  PREV    LDA  N 4 + STA   
13  PREV 1+ LDA  N 5 + STA  THISBUFFER? JSR    0= ?[               
14                                                                 
15                                                                 
Screen 104 not modified     
 0 \   "                         11JUN85BP)                        
 1                                                                 
 2 LABEL BLOCKFOUND     SP 2INC  1 # LDY                           
 3  8 #   LDA  CLC N 4 + ADC SP X) STA                             
 4  N 5 + LDA        0 # ADC SP )Y STA                             
 5  ' EXIT @ JMP  ]?                                               
 6  [[ N 4 + LDA  N 6 + STA N 5 + LDA  N 7 + STA                   
 7     N 6 + X) LDA  N 4 + STA  1 # LDY                            
 8     N 6 + )Y LDA  N 5 + STA  N 4 + ORA                          
 9      0= ?[ ( LIST EMPTY )  NEXT JMP ]?                          
10    THISBUFFER? JSR 0= ?] \ FOUND, RELINK                        
11  N 4 + X) LDA  N 6 + X) STA  1 # LDY N 4 + )Y LDA  N 6 + )Y STA 
12  PREV    LDA  N 4 + X) STA   PREV 1+ LDA  N 4 + )Y STA          
13  N 4 + LDA  PREV    STA      N 5 + LDA  PREV 1+ STA             
14  BLOCKFOUND JMP    END-CODE                                     
15                                                                 
Screen 105 not modified     
 0 \\ (CORE?                       23SEP85BP                       
 1 | : this? ( blk file bufadr -- flag )                           
 2    DUP 4+ @  SWAP 2+ @  D= ;                                    
 3                                                                 
 4 | : (CORE?  ( BLK FILE -- DATAADDR / BLK FILE )                 
 5   BEGIN  OVER OFFSET @ + OVER  PREV @                           
 6     THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN                   
 7     2DUP >R OFFSET @ + >R PREV @                                
 8     BEGIN  DUP @ ?DUP                                           
 9        0= IF RDROP RDROP DROP EXIT THEN                         
10       DUP R> R> 2DUP >R >R  ROT THIS? 0=                        
11     WHILE  NIP  REPEAT DUP @ ROT !  PREV @ OVER !  PREV !       
12     RDROP RDROP REPEAT ;    -2 ALLOT                            
13                                                                 
14                                                                 
15                                                                 
Screen 106 not modified     
 0 \ (DISKERR                    11JUN85BP)                        
 1                                                                 
 2 : (DISKERR   ." ERROR !  R TO RETRY "                           
 3  KEY DUP ASCII R =  SWAP ASCII R =                              
 4  OR NOT  ABORT" ABORTED"  ;                                     
 5                                                                 
 6                                                                 
 7 DEFER DISKERR  ' (DISKERR  IS DISKERR                           
 8                                                                 
 9 DEFER R/W                                                       
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 107 not modified     
 0 \ BACKUP EMPTYBUF READBLK     11JUN85BP)                        
 1 | : BACKUP   ( BUFADDR --)                                      
 2  DUP 6+ @  0<                                                   
 3  IF  2+  DUP @ 1+               \ BUFFER EMPTY IF FILE = -1     
 4   IF INPUT PUSH OUTPUT PUSH STANDARDI/O                         
 5    BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W                        
 6    WHILE ." WRITE " DISKERR                                     
 7    REPEAT   THEN                                                
 8   080 OVER 4+ 1+ CTOGGLE  THEN DROP ;                           
 9                                                                 
10 | : EMPTYBUF  ( BUFADDR --)   2+ DUP ON 4+ OFF ;                
11                                                                 
12 | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR)                   
13      DUP EMPTYBUF  INPUT PUSH  OUTPUT PUSH  STANDARDI/O >R      
14      BEGIN OVER OFFSET @ + OVER R@ 8 +  -ROT   1  R/W           
15      WHILE ." READ " DISKERR REPEAT  R>  ;                      
Screen 108 not modified     
 0 \ TAKE MARK UPDATES? FULL? CORE?     BP)                        
 1                                                                 
 2 | : TAKE   ( -- BUFADDR)    PREV                                
 3      BEGIN  DUP @  WHILE  @  DUP 2+ @ -1 = UNTIL                
 4      BUFFERS LOCK   DUP BACKUP ;                                
 5                                                                 
 6 | : MARK ( BLK FILE BUFADDR -- BLK FILE )                       
 7      2+ >R 2DUP R@ !  OFFSET @ +  R@ 2+ !                       
 8      R> 4+ OFF  BUFFERS UNLOCK ;                                
 9                                                                 
10 | : UPDATES?  ( -- BUFADDR / FLAG)                              
11      PREV  BEGIN  @ DUP  WHILE  DUP 6+ @ 0<  UNTIL ;            
12                                                                 
13 | : FULL?   ( -- FLAG)  PREV BEGIN @ DUP @ 0= UNTIL  6+ @ 0< ;  
14                                                                 
15 : CORE?  ( BLK FILE -- ADDR /FALSE)  (CORE? 2DROP FALSE ;       
Screen 109 not modified     
 0 \ BLOCK & BUFFER MANIPULATION 11JUN85BP)                        
 1                                                                 
 2 : (BUFFER ( BLK FILE -- ADDR)                                   
 3     BEGIN  (CORE? TAKE MARK  REPEAT ;   -2 ALLOT                
 4                                                                 
 5 : (BLOCK  ( BLK FILE -- ADDR)                                   
 6     BEGIN  (CORE? TAKE READBLK MARK REPEAT ;   -2 ALLOT         
 7                                                                 
 8 | CODE FILE@  ( -- N ) USER' FILE # LDY                         
 9     UP )Y LDA  PHA  INY  UP )Y LDA PUSH JMP  END-CODE           
10                                                                 
11 : BUFFER  ( BLK -- ADDR ) FILE@  (BUFFER ;                      
12                                                                 
13 : BLOCK   ( BLK -- ADDR ) FILE@  (BLOCK ;                       
14                                                                 
15                                                                 
Screen 110 not modified     
 0 \ BLOCK & BUFFER MANIPULATION 09SEP84KS)                        
 1                                                                 
 2 : UPDATE   080 PREV @  6+ 1+ C! ;                               
 3                                                                 
 4 : SAVE-BUFFERS                                                  
 5    BUFFERS LOCK BEGIN   UPDATES? ?DUP WHILE BACKUP REPEAT       
 6    BUFFERS UNLOCK  ;                                            
 7                                                                 
 8 : EMPTY-BUFFERS                                                 
 9    BUFFERS LOCK  PREV                                           
10    BEGIN @ ?DUP                                                 
11    WHILE DUP EMPTYBUF                                           
12    REPEAT  BUFFERS UNLOCK ;                                     
13                                                                 
14 : FLUSH    SAVE-BUFFERS EMPTY-BUFFERS ;                         
15                                                                 
Screen 111 not modified     
 0 \ MOVING BLOCKS               15DEC83KS)             cas 26jan06
 1 | : (COPY   ( FROM TO --) DUP FILE@                             
 2      CORE? IF PREV @ EMPTYBUF THEN                              
 3      FULL? IF  SAVE-BUFFERS   THEN                              
 4      OFFSET @ + SWAP BLOCK 2- 2- !  UPDATE ;                    
 5                                                                 
 6 | : BLKMOVE  ( FROM TO QUAN --) SAVE-BUFFERS >R                 
 7      OVER R@ + OVER U> >R  2DUP U< R> AND                       
 8      IF  R@ R@ D+  R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP            
 9      ELSE          R> 0 ?DO 2DUP (COPY 1 1 D+   LOOP            
10      THEN  SAVE-BUFFERS 2DROP ;                                 
11                                                                 
12 : COPY    ( FROM TO --)   1 BLKMOVE ;                           
13                                                                 
14 : CONVEY  ( [BLK1 BLK2] [TO.BLK --)                             
15      SWAP  1+  2 PICK -   DUP 0> NOT ABORT" NO!!"  BLKMOVE ;    
Screen 112 not modified     
 0 \ ALLOCATING BUFFERS          23SEP83KS)            cas2013apr04
 1                                                                 
 2 7F00 CONSTANT LIMIT     VARIABLE FIRST                          
 3                                                                 
 4 : ALLOTBUFFER   ( -- )                                          
 5    FIRST @ R0 @  - B/BUF 2+ U< ?EXIT                            
 6    B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF                   
 7    PREV  @ OVER !  PREV !   ;                                   
 8                                                                 
 9 : FREEBUFFER    ( -- )                                          
10    FIRST @   LIMIT B/BUF - U<                                   
11    IF SAVE-BUFFERS BEGIN  DUP @ FIRST @  - WHILE  @  REPEAT     
12    FIRST @  @ SWAP ! B/BUF FIRST +! THEN ;                      
13                                                                 
14 : ALL-BUFFERS BEGIN  FIRST @ ALLOTBUFFER FIRST @  = UNTIL ;     
15                                                                 
Screen 113 not modified     
 0 \ ENDPOINTS OF FORGET      04JAN85BP/KS)                        
 1 | : \? ( NFA -- FLAG )   C@  020  AND ;                         
 2                                                                 
 3 | : FORGET?  ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ?  
 4      NAME> UNDER 1+ U< SWAP  HEAP?  OR ;                        
 5                                                                 
 6 |  : ENDPOINTS  ( ADDR -- ADDR SYMB)                            
 7  HEAP   VOC-LINK @ >R                                           
 8   BEGIN R> @ ?DUP    \ THROUGH ALL VOCABS                       
 9   WHILE DUP >R 4 - >R \ LINK ON RETURNST.                       
10    BEGIN R> @ >R OVER 1- DUP R@  U<    \ UNTIL LINK  OR         
11               SWAP  R@ 2+ NAME> U< AND \ CODE UNDER ADR         
12    WHILE  R@ HEAP?  [ 2DUP ] UNTIL  \ SEARCH FOR A NAME IN HEAP 
13     R@ 2+ \?  IF  OVER R@ 2+ FORGET?                            
14                IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB  
15               THEN REPEAT RDROP   REPEAT  ;                     
Screen 114 not modified     
 0 \ REMOVE                       23JUL85WE                        
 1                                                                 
 2 | CODE REMOVE ( DIC SYMB THR - DIC SYMB)                        
 3    5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY       
 4    CLC UP )Y LDA 6 # ADC N 6 + STA                              
 5    INY UP )Y LDA 0 # ADC N 7 + STA  1 # LDY                     
 6    [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA  0<>      
 7    ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS               
 8      ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC                 
 9      ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC                 
10      ]? CC                                                      
11      ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA             
12      ][ N 8 + LDA    N    STA N 9 + LDA N 1+ STA ]?             
13    ]]? (DROP JMP   END-CODE                                     
14                                                                 
15                                                                 
Screen 115 not modified     
 0 \ REMOVE-     FORGET-WORDS    29APR85BP)                        
 1                                                                 
 2 | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB)                        
 3      VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT  ; 
 4                                                                 
 5 | : REMOVE-TASKS  ( DIC --)                                     
 6      UP@  BEGIN  1+ DUP @ UP@ - WHILE  2DUP @ SWAP HERE UWITHIN 
 7      IF DUP @ 1+ @ OVER ! 1-  ELSE  @ THEN REPEAT  2DROP ;      
 8                                                                 
 9 | : REMOVE-VOCS  ( DIC SYMB -- DIC SYMB)                        
10      VOC-LINK REMOVE THRU.VOCSTACK                              
11       DO  2DUP I @  -ROT  UWITHIN                               
12         IF   [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP           
13       2DUP   CURRENT @  -ROT   UWITHIN                          
14      IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ;                 
15                                                                 
Screen 116 not modified     
 0 \  FORGET-WORDS                                      cas 26jan06
 1                                                                 
 2 | : FORGET-WORDS    ( DIC SYMB --)                              
 3      OVER REMOVE-TASKS REMOVE-VOCS                              
 4           REMOVE-WORDS                                          
 5      HEAP SWAP - HALLOT DP !  0 LAST ! ;                        
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 117 not modified     
 0 \ DELETING WORDS FROM DICT.   13JAN83KS)                        
 1                                                                 
 2 : CLEAR HERE   DUP UP@ FORGET-WORDS   DP ! ;                    
 3                                                                 
 4 : (FORGET ( ADR --) DUP  HEAP? ABORT" IS SYMBOL"                
 5     ENDPOINTS FORGET-WORDS ;                                    
 6                                                                 
 7 : FORGET  ' DUP [ DP ] LITERAL @ U<  ABORT" PROTECTED"          
 8    >NAME DUP HEAP? IF  NAME>  ELSE  2- 2-  THEN (FORGET ;       
 9                                                                 
10 : EMPTY  [ DP ] LITERAL @                                       
11    UP@ FORGET-WORDS [ UDP ] LITERAL @  UDP ! ;                  
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 118 not modified     
 0 \ SAVE BYE STOP? ?CR       20OCT84KS/BP)                        
 1                                                                 
 2 : SAVE                                                          
 3    HERE UP@ FORGET-WORDS VOC-LINK @                             
 4    BEGIN  DUP 2- 2-  @  OVER 2- !  @ ?DUP 0=  UNTIL             
 5    UP@ ORIGIN 0100 CMOVE   ;                                    
 6                                                                 
 7 : BYE       FLUSH EMPTY (BYE ;                                  
 8                                                                 
 9 | : END?    KEY   #CR   (C 3 ) = IF TRUE RDROP THEN ;           
10                                                                 
11 : STOP?   ( -- FLAG) KEY? IF END? END? THEN FALSE ;             
12                                                                 
13 : ?CR   COL  C/L 0A -  U> IF CR THEN ;                          
14                                                                 
15                                                                 
Screen 119 not modified     
 0 \ IN/OUTPUT STRUCTURE         02MAR85BP)                        
 1 | : OUT:  CREATE DUP C,  2+ DOES> C@ OUTPUT @ +  PERFORM ;      
 2                                                                 
 3   : OUTPUT:  CREATE  ]      DOES>  OUTPUT ! ;                   
 4 0  OUT: EMIT   OUT: CR     OUT: TYPE                            
 5    OUT: DEL    OUT: PAGE   OUT: AT    OUT: AT?  DROP            
 6                                                                 
 7 : ROW   ( -- ROW)  AT? DROP ;                                   
 8 : COL   ( -- COL)  AT? NIP ;                                    
 9                                                                 
10 | : IN:    CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ;        
11                                                                 
12   : INPUT:  CREATE ]        DOES> INPUT ! ;                     
13                                                                 
14 0  IN: KEY   IN: KEY?   IN: DECODE  IN: EXPECT   DROP           
15                                                                 
Screen 120 not modified     
 0 \ ALIAS  ONLY DEFINITIONEN    29JAN85BP)                        
 1                                                                 
 2 ONLY DEFINITIONS FORTH                                          
 3                                                                 
 4 : SEAL  0 ['] ONLY  >BODY  ! ;  \ KILL ALL WORDS IN ONLY)       
 5                                                                 
 6       ' ONLY  ALIAS ONLY                                        
 7       ' FORTH ALIAS FORTH                                       
 8       ' WORDS ALIAS WORDS                                       
 9       ' ALSO  ALIAS ALSO                                        
10 ' DEFINITIONS ALIAS DEFINITIONS                                 
11 HOST TARGET                                                     
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 121 not modified     
 0 \ 'COLD                       07JUN85BP)            cas2013apr05
 1 | : INIT-VOCABULARYS   VOC-LINK @                               
 2      BEGIN  DUP  2- @  OVER 4 - ! @ ?DUP 0= UNTIL ;             
 3                                                                 
 4 | : INIT-BUFFERS 0 PREV ! LIMIT FIRST !  ALL-BUFFERS ;          
 5                                                                 
 6 DEFER  'COLD    ' NOOP IS 'COLD                                 
 7                                                                 
 8 | : (COLD INIT-VOCABULARYS  INIT-BUFFERS  PAGE 'COLD ONLYFORTH  
 9      ." volksFORTH-83  3.8.7 05apr13 CS" CR   RESTART ; -2 ALLOT
10                                                                 
11 DEFER 'RESTART  ' NOOP IS 'RESTART                              
12 | : (RESTART ['] (QUIT IS 'QUIT                                 
13     DRVINIT 'RESTART  [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! 
14     [']  NOOP IS 'ABORT ABORT  ;  -2 ALLOT                      
15                                                                 
Screen 122 not modified     
 0 \ COLD BOOTSYSTEM RESTART     09JUL85WE)                        
 1 CODE COLD        HERE >COLD !                                   
 2  ' (COLD >BODY 100 U/MOD # LDA PHA  # LDA PHA                   
 3                                                                 
 4 LABEL BOOTSYSTEM  CLI 0 # LDY                                   
 5  CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA            
 6  [[ ORIGIN ,Y LDA N )Y STA INY 0= ?]                            
 7 LABEL WARMBOOT  BOOTNEXTLEN 1- # LDY                            
 8  [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?]                       
 9  CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA          
10  USER' S0 # LDY  UP )Y LDA SP STA INY  UP )Y LDA SP 1+ STA      
11  USER' R0 # LDY  UP )Y LDA RP STA INY  UP )Y LDA RP 1+ STA      
12  0 # LDX 1 # LDY TXA RP X) STA RP )Y STA                        
13  PLA IP STA PLA IP 1+ STA                                       
14 LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE                  
15                                                                 
Screen 123 not modified     
 0 \ ( RESTART  PARAM.-PASSING TO FORTH   BP)                      
 1                                                                 
 2 CODE RESTART       HERE >RESTART !                              
 3  ' (RESTART >BODY 100 U/MOD                                     
 4  # LDA  PHA  # LDA PHA WARMBOOT JMP   END-CODE                  
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 124 not modified     
 0 \ CODE FOR PARAMETER-PASSING TO FORTH                cas 26jan06
 1                                                                 
 2 \ Include system dependent Input / Output code                  
 3 \ (Keyboard and Screen)                                         
 4 include systemio.fb                                             
 5                                                                 
 6                                                                 
 7 HOST  ' TRANSIENT 8 + @                                         
 8 TRANSIENT  FORTH  CONTEXT @ 6 + !                               
 9 TARGET                                                          
10                                                                 
11 FORTH ALSO DEFINITIONS                                          
12                                                                 
13 : FORTH-83 ;  \ LAST WORD IN DICTIONARY                         
14                                                                 
15                                                                 
Screen 125 not modified     
 0 \ SYSTEM DEPENDENT CONSTANTS      BP/KS)                        
 1                                                                 
 2 VOCABULARY ASSEMBLER                                            
 3 ASSEMBLER DEFINITIONS                                           
 4 TRANSIENT  ASSEMBLER                                            
 5 PUSHA  CONSTANT PUSHA           \ PUT A SIGN-EXTENDED ON STACK  
 6 PUSH0A CONSTANT PUSH0A          \ PUT A ON STACK                
 7 PUSH   CONSTANT PUSH            \ MSB IN A AND LSB ON JSR-STACK 
 8 RP     CONSTANT RP                                              
 9 UP     CONSTANT UP                                              
10 SP     CONSTANT SP                                              
11 IP     CONSTANT IP                                              
12 N      CONSTANT N                                               
13 PUTA   CONSTANT PUTA                                            
14 W      CONSTANT W                                               
15 SETUP  CONSTANT SETUP                                           
Screen 126 not modified     
 0 \                                                               
 1 NEXT   CONSTANT NEXT                                            
 2 XYNEXT CONSTANT XYNEXT                                          
 3 (2DROP CONSTANT POPTWO                                          
 4 (DROP  CONSTANT POP                                             
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 127 not modified     
 0 \ SYSTEM PATCHUP              05JAN85BP)            cas2013apr05
 1                                                                 
 2 FORTH DEFINITIONS                                               
 3                                                                 
 4 \ change memory layout for stacks and buffers here              
 5 TOPADDR ' LIMIT >BODY !                                         
 6 TOPADDR $F00 - S0 !  TOPADDR $480 - R0 !                        
 7                                                                 
 8 S0 @ DUP S0 2- !      6 + S0 7 - !                              
 9 HERE DP !                                                       
10                                                                 
11 HOST  TUDP @          TARGET  UDP !                             
12 HOST  TVOC-LINK @     TARGET  VOC-LINK !                        
13 HOST  MOVE-THREADS                                              
14                                                                 
15                                    )                            
Screen 128 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 129 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 130 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
Screen 131 not modified     
 0                                                                 
 1                                                                 
 2                                                                 
 3                                                                 
 4                                                                 
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 
