From 1bd8d592c20b6f727c138f38cdd5b6bff28936af Mon Sep 17 00:00:00 2001
From: Philip Zembrod <pzembrod@google.com>
Date: Sat, 11 Jul 2020 20:44:11 +0200
Subject: [PATCH] Initial branch of blk $10-$7d, i.e. the main part of the vf
 sources, from the ascii version vforth4_2.fth of the disks/vforth4_2.d64
 block sources into a separate vf-blk-10-7d.fth in the src dir.

---
 6502/C64/src/vf-blk-10-7d.fth | 4760 +++++++++++++++++++++++++++++++++
 1 file changed, 4760 insertions(+)
 create mode 100644 6502/C64/src/vf-blk-10-7d.fth

diff --git a/6502/C64/src/vf-blk-10-7d.fth b/6502/C64/src/vf-blk-10-7d.fth
new file mode 100644
index 0000000..181fe08
--- /dev/null
+++ b/6502/C64/src/vf-blk-10-7d.fth
@@ -0,0 +1,4760 @@
+
+\ *** Block No. 0, Hexblock 0
+
+\\ Directory volksFORTH 2of4   26oct87re
+
+.                    0
+..                   0
+misc               $08
+C64/C16            $09
+System             $0F
+C64interface       $7d
+C16init            $94
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 1, Hexblock 1
+
+\\ Content volksFORTH 2of4     26oct87re
+
+Directory            0
+Content              1
+misc               $08
+C64 or  C16        $09
+System             $0F
+C64/C16interface   $7d
+                   $95-a9 free
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 2, Hexblock 2
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 3, Hexblock 3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 4, Hexblock 4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 5, Hexblock 5
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 6, Hexblock 6
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 7, Hexblock 7
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 8, Hexblock 8
+
+\ ram rom jsr NormJsr f.C16+ clv12.4.87)
+
+
+Assembler also definitions
+
+(c16+ \ C16+Macros for Bankswitching
+
+: ram $ff3f sta ;   : rom $ff3e sta ;
+
+' Jsr Alias NormJsr   Defer Jsr
+
+: C16+Jsr dup $c000 u>
+ IF rom NormJsr ram ELSE NormJsr THEN ;
+
+' C16+Jsr Is Jsr
+)
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 9, Hexblock 9
+
+\ Target-Machine              clv06dec88
+
+Onlyforth
+
+
+cr .( Host is: )
+    (64  .( C64) C)
+    (16  .( C16) C)
+
+       : )     ; immediate
+       : (C    ; immediate
+
+       : (C64  ; immediate
+\      : (C16  ; immediate
+\      : (C16+ ; immediate
+\      : (C16- ; immediate
+
+\      : (C64  [compile] ( ; immediate
+       : (C16  [compile] ( ; immediate
+       : (C16+ [compile] ( ; immediate
+       : (C16- [compile] ( ; immediate
+
+
+
+
+
+\ *** Block No. 10, Hexblock a
+
+\ load/remove  JSR-Macros    clv14.4.87)
+
+Assembler also definitions
+
+(C16+ \needs C16+Jsr          -2 +load )
+(C16+ ' C16+Jsr Is Jsr .( JSR Is:C16+  )
+(C16+ \\ skips rest of screen
+
+\ all other platforms don't need
+\ macros, so we skip the rest:
+\
+
+\needs C16+Jsr \\
+
+\ if macro exist, redefine it:
+
+' NormJsr Is Jsr .( JSR Is:Norm )
+
+
+
+
+
+
+
+
+
+\ *** Block No. 11, Hexblock b
+
+cr .( Target is: ) \         clv14.4.87)
+
+
+(C    .( CBM )
+(C64  .( C64 )
+(C16  .( C16 with )
+(C16+ .( 64kb )
+(C16- .( 32kb )
+
+cr .( Target is not: )
+
+(C    \ )      .( CBM, )
+(C64  \ )      .( C64, )
+(C16  \ )      .( C16, )
+(C16+ \ )      .( C16+64kb, )
+(C16- \ )      .( C16-32kb, )
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 12, Hexblock c
+
+\ ramfill                             3:
+
+Onlyforth
+
+Code ramfill   ( adr n 8b -)
+ sei  34 # lda  1 sta
+ 3 # lda setup jsr
+ N 3 + ldx txa  N 2+ ora 0<>
+  ?[ N lda 0 # ldy
+    [[ 0 # cpx 0<>
+      ?[[ [[ N 4 + )Y sta iny 0= ?]
+          N 5 + inc dex ]]?
+   N 2+ ldx 0<> ?[
+   [[ N 4 + )Y sta iny N 2+ cpy CS ?] ]?
+  ]?
+ 36 # lda  1 sta cli
+ 0 # ldx 1 # ldy Next jmp
+end-code
+
+$C000 $4000 (16 $300 - C)  0 ramfill
+
+forget ramfill
+
+
+
+
+\ *** Block No. 13, Hexblock d
+
+( Deleting Assembler Labels bp27jun85we)
+
+: delete   Assembler name find
+ IF  >name count $1F and
+   bounds ?DO $1F I c! LOOP
+ ELSE  count type space THEN ;
+
+delete setup     delete xyNext
+delete Puta      delete SP
+delete Pop       delete Next
+delete N         delete UP
+delete Poptwo    delete W
+delete IP        delete RP
+delete Push      delete Push0A
+delete PushA     delete ;c:
+
+forget delete Onlyforth
+
+
+
+
+
+
+
+
+
+\ *** Block No. 14, Hexblock e
+
+( Definition for  .status     28jun85we)
+
+: status
+ blk @ ?dup IF
+  ."  blk " u.
+  ." here "  here u.
+  ." there " there u.
+  ." heap "  heap u.  cr
+  THEN ;
+
+' status is .status
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 15, Hexblock f
+
+\ C64    Forth loadscreen     clv14oct87
+
+Onlyforth hex
+  -3    +load   \ clear memory and
+  -2 -1 +thru   \ clr labels  .status
+  -6 -4 +thru   \ Target-Machine
+Onlyforth
+
+(C64 $801 ) (C16 $1001 ) dup displace !
+
+Target definitions   here!
+
+$1 $6E +thru
+
+Assembler nonrelocate
+
+.unresolved
+
+' .blk is .status
+
+    -4 +load    \ Print Target-Machine
+
+cr .( save-target volksforth83)
+91 con! ( Cursor up) quit
+
+
+\ *** Block No. 16, Hexblock 10
+
+\ FORTH Preamble and ID       clv06aug87
+
+(C64  $D c, $8 c, $A c, 00 c, 9E c,
+28 c, 32 c, 30 c, 36 c, 34 c, 29 c,
+00 c, 00 c, 00 c, 00 c, ) \ SYS(2064)
+(C16  $D c, 10 c, $A c, 00 c, 9E c,
+28 c, 34 c, 31 c, 31 c, 32 c, 29 c,
+00 c, 00 c, 00 c, 00 c, ) \ SYS(4112)
+
+Assembler
+  nop  0 jmp  here 2- >label >cold
+  nop  0 jmp  here 2- >label >restart
+
+here dup origin!
+\ Here are coldstart- and Uservariables
+\
+0 jmp  0 jsr  here 2- >label >wake
+ end-code
+$100 allot
+
+Create logo
+ (C64  ," volksFORTH-83 3.80.1-C64  " )
+ (C16+ ," volksFORTH-83 3.80.1-C16+ " )
+ (C16- ," volksFORTH-83 3.80.1-C16- " )
+
+
+\ *** Block No. 17, Hexblock 11
+
+( Zero page Variables & Next  03apr85bp)
+
+02 dup     >label RP     2+
+   dup     >label UP     2+
+
+   dup     >label Puta   1+
+   dup     >label SP     2+
+   dup     >label Next
+   dup 5 + >label IP
+      13 + >label W
+
+     W 8 + >label N
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 18, Hexblock 12
+
+( Next, moved into Zero page  08apr85bp)
+
+Label Bootnext
+   -1 sta              \ -1 is dummy SP
+   IP )Y lda  W 1+  sta
+   -1 lda     W sta    \ -1 is dummy IP
+   clc IP lda  2 # adc  IP sta
+     CS not ?[ Label Wjmp -1 ) jmp ]?
+   IP 1+ inc  Wjmp bcs
+end-code
+
+here Bootnext - >label Bootnextlen
+
+Code end-trace  ( Patch Next for trace )
+ $A5 # lda  Next $A + sta
+  IP # lda  Next $B + sta
+ $69 # lda  Next $C + sta
+   2 # lda  Next $D + sta
+ Next jmp   end-code
+
+
+
+
+
+
+
+\ *** Block No. 19, Hexblock 13
+
+\ ;c:  noop                    02nov87re
+
+Create recover  ( -- adr )   Assembler
+ pla  W sta  pla  W 1+ sta
+ W wdec  0 jmp   end-code
+
+here 2- >label >recover
+\ handcrafted forward reference for
+\ jmp command
+
+Compiler Assembler also definitions
+ H : ;c:   0 T recover jsr
+ end-code  ] H ;
+Target
+
+Code noop   Next here 2- !  end-code
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 20, Hexblock 14
+
+\ User variables              clv14oct87
+
+Constant origin  8 uallot drop
+                 \ For multitasker
+
+User s0       $7CFA s0 !
+User r0       $7FFE r0 !
+User dp
+User offset      0 offset !
+User base      &10 base !
+User output
+User input
+User errorhandler
+     \ pointer for  Abort" -code
+User voc-link
+User udp
+     \ points to next free addr in User
+
+
+
+
+
+
+
+
+
+\ *** Block No. 21, Hexblock 15
+
+( manipulate system pointers  29jan85bp)
+
+Code sp@   ( -- addr)
+ SP lda  N sta  SP 1+ lda  N 1+ sta
+ N # ldx
+Label Xpush
+ SP 2dec  1 ,X lda  SP )Y sta
+ 0 ,X lda  0 # ldx  Puta jmp   end-code
+
+Code sp!   ( addr --)
+ SP X) lda  tax  SP )Y lda
+ SP 1+ sta  SP stx   0 # ldx
+ Next jmp   end-code
+
+Code up@   ( -- addr)
+ UP # ldx  Xpush jmp  end-code
+
+Code up!   ( addr --)      UP # ldx
+Label Xpull     SP )Y lda  1 ,X sta
+            dey SP )Y lda  0 ,X sta
+Label (xydrop   0 # ldx  1 # ldy
+Label (drop     SP 2inc  Next jmp
+end-code restrict
+
+
+
+\ *** Block No. 22, Hexblock 16
+
+( manipulate returnstack   16feb85bp/ks)
+
+Code rp@ ( -- addr )
+ RP # ldx  Xpush jmp  end-code
+
+Code rp! ( addr -- )
+ RP # ldx  Xpull jmp  end-code restrict
+
+Code >r  ( 16b --  )
+ RP 2dec  SP X) lda   RP X) sta
+ SP )Y lda   RP )Y sta (drop jmp
+end-code restrict
+
+Code r>  ( -- 16b)
+ SP 2dec  RP X) lda  SP X) sta
+          RP )Y lda  SP )Y sta
+Label (rdrop     2 # lda
+Label (nrdrop    clc  RP adc  RP sta
+    CS ?[  RP 1+ inc  ]?
+ Next jmp  end-code  restrict
+
+
+
+
+
+
+\ *** Block No. 23, Hexblock 17
+
+\ r@ rdrop  exit  ?exit       clv12jul87
+
+Code r@      ( -- 16b)
+ SP 2dec  RP )Y lda  SP )Y sta
+          RP X) lda  Puta jmp
+end-code
+
+Code rdrop    (rdrop here 2- !
+end-code   restrict
+
+Code exit
+ RP X) lda  IP sta
+ RP )Y lda  IP 1+ sta
+ (rdrop jmp   end-code
+Code unnest
+ RP X) lda  IP sta
+ RP )Y lda  IP 1+ sta
+ (rdrop jmp   end-code
+
+Code ?exit     ( flag -- )
+ SP X) lda  SP )Y ora
+ php  SP 2inc  plp
+ ' exit @ bne  Next jmp
+end-code
+
+
+\ *** Block No. 24, Hexblock 18
+
+( execute  perform            08apr85bp)
+
+Code execute  ( addr --)
+ SP X) lda   W sta
+ SP )Y lda   W 1+ sta
+ SP 2inc     W 1- jmp   end-code
+
+: perform ( addr -- )   @ execute ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 25, Hexblock 19
+
+( c@   c! ctoggle             10jan85bp)
+
+Code c@ ( addr -- 8b)
+ SP X) lda  N sta   SP )Y lda  N 1+ sta
+Label (c@    0 # lda  SP )Y sta
+ N X)  lda   Puta jmp   end-code
+
+Code c!  ( 16b addr --)
+ SP X) lda   N sta   SP )Y lda  N 1+ sta
+ iny  SP )Y lda  N X) sta dey
+Label (2drop
+ SP lda  clc  4 # adc  SP sta
+   CS ?[  SP 1+ inc  ]?
+ Next jmp   end-code
+
+: ctoggle   ( 8b addr --)
+ under c@ xor swap c! ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 26, Hexblock 1a
+
+( @ ! +!                      08apr85bp)
+
+Code @  ( addr -- 16b)
+ SP X) lda  N sta  SP )Y lda  N 1+ sta
+ N )Y lda  SP )Y sta
+ N X) lda Puta jmp   end-code
+
+Code !   ( 16b addr --)
+ SP X) lda  N sta  SP )Y lda  N 1+ sta
+ iny SP )Y lda  N X) sta
+ iny SP )Y lda   1 # ldy
+Label (!
+ N )Y sta  (2drop jmp   end-code
+
+Code +!  ( n addr --)
+ SP X) lda  N sta  SP )Y lda  N 1+ sta
+ iny  SP )Y lda  clc  N X) adc N X) sta
+ iny  SP )Y lda  1 # ldy  N )Y adc
+ (! jmp   end-code
+
+
+
+
+
+
+
+\ *** Block No. 27, Hexblock 1b
+
+( drop swap                   24may84ks)
+
+Code drop  ( 16b --)
+ (drop here 2- !  end-code
+
+Code swap  ( 16b1 16b2 -- 16b2 16b1 )
+ SP )Y lda  tax
+ 3 # ldy  SP )Y lda  N sta
+ txa  SP )Y sta
+ N lda  1 # ldy  SP )Y sta
+ iny  0 # ldx
+ SP )Y lda  N sta  SP X) lda  SP )Y sta
+ dey
+ N lda Puta jmp   end-code
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 28, Hexblock 1c
+
+( dup  ?dup                   08may85bp)
+
+Code dup   ( 16b -- 16b 16b)
+ SP 2dec
+ 3 # ldy  SP )Y lda  1 # ldy  SP )Y sta
+ iny  SP )Y lda  dey
+ Puta jmp   end-code
+
+Code ?dup     ( 16b -- 16b 16b / false)
+ SP X) lda  SP )Y ora
+   0= ?[  Next jmp  ]?
+ ' dup @ jmp end-code
+
+
+\\ : ?dup   ( 16b -- 16b 16b / false)
+    dup  IF  dup  THEN ;
+
+   : dup    Sp@  @  ;
+
+
+
+
+
+
+
+
+\ *** Block No. 29, Hexblock 1d
+
+( over rot                    13jun84ks)
+
+Code over  ( 16b1 16b2 - 16b1 16b3 16b1)
+
+ SP 2dec  4 # ldy  SP )Y lda  SP X) sta
+ iny  SP )Y lda  1 # ldy  SP )Y sta
+ Next jmp   end-code
+
+Code rot
+    ( 16b1 16b2 16b3 -- 16b2 16b3 16b1)
+ 3 # ldy  SP )Y lda  N 1+ sta
+ 1 # ldy  SP )Y lda  3 # ldy  SP )Y sta
+ 5 # ldy  SP )Y lda  N sta
+ N 1+ lda  SP )Y sta
+ 1 # ldy  N lda  SP )Y sta
+ iny  SP )Y lda  N 1+ sta
+ SP X) lda  SP )Y sta
+ 4 # ldy  SP )Y lda  SP X) sta
+ N 1+ lda  SP )Y sta
+ 1 # ldy  Next jmp   end-code
+
+\\ : rot   >r swap r> swap ;
+   : over  >r dup r> swap ;
+
+
+
+\ *** Block No. 30, Hexblock 1e
+
+( -rot nip under pick roll    24dec83ks)
+
+: -rot
+    ( 16b1 16b2 16b3 -- 16b3 16b1 16b2)
+ rot rot ;
+
+: nip   ( 16b1 16b2 -- 16b2)
+ swap drop ;
+
+: under ( 16b1 16b2 -- 16b2 16b1 16b2)
+ swap over ;
+
+: pick  ( n -- 16b.n )   1+ 2* sp@ + @ ;
+
+: roll  ( n --)
+ dup >r pick sp@ dup 2+ r> 1+ 2* cmove>
+ drop ;
+
+\\ : -roll ( n --)
+ >r dup sp@  dup 2+ dup 2+ swap
+ r@ 2* cmove r> 1+ 2* + ! ;
+
+
+
+
+
+\ *** Block No. 31, Hexblock 1f
+
+( double word stack manip.    21apr83ks)
+
+: 2swap ( 32b1 32b2 -- 32b2 32b1)
+ rot >r rot r> ;
+
+Code 2drop ( 32b -- )
+ (2drop here 2- !   end-code
+
+\  : 2drop ( 32b -- )    drop drop ;
+
+: 2dup  ( 32b -- 32b 32b)
+ over over ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 32, Hexblock 20
+
+( + and or xor                08apr85bp)
+
+Compiler  Assembler also definitions
+
+H : Dyadop ( opcode --)  T
+   iny  SP X) lda  dup c, SP c,
+   SP )Y sta
+   dey  SP )Y lda  3 # ldy  c, SP c,
+   SP )Y sta
+   (xydrop jmp  H ;
+
+Target
+
+Code +     ( n1 n2 -- n3)
+ clc $71 Dyadop   end-code
+
+Code or    ( 16b1 16b2 -- 16b3)
+     $11 Dyadop   end-code
+
+Code and   ( 16b1 16b2 -- 16b3)
+     $31 Dyadop   end-code
+
+Code xor   ( 16b1 16b2 -- 16b3)
+     $51 Dyadop   end-code
+
+
+\ *** Block No. 33, Hexblock 21
+
+( -  not  negate              24dec83ks)
+
+Code -    ( n1 n2 -- n3)
+ iny SP )Y lda  sec SP X) sbc SP )Y sta
+ iny SP )Y lda
+ 1 # ldy  SP )Y sbc  3 # ldy  SP )Y sta
+ (xydrop jmp   end-code
+
+Code not   ( 16b1 -- 16b2)   clc
+Label (not
+ txa  SP X) sbc  SP X) sta  txa
+      SP )Y sbc  SP )Y sta
+ Next jmp   end-code
+
+Code negate   ( n1 -- n2 )
+ sec  (not bcs   end-code
+
+\ : -       negate + ;
+
+
+
+
+
+
+
+
+\ *** Block No. 34, Hexblock 22
+
+( dnegate setup d+            14jun84ks)
+
+Code dnegate ( d1 -- -d1)
+ iny  sec
+ txa  SP )Y sbc  SP )Y sta  iny
+ txa  SP )Y sbc  SP )Y sta
+ txa  SP X) sbc  SP X) sta  1 # ldy
+ txa  SP )Y sbc  SP )Y sta
+ Next jmp  end-code
+
+Label Setup  ( quan  in A)
+ .A asl tax tay  dey
+    [[ SP )Y lda  N ,Y sta  dey  0< ?]
+ txa  clc  SP adc  SP sta
+    CS ?[  SP 1+ inc  ]?
+ 0 # ldx  1 # ldy   rts   end-code
+
+Code d+      ( d1 d2 -- d3)
+ 2 # lda  Setup jsr  iny
+ SP )Y lda  clc N 2+  adc SP )Y sta iny
+ SP )Y lda      N 3 + adc SP )Y sta
+ SP X) lda  N    adc SP X) sta  1 # ldy
+ SP )Y lda  N 1+ adc SP )Y sta
+ Next jmp   end-code
+
+
+\ *** Block No. 35, Hexblock 23
+
+( 1+ 2+ 3+    1- 2-           08apr85bp)
+
+Code 1+   ( n1 -- n2)   1 # lda
+Label n+  clc  SP X) adc
+ CS not   ?[  Puta jmp  ]?
+ SP X) sta  SP )Y lda  0 # adc SP )Y sta
+ Next jmp  end-code
+
+Code 2+   ( n1 -- n2)
+ 2 # lda   n+ bne     end-code
+Code 3+   ( n1 -- n2)
+ 3 # lda   n+ bne     end-code
+| Code 4+ ( n1 -- n2)
+ 4 # lda   n+ bne     end-code
+| Code 6+ ( n1 -- n2)
+ 6 # lda   n+ bne     end-code
+
+Code 1-   ( n1 -- n2)   sec
+Label (1-     SP X) lda  1 # sbc
+   CS ?[ Puta jmp ]?
+ SP X) sta  SP )Y lda  0 # sbc SP )Y sta
+ Next jmp  end-code
+
+Code 2-   ( n1 -- n2)
+ clc (1- bcc  end-code
+
+\ *** Block No. 36, Hexblock 24
+
+( number Constants            24dec83ks)
+
+-1 Constant true    0 Constant false
+
+' true Alias -1     ' false Alias 0
+
+1 Constant 1        2 Constant 2
+3 Constant 3        4 Constant 4
+
+: on    ( addr -- )  true  swap ! ;
+: off   ( addr -- )  false swap ! ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 37, Hexblock 25
+
+( words for number literals   24may84ks)
+
+Code clit  ( -- 8b)
+ SP 2dec  IP X) lda  SP X) sta
+  txa   SP )Y sta  IP winc
+ Next jmp   end-code restrict
+
+Code lit   ( -- 16b)
+ SP 2dec  IP )Y lda  SP )Y sta
+          IP X) lda  SP X) sta
+Label (bump   IP 2inc
+ Next jmp  end-code restrict
+
+: Literal   ( 16b --)
+ dup $FF00 and
+   IF  compile lit   , exit THEN
+       compile clit c,  ;
+immediate restrict
+
+
+\\ : lit     r> dup 2+ >r  @  ;
+   : clit    r> dup 1+ >r  c@ ;
+
+
+
+
+\ *** Block No. 38, Hexblock 26
+
+( comparision code words      13jun84ks)
+
+Code 0<   ( n -- flag)
+ SP )Y lda  0< ?[
+Label putTrue    $FF # lda  $24 c, ]?
+Label putFalse   txa  SP )Y sta
+ Puta jmp   end-code
+
+Code 0=   ( 16b -- flag)
+ SP X) lda  SP )Y ora
+ putTrue  beq
+ putFalse bne  end-code
+
+Code uwithin  ( u1 [low up[  -- flag)
+ 2 # lda  Setup jsr
+ 1 # ldy  SP X) lda  N cmp
+          SP )Y lda  N 1+ sbc
+  CS not ?[ ( N>SP) SP X) lda N 2+  cmp
+                    SP )Y lda N 3 + sbc
+           putTrue bcs ]?
+ putFalse jmp  end-code
+
+
+
+
+
+\ *** Block No. 39, Hexblock 27
+
+( comparision code words      13jun84ks)
+
+Code <    ( n1 n2 -- flag)
+ SP X) lda  N sta  SP )Y lda  N 1+ sta
+ SP 2inc
+ N 1+ lda  SP )Y eor  ' 0< @  bmi
+ SP X) lda  N cmp  SP )Y lda  N 1+ sbc
+ ' 0< @ 2+ jmp    end-code
+
+Code u<   ( u1 u2 -- flag)
+ SP X) lda  N sta  SP )Y lda  N 1+ sta
+ SP 2inc
+ SP X) lda  N cmp  SP )Y lda  N 1+ sbc
+   CS not ?[  putTrue jmp  ]?
+              putFalse jmp  end-code
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 40, Hexblock 28
+
+( comparision words           24dec83ks)
+
+\ : 0<   $8000 and  0<> ;
+
+: >   ( n1 n2 -- flag)  swap < ;
+
+: 0>  ( n --     flag)  negate 0<  ;
+
+: 0<> ( n --     flag)  0= not ;
+
+: u>  ( u1 u2 -- flag)  swap u< ;
+
+: =   ( n1 n2 -- flag)  - 0= ;
+
+: d0= ( d --     flag)  or 0= ;
+
+: d=  ( d1 d2 -- flag)  dnegate d+ d0= ;
+
+: d<  ( d1 d2 -- flag)  rot 2dup -
+ IF > nip nip  ELSE 2drop u< THEN ;
+
+
+
+
+
+
+\ *** Block No. 41, Hexblock 29
+
+( min max umax umin extend dabs abs  ks)
+
+| : minimax  ( n1 n2 flag -- n3)
+   rdrop  IF swap THEN drop ;
+
+: min   ( n1 n2 -- n3)
+ 2dup  > minimax ;
+
+: max   ( n1 n2 -- n3)
+ 2dup  < minimax ;
+
+: umax  ( u1 u2 -- u3)
+ 2dup u< minimax ;
+
+: umin  ( u1 u2 -- u3)
+ 2dup u> minimax ;
+
+
+: extend  ( n -- d)     dup 0< ;
+
+: dabs    ( d -- ud)
+ extend IF  dnegate THEN ;
+
+: abs     ( n -- u)
+ extend IF   negate THEN ;
+
+\ *** Block No. 42, Hexblock 2a
+
+\ loop primitives              02nov87re
+
+| : dodo
+ rdrop r> 2+ dup >r rot >r swap >r >r ;
+
+: (do  ( limit star -- )
+ over - dodo ;      restrict
+
+: (?do ( limit start -- )
+ over - ?dup  IF dodo THEN
+ r> dup @ +  >r drop ;       restrict
+
+: bounds  ( start count -- limit start )
+ over + swap ;
+
+Code endloop  ( -- )
+ 6 # lda (nrdrop jmp   end-code restrict
+
+\\ dodo puts  "index | limit |
+ adr.of.DO"  on return-stack
+
+
+
+
+
+
+\ *** Block No. 43, Hexblock 2b
+
+\ (loop (+loop                 02nov87re
+
+Code (loop
+ clc  1 # lda  RP X) adc RP X) sta
+   CS ?[  RP )Y lda  0 # adc RP )Y sta
+      CS ?[ Next jmp ]? ]?
+Label doloop  5 # ldy
+ RP )Y lda  IP 1+ sta  dey
+ RP )Y lda  IP    sta  1 # ldy
+ Next jmp    end-code restrict
+
+Code (+loop  ( n -- )
+ clc SP X) lda  RP X) adc  RP X) sta
+     SP )Y lda  RP )Y adc  RP )Y sta
+ .A ror  SP )Y eor
+ php  SP 2inc  plp doloop bpl
+ Next jmp    end-code restrict
+
+
+
+
+
+
+
+
+
+\ *** Block No. 44, Hexblock 2c
+
+( loop indices                08apr85bp)
+
+Code I  ( -- n)    0 # ldy
+Label loopindex    SP 2dec   clc
+ RP )Y lda  iny  iny
+ RP )Y adc  SP X) sta  dey
+ RP )Y lda  iny  iny
+ RP )Y adc  1 # ldy  SP )Y sta
+ Next jmp   end-code restrict
+
+Code J  ( -- n)
+ 6 # ldy  loopindex bne
+            end-code  restrict
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 45, Hexblock 2d
+
+\ branching                    02nov87re
+
+Code branch
+ clc  IP    lda  IP X) adc  N sta
+      IP 1+ lda  IP )Y adc  IP 1+ sta
+ N lda IP sta
+ Next jmp     end-code restrict
+
+Code ?branch  ( flag -- )
+ SP X) lda  SP )Y ora
+ php  SP 2inc  plp
+ ' branch @ beq    (bump jmp
+end-code   restrict
+
+
+
+\\  : branch   r> dup @ + >r ; restrict
+
+    : ?branch  ( flag -- )
+     0= r> over not over 2+  and -rot
+     dup @ + and or >r ;       restrict
+
+
+
+
+
+\ *** Block No. 46, Hexblock 2e
+
+( resolve loops and branches  03feb85bp)
+
+: >mark     ( -- addr)  here   0 , ;
+
+: >resolve  ( addr --)
+ here over -   swap !  ;
+
+: <mark     ( -- addr)  here ;
+
+: <resolve  ( addr --) here - ,  ;
+
+: ?pairs  ( n1 n2 -- )
+ -  Abort" unstructured" ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 47, Hexblock 2f
+
+( case?                       04may85bp)
+
+Label  PushA
+ 0 # cmp  0< ?[ pha  $FF # lda ][
+Label  Push0A   pha   0  # lda  ]?
+Label  Push     tax   SP 2dec
+ txa  1 # ldy  SP )Y sta
+ pla  0 # ldx   Puta jmp
+
+Code case?
+ ( 16b1 16b2 -- 16b1 false / true )
+ 1 # lda  Setup jsr
+ N lda  SP X) cmp
+  0= ?[   N 1+ lda  SP )Y cmp
+    0= ?[ putTrue jmp ]?  ]?
+ txa  Push0A jmp   end-code
+
+
+
+\\ : case?
+ ( 16b1 16b2 -- 16b1 false / true )
+ over = dup  IF  nip  THEN ;
+
+
+
+
+\ *** Block No. 48, Hexblock 30
+
+( Branching                   03feb85bp)
+
+: IF     compile ?branch >mark  1 ;
+         immediate restrict
+
+: THEN   abs 1   ?pairs  >resolve ;
+         immediate restrict
+
+: ELSE   1 ?pairs  compile branch >mark
+         swap >resolve  -1 ;
+         immediate restrict
+
+: BEGIN  <mark 2 ; immediate restrict
+
+: WHILE  2 ?pairs  2   compile ?branch
+         >mark -2  2swap  ;
+         immediate restrict
+
+| : (reptil   <resolve   BEGIN dup -2
+    = WHILE  drop >resolve  REPEAT  ;
+
+: REPEAT 2 ?pairs  compile branch
+         (reptil ; immediate restrict
+: UNTIL  2 ?pairs  compile ?branch
+         (reptil ; immediate restrict
+
+\ *** Block No. 49, Hexblock 31
+
+( Loops                    29jan85ks/bp)
+
+: DO     compile (do  >mark  3 ;
+         immediate restrict
+
+: ?DO    compile (?do >mark  3 ;
+         immediate restrict
+
+: LOOP   3 ?pairs  compile (loop
+         compile endloop  >resolve ;
+         immediate restrict
+
+: +LOOP  3 ?pairs  compile (+loop
+         compile endloop  >resolve ;
+         immediate restrict
+
+: LEAVE  endloop r> 2- dup @ + >r ;
+         restrict
+
+\\ Returnstack: calladr | index
+                  limit | adr of DO
+
+
+
+
+
+\ *** Block No. 50, Hexblock 32
+
+( um*                      bp/ks13.2.85)
+
+Code um*  ( u1 u2 -- ud)
+ SP )Y lda N sta  SP X) lda  N 1+ sta
+ iny N 2 + stx N 3 + stx  $10 # ldx
+  [[ N 3 + asl N 2+ rol N 1+ rol N rol
+   CS ?[ clc
+         SP )Y lda  N 3 + adc  N 3 + sta
+         iny  SP )Y lda dey
+         N 2 + adc   N 2 + sta
+           CS ?[  N 1+ inc
+              0= ?[  N   inc  ]? ]? ]?
+    dex  0= ?]
+ N 3 + lda   SP )Y sta   iny
+ N 2 + lda   SP )Y sta   1 # ldy
+ N     lda   SP )Y sta
+ N 1+ lda    SP X) sta
+ Next jmp   end-code
+
+
+\\ : um*   ( u1 u2 -- ud3)
+ >r 0 0 0 r>  $10 0
+  DO  dup 2/ >r  1 and IF 2over d+ THEN
+      >r >r 2dup d+ r> r> r>  LOOP
+ drop 2swap 2drop ;
+
+\ *** Block No. 51, Hexblock 33
+
+( m* 2*                       04jul84ks)
+
+: m*     ( n1 n2 -- d)
+ dup 0< dup >r IF negate THEN
+ swap dup  0<  IF negate r> not >r THEN
+ um*  r> IF dnegate THEN ;
+
+: *      ( n n -- prod)   um* drop ;
+
+Code 2*  ( n1 -- n2)
+ SP X) lda  .A asl  SP X) sta
+ SP )Y lda  .A rol  SP )Y sta
+ Next jmp    end-code
+
+
+\ : 2*   dup + ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 52, Hexblock 34
+
+( um/mod                      04jul84ks)
+
+| : divovl
+   true Abort" division overflow" ;
+
+Code um/mod  ( ud u -- urem uquot)
+ SP X) lda  N 5 + sta
+ SP )Y lda  N 4 + sta   SP 2inc
+ SP X) lda  N 1+  sta
+ SP )Y lda  N     sta   iny
+ SP )Y lda  N 3 + sta   iny
+ SP )Y lda  N 2+  sta   $11 # ldx  clc
+  [[ N 6 + ror  sec  N 1+ lda  N 5 + sbc
+     tay  N lda  N 4 + sbc
+    CS not ?[  N 6 + rol ]?
+      CS ?[ N sta  N 1+ sty ]?
+     N 3 + rol N 2+ rol N 1+ rol N rol
+  dex  0= ?]
+ 1 # ldy  N ror  N 1+ ror
+   CS ?[ ;c: divovl ; Assembler ]?
+ N 2+  lda SP )Y sta iny
+ N 1+  lda SP )Y sta iny
+ N     lda SP )Y sta 1 # ldy
+ N 3 + lda
+ Puta jmp    end-code
+
+\ *** Block No. 53, Hexblock 35
+
+( 2/ m/mod                    24dec83ks)
+
+: m/mod  ( d n -- mod quot)
+ dup >r abs  over
+   0< IF  under + swap  THEN
+ um/mod r@
+ 0< IF negate over IF swap r@ + swap 1-
+ THEN THEN rdrop ;
+
+Code 2/  ( n1 -- n2)
+ SP )Y lda  .A asl
+ SP )Y lda  .A ror  SP )Y sta
+ SP X) lda  .A ror
+ Puta jmp      end-code
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 54, Hexblock 36
+
+( /mod / mod */mod */ u/mod  ud/mod  ks)
+
+: /mod  ( n1 n2 -- rem quot)
+ >r extend r> m/mod ;
+
+: /     ( n1 n2 -- quot)     /mod nip ;
+
+: mod   ( n1 n2 -- rem)      /mod drop ;
+
+: */mod ( n1 n2 n3 -- rem quot)
+ >r m*  r> m/mod ;
+
+: */    ( n1 n2 n3 -- quot)  */mod nip ;
+
+: u/mod  ( u1 u2  -- urem uquot)
+ 0 swap um/mod ;
+
+: ud/mod ( ud1 u2 -- urem udquot)
+ >r  0  r@  um/mod  r>
+   swap >r  um/mod  r>  ;
+
+
+
+
+
+
+\ *** Block No. 55, Hexblock 37
+
+( cmove cmove> (cmove>       bp 08apr85)
+
+Code cmove  ( from to quan --)
+ 3 # lda Setup jsr  dey
+ [[ [[  N cpy  0= ?[  N 1+ dec  0< ?[
+                1 # ldy  Next jmp  ]? ]?
+     N 4 + )Y lda  N 2+ )Y sta iny 0= ?]
+     N 5 + inc N 3 + inc  ]]  end-code
+
+Code cmove> ( from to quan --)
+ 3 # lda Setup jsr
+ clc N 1+ lda  N 3 + adc  N 3 + sta
+ clc N 1+ lda  N 5 + adc  N 5 + sta
+ N 1+ inc  N ldy  clc CS ?[
+Label (cmove>
+ dey  N 4 + )Y lda  N 2+ )Y sta ]?
+ tya  (cmove> bne
+ N 3 + dec  N 5 + dec  N 1+ dec
+ (cmove> bne  1 # ldy
+ Next jmp   end-code
+
+: move   ( from to quan --)
+ >r 2dup u<  IF r> cmove> exit THEN
+ r> cmove ;
+
+
+\ *** Block No. 56, Hexblock 38
+
+( place count  erase       16feb85bp/ks)
+
+: place ( addr len to --)
+ over >r rot over 1+ r> move c! ;
+
+Code count ( addr -- addr+1 len)
+ SP X) lda N sta clc 1 # adc SP X) sta
+ SP )Y lda N 1+ sta  0 # adc SP )Y sta
+ SP 2dec  (c@ jmp   end-code
+
+\  : count ( adr -- adr+1 len )
+\   dup 1+  swap c@ ;
+
+: erase ( addr quan --)      0 fill ;
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 57, Hexblock 39
+
+( fill                        11jun85bp)
+
+Code fill  ( addr quan 8b -- )
+ 3 # lda Setup jsr  dey
+ N lda  N 3 + ldx
+  0<> ?[  [[ [[ N 4 + )Y sta iny 0= ?]
+                N 5 + inc    dex 0= ?]
+      ]?  N 2+ ldx
+  0<> ?[  [[ N 4 + )Y sta iny dex 0= ?]
+      ]? 1 # ldy
+ Next jmp   end-code
+
+
+\\
+: fill  ( addr quan 8b --)   swap ?dup
+       IF  >r over c! dup 1+ r> 1- cmove
+  exit  THEN  2drop  ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 58, Hexblock 3a
+
+( here Pad allot , c, compile 24dec83ks)
+
+: here  ( -- addr)   dp @ ;
+
+: pad   ( -- addr)   here $42 + ;
+
+: allot ( n --)      dp +! ;
+
+: ,     ( 16b --)    here !  2  allot ;
+
+: c,    ( 8b --)     here c! 1  allot ;
+
+: compile            r> dup 2+ >r @ , ;
+                     restrict
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 59, Hexblock 3b
+
+( input strings               24dec83ks)
+
+Variable #tib   0 #tib !
+Variable >tib   here >tib !   $50 allot
+Variable >in    0 >in !
+Variable blk    0 blk !
+Variable span   0 span !
+
+: tib   ( -- addr )    >tib @ ;
+
+: query
+ tib  $50 expect
+ span @ #tib !  >in off  blk off ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 60, Hexblock 3c
+
+( scan skip /string           12oct84bp)
+
+: scan  ( addr0 len0 char -- addr1 len1)
+ >r
+     BEGIN  dup  WHILE  over c@ r@ -
+     WHILE  1- swap 1+ swap  REPEAT
+ rdrop ;
+
+: skip  ( addr len del -- addr1 len1)
+ >r
+     BEGIN  dup  WHILE  over c@ r@ =
+     WHILE  1- swap 1+ swap  REPEAT
+ rdrop ;
+
+: /string  ( addr0 len0 +n - addr1 len1)
+ over umin rot over + -rot - ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 61, Hexblock 3d
+
+\ capital                     clv06aug87
+
+Label (capital  \ for commodore only
+                \ for Ascii: next scr
+ Ascii a             # cmp  CS
+ ?[ Ascii z    $21 + # cmp  CC
+    ?[ Ascii a $21 + # cmp  CS
+       ?[ $df # and ]? \ 2nd up to low
+     Ascii z      1+ # cmp  CC
+     ?[ $80 # ora      \ low to up
+ ]? ]? ]? rts end-code
+
+Code capital  ( char -- char' )
+ SP X) lda  (capital jsr  SP X) sta
+ Next jmp    end-code
+
+\\ The new (capital does:
+
+No  00-40,5b-60,7b-c1-da-dc-ff no change
+==    -@ , [-@ ,  -A -Z -| -      ..
+
+No  41-5a,61-7a        changes to:c1-da
+==   a-z , A-Z                     A-Z
+
+
+
+\ *** Block No. 62, Hexblock 3e
+
+\ capitalize                  clv06aug87
+
+Code capitalize  ( string -- string )
+ SP X) lda N    sta  SP )Y lda  N 1+ sta
+  N X) lda N 2+ sta   dey
+ [[ N 2+ cpy  0= ?[ 1 # ldy  Next jmp ]?
+   iny N )Y lda  (capital jsr  N )Y sta
+ ]]   end-code
+
+\\ : capitalize  ( string -- string )
+ dup  count  bounds
+  ?DO  I c@  capital  I c!  THEN  LOOP ;
+
+\\ capital ( char -- char )
+   Ascii a  Ascii z 1+  uwithin
+   IF  I c@  [ Ascii a  Ascii A - ]
+ Literal -  ;
+
+\\ Label (capital  \ for Ascii only
+ Ascii a # cmp
+ CS ?[  Ascii z  1+ # cmp
+    CC ?[      sec
+           Ascii a Ascii A - # sbc
+  ]? ]?  rts  end-code
+
+
+\ *** Block No. 63, Hexblock 3f
+
+( (word                       08apr85bp)
+
+| Code (word   ( char adr0 len0 -- adr)
+       \ N   : length of source
+       \ N+2 : ptr in source / next char
+       \ N+4 : string start adress
+       \ N+6 : string length
+ N 6 + stx        \ 0 =: string_length
+ 3 # ldy
+  [[ SP )Y lda  N ,Y sta dey  0< ?]
+ 1 # ldy  clc
+ >in    lda  N 2+  adc  N 2+  sta
+                  \ >in+adr0 =: N+2
+ >in 1+ lda  N 3 + adc  N 3 + sta
+ sec  N lda  >in    sbc  N    sta
+                  \ len0->in =: N
+   N 1+ lda  >in 1+ sbc  N 1+ sta
+  CC ?[ SP X) lda  >in    sta
+                  \ stream exhausted
+        SP )Y lda  >in 1+ sta
+
+
+
+
+
+
+\ *** Block No. 64, Hexblock 40
+
+( (word                       08apr85bp)
+
+][ 4 # ldy  [[  N lda  N 1+ ora
+                  \ skip char's
+       0= not ?[[ N 2+ X) lda SP )Y cmp
+                  \ while count <>0
+       0=     ?[[ N 2+ winc  N wdec ]]?
+    N 2+  lda  N 4 + sta
+              \ save string_start_adress
+    N 3 + lda  N 5 + sta
+    [[  N 2+ X) lda  SP )Y cmp php
+              \ scan for char
+        N 2+ winc  N wdec plp
+    0= not ?[[ N 6 + inc
+              \ count string_length
+       N lda N 1+ ora
+    0= ?]  ]? ]?
+              \ from count = 0 in skip)
+ sec 2 # ldy
+       \ adr_after_string - adr0 =: >in)
+ N 2+  lda  SP )Y sbc  >in    sta  iny
+ N 3 + lda  SP )Y sbc  >in 1+ sta
+
+
+
+
+\ *** Block No. 65, Hexblock 41
+
+( (word                       08apr85bp)
+
+]? \ from 1st ][, stream was exhausted
+   \ when word called)
+ clc  4 # lda  SP adc  SP sta
+  CS ?[ SP 1+ inc ]?  \ 2drop
+ user' dp # ldy  UP )Y lda
+ SP X) sta N    sta  iny
+ UP )Y lda 1 # ldy
+ SP )Y sta N 1+ sta        \ dp @
+ dey N 6 + lda  \ store count byte first
+ [[  N )Y sta  N 4 + )Y lda  iny
+     N 6 + dec  0< ?]
+ $20 # lda  N )Y sta       \ add a blank
+ 1 # ldy   Next jmp   end-code
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 66, Hexblock 42
+
+( source word parse name      08apr85bp)
+
+: source   ( -- addr len)
+ blk @  ?dup IF  block b/blk exit THEN
+ tib #tib @  ;
+
+: word  ( char -- addr)   source (word ;
+
+: parse ( char -- addr len)
+ >r source  >in @  /string over swap
+ r> scan >r over - dup r> 0<> - >in +! ;
+
+: name   ( -- addr)
+ bl word  capitalize  exit  ;
+
+
+\\
+: word  ( char -- addr)        >r
+ source  over swap  >in @  /string
+ r@ skip  over  swap  r> scan
+ >r  rot over swap  - r> 0<> -  >in !
+ over - here place  bl here count + c!
+ here ;
+
+
+
+\ *** Block No. 67, Hexblock 43
+
+\ state Ascii ,"  ("  "        02nov87re
+
+Variable state    0 state !
+
+: Ascii  ( -- char )  ( -- )
+ bl word 1+ c@ state @
+ IF [compile] Literal THEN ; immediate
+
+: ,"       Ascii "  parse
+ here over 1+  allot place  ;
+
+: "lit  ( -- adr )
+ r> r> under count + >r >r ; restrict
+
+: ("    ( -- adr )   "lit ; restrict
+
+: "        compile ("  ,"  ;
+                immediate restrict
+
+
+
+
+
+
+
+
+\ *** Block No. 68, Hexblock 44
+
+( ." ( .( \ \\ hex decimal    08sep84ks)
+
+: (."    "lit count type ; restrict
+
+: ."     compile (." ," ;
+                    immediate restrict
+
+: (      Ascii )  parse 2drop ;
+                    immediate
+
+: .(     Ascii )  parse type ;
+                    immediate
+
+: \      >in @  c/l /  1+ c/l *  >in ! ;
+                    immediate
+
+: \\        b/blk >in ! ;  immediate
+
+: \needs
+ name find nip  IF  [compile] \  THEN ;
+
+: hex       $10 base ! ;
+: decimal    $A base ! ;
+
+
+
+\ *** Block No. 69, Hexblock 45
+
+( number conv.:  digit?  accumulate  ks)
+
+: digit?  ( char -- digit true/ false )
+ Ascii 0 -   dup 9 u>
+ IF [ Ascii A Ascii 9 - 1- ]
+   Literal -  dup 9 u>
+     IF [ 2swap ( unstructured ) ] THEN
+   base @  over  u>  ?dup  ?exit
+ THEN drop  false ;
+
+: accumulate ( +d0 adr digit - +d1 adr)
+ swap >r swap  base @ um*  drop  rot
+ base @ um*  d+  r>  ;
+
+: convert  ( +d1 addr0 -- +d2 addr2)
+ 1+  BEGIN  count digit?
+     WHILE  accumulate    REPEAT  1- ;
+
+: end?   ( -- flag )  ptr @  0= ;
+
+: char   ( addr0 -- addr1 char )
+ count   -1 ptr +!  ;
+
+: previous  ( addr0 -- addr0 char)
+ 1-  count ;
+
+\ *** Block No. 70, Hexblock 46
+
+( ?nonum ?num fixbase?        13feb85ks)
+
+Variable dpl   -1 dpl !
+
+| : ?nonum  ( flag -- exit if true )
+ IF rdrop 2drop drop rdrop false THEN ;
+
+| : ?num    ( flag -- exit if true )
+ IF rdrop drop r> IF  dnegate  THEN
+    rot drop  dpl @ 1+  ?dup ?exit
+    drop true THEN ;
+
+| : fixbase?
+ ( char - char false /  newbase true )
+ Ascii & case?  IF $A true exit THEN
+ Ascii $ case?  IF 10 true exit THEN
+ Ascii H case?  IF 10 true exit THEN
+ Ascii % case?  IF  2 true exit THEN
+ false  ;
+
+| : punctuation?   ( char -- flag)
+   Ascii , over = swap Ascii . =  or ;
+
+| : ?dpl   dpl @ -1 = ?exit  1 dpl +! ;
+
+
+\ *** Block No. 71, Hexblock 47
+
+( number? number 'number  01oct87clv/re)
+
+| Variable ptr      \ points into string
+
+: number?
+ ( string - string false / n 0< / d 0> )
+ base push  dup count  ptr !  dpl on
+ 0 >r  ( +sign)
+ 0 0 rot           end? ?nonum char
+ Ascii - case?
+ IF rdrop true >r  end? ?nonum char THEN
+ fixbase?
+ IF  base !        end? ?nonum char THEN
+ BEGIN   digit?  0= ?nonum
+   BEGIN  accumulate  ?dpl  end? ?num
+          char digit?  0= UNTIL
+   previous  punctuation?  0= ?nonum
+   dpl off   end? ?num char REPEAT ;
+
+Defer 'number?     ' number? Is 'number?
+
+: number  ( string -- d )
+ 'number?  ?dup 0= Abort" ?"
+ 0< IF extend THEN ;
+
+
+\ *** Block No. 72, Hexblock 48
+
+( hide reveal immediate restrict     ks)
+
+Variable last     0 last !
+
+| : last?   ( -- false / acf true)
+ last @ ?dup ;
+
+: hide
+ last?  IF 2- @ current @ ! THEN ;
+
+: reveal
+ last?  IF 2-   current @ ! THEN ;
+
+: Recursive   reveal  ;
+ immediate restrict
+
+| : flag!    ( 8b --)
+   last? IF under c@ or over c! THEN
+   drop ;
+
+: immediate  $40 flag! ;
+: restrict   $80 flag! ;
+
+
+
+
+\ *** Block No. 73, Hexblock 49
+
+( clearstack hallot heap heap?11feb85bp)
+
+Code clearstack
+ user' s0 # ldy
+ UP )Y lda  SP    sta  iny
+ UP )Y lda  SP 1+ sta
+ 1 # ldy  Next jmp   end-code
+
+: hallot ( quan -- )
+ s0 @ over - swap
+ sp@ 2+  dup rot -  dup s0 !
+ 2 pick over -  move  clearstack  s0 ! ;
+
+: heap   ( -- addr)        s0 @  6+ ;
+
+: heap?  ( addr -- flag)
+ heap up@ uwithin ;
+
+| : heapmove   ( from -- from)
+   dup here  over -
+   dup hallot  heap swap cmove
+   heap over - last +!  reveal ;
+
+
+
+
+\ *** Block No. 74, Hexblock 4a
+
+( Does>  ;                 30dec84ks/bp)
+
+Label (dodoes>   RP 2dec
+IP 1+ lda RP )Y sta  IP lda  RP X) sta
+                          \ put IP on RP
+clc  W X) lda  3 # adc IP sta
+txa  W )Y adc  IP 1+ sta  \ W@ + 3 -> IP
+
+Label docreate
+ 2 # lda  clc W adc pha txa W 1+ adc
+ Push jmp end-code
+
+| : (;code    r> last @  name>  ! ;
+
+: Does>
+ compile (;code  $4C c,
+ compile (dodoes> ;  immediate restrict
+
+
+
+
+
+
+
+
+
+\ *** Block No. 75, Hexblock 4b
+
+( 6502-align  ?head  |        08sep84bp)
+
+| : 6502-align/1   ( adr -- adr' )
+   dup  $FF and  $FF =  - ;
+
+| : 6502-align/2   ( lfa -- lfa )
+   here  $FF and $FF =
+   IF  dup dup 1+  here over - 1+
+       cmove>  \ lfa now invalid
+       1 last +! 1 allot  THEN  ;
+
+
+Variable ?head    0 ?head !
+
+: |     ?head @   ?exit   -1 ?head  ! ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 76, Hexblock 4c
+
+( warning   Create            30dec84bp)
+
+Variable warning  0 warning !
+
+| : exists?
+ warning @ ?exit
+ last @  current @  (find  nip
+ IF space  last @ .name ." exists " ?cr
+ THEN  ;
+
+: Create
+ here blk @ ,  current @ @ ,
+ name  c@ dup 1 $20
+ uwithin not  Abort" invalid name"
+ here  last ! 1+ allot
+ exists? ?head @
+ IF 1 ?head +!  dup  6502-align/1 ,
+                    \ Pointer to code
+    heapmove $20 flag! 6502-align/1 dp !
+ ELSE  6502-align/2  drop
+ THEN  reveal  0 ,
+ ;Code  docreate jmp end-code
+
+
+
+
+\ *** Block No. 77, Hexblock 4d
+
+( nfa?                        30dec84bp)
+
+ Code nfa?
+ ( vocabthread  cfa -- nfa / false)
+ SP X) lda  N 4 + sta
+ SP )Y lda  N 5 + sta   SP 2inc
+ [[ [[ SP X) lda  N 2+  sta
+       SP )Y lda  N 3 + sta
+      N 2+ ora  0= ?[ putFalse jmp ]?
+      N 2+ )Y lda SP )Y sta  N 1+ sta
+      N 2+ X) lda SP X) sta  N sta
+      N 1+ ora  0= ?[  Next jmp  ]?
+                               \ N=link
+      N 2inc N X) lda pha sec $1F # and
+      N adc  N sta  CS ?[ N 1+ inc ]?
+      pla  $20 # and  0= not
+       ?[ N )Y lda  pha
+          N X) lda N sta pla N 1+ sta ]?
+      N lda     N 4 + cmp  0= ?]
+      N 1+ lda  N 5 + cmp  0= ?]
+ ' 2+ @ jmp       end-code
+
+\\ vocabthread=0 that is empty Vocabul-
+ ary in nfa? is not allowed
+
+
+\ *** Block No. 78, Hexblock 4e
+
+( >name name> >body .name     03feb85bp)
+
+: >name   ( cfa -- nfa / false)
+ voc-link
+ BEGIN @ dup WHILE 2dup 4 - swap
+      nfa? ?dup IF -rot 2drop exit THEN
+ REPEAT nip ;
+
+| : (name>  ( nfa -- cfa)
+   count $1F  and + ;
+
+: name>     ( nfa -- cfa)
+ dup (name> swap c@ $20 and IF @ THEN ;
+
+: >body   ( cfa -- pfa)   2+ ;
+
+: .name   ( nfa --)
+ ?dup IF dup heap?  IF ." |" THEN
+         count $1F and type
+      ELSE  ." ???"
+      THEN  space  ;
+
+
+
+
+
+\ *** Block No. 79, Hexblock 4f
+
+\ : ; Constant Variable       clv16jul87
+
+: Create: Create hide
+ current @ context ! ] 0 ;
+
+: :  Create: ;Code here >recover !
+               \ resolve fwd. reference
+ RP 2dec IP    lda  RP X) sta
+         IP 1+ lda  RP )Y sta
+ W lda  clc  2 # adc  IP sta
+      txa   W 1+ adc  IP 1+ sta
+ Next jmp   end-code
+
+: ;        0 ?pairs  compile unnest
+ [compile] [ reveal ; immediate restrict
+
+
+: Constant  ( 16b --)  Create ,
+ ;Code  SP 2dec  2 # ldy
+ W )Y lda  SP X) sta  iny
+ W )Y lda   1 # ldy   SP )Y sta
+ Next jmp   end-code
+
+: Variable   Create  2 allot ;
+
+
+\ *** Block No. 80, Hexblock 50
+
+( uallot User Alias        10jan85ks/bp)
+
+: uallot ( quan -- offset)
+ dup udp @ +  $FF
+   u> Abort" Userarea full"
+ udp  @ swap udp +! ;
+
+: User  Create   2 uallot c,
+ ;Code  SP 2dec  2 # ldy
+ W )Y lda  clc UP    adc  SP X) sta
+      txa  iny UP 1+ adc  1 # ldy
+ SP )Y sta   Next jmp   end-code
+
+: Alias  ( cfa --)
+ Create last @ dup c@ $20 and
+ IF   -2 allot  ELSE  $20 flag! THEN
+ (name> ! ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 81, Hexblock 51
+
+( voc-link vp current context also   bp)
+
+Create   vp       $10 allot
+Variable current
+
+: context ( -- adr  )  vp dup @ + 2+ ;
+
+| : thru.vocstack  ( -- from to )
+   vp 2+ context ;
+\ "Only Forth also Assembler" gives vp :
+\  countword = 6 |Only|Forth|Assembler
+
+: also     vp @
+ $A > Error" Vocabulary stack full"
+ context @   2 vp +!  context ! ;
+
+: toss   -2 vp +! ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 82, Hexblock 52
+
+(  Vocabulary Forth Only Forth-83 ks/bp)
+
+: Vocabulary
+ Create  0 , 0 ,
+ here voc-link @ ,  voc-link !
+ Does>  context ! ;
+
+\ Name | Code | Thread | Coldthread |
+\ Voc-link
+
+Vocabulary Forth
+
+Vocabulary Only
+] Does>  [ Onlypatch ]  0 vp !
+ context !  also  ;  ' Only !
+
+: Onlyforth
+ Only Forth also definitions ;
+
+
+
+
+
+
+
+
+\ *** Block No. 83, Hexblock 53
+
+( definitions order words  13jan84bp/ks)
+
+: definitions   context @ current ! ;
+
+| : .voc  ( adr -- )
+ @ 2- >name .name ;
+
+: order
+ thru.vocstack  DO  I .voc  -2  +LOOP
+ 2 spaces  current .voc ;
+
+: words      context @
+ BEGIN  @ dup stop? 0= and
+ WHILE  ?cr dup 2+ .name space
+ REPEAT drop ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 84, Hexblock 54
+
+( (find                       08apr85bp)
+
+Code (find  ( string thread
+       -- string false / namefield true)
+ 3 # ldy [[ SP )Y lda N ,Y sta dey 0< ?]
+ N 2+ X) lda $1F # and N 4 + sta
+
+Label findloop   0 # ldy
+ N )Y lda   tax   iny
+ N )Y lda  N 1+ sta  N stx  N ora
+  0= ?[ 1 # ldy 0 # ldx putFalse jmp ]?
+ iny N )Y lda  $1F # and  N 4 + cmp
+  findloop bne       \ countbyte match
+ clc 2 # lda N    adc N 5 + sta
+     0 # lda N 1+ adc N 6 + sta
+ N 4  + ldy
+  [[ N 2+ )Y lda N 5 + )Y cmp
+     findloop bne   dey  0= ?]
+ 3 # ldy N 6 + lda  SP )Y sta   dey
+         N 5 + lda  SP )Y sta
+ dey  0 # ldx    putTrue jmp   end-code
+
+
+
+
+
+\ *** Block No. 85, Hexblock 55
+
+( found                       29jan85bp)
+
+| Code found  ( nfa -- cfa n )
+ SP X) lda N sta  SP )Y lda N 1+ sta
+  N X) lda N 2+ sta  $1F # and
+ sec N adc N sta
+  CS ?[ N 1+ inc ]?
+ N 2+ lda $20 # and
+ 0= ?[ N    lda  SP X) sta   N 1+ lda
+    ][ N X) lda  SP X) sta
+       N )Y lda   ]?  SP )Y sta
+  SP 2dec   N 2+ lda   0< ?[  iny  ]?
+ .A asl
+  0< not ?[ tya $FF # eor tay iny  ]?
+  tya SP X) sta
+  0< ?[ $FF # lda  24 c, ]?
+ txa  1 # ldy  SP )Y sta
+ Next jmp  end-code
+
+\\ | : found  ( nfa -- cfa n )
+      dup   c@ >r   (name>
+            r@ $20 and  IF @ THEN
+        -1  r@ $80 and  IF 1- THEN
+            r> $40 and  IF negate THEN ;
+
+
+\ *** Block No. 86, Hexblock 56
+
+( find  ' [']                 13jan85bp)
+
+: find ( string -- cfa n / string false)
+ context dup @ over 2- @ = IF 2- THEN
+ BEGIN  under @ (find
+                IF nip found exit THEN
+   over vp 2+ u>
+ WHILE  swap 2-
+ REPEAT nip false ;
+
+: '  ( -- cfa )
+ name find 0= Abort" What?"  ;
+
+: [compile]   ' , ;   immediate restrict
+
+: [']     ' [compile] Literal ;
+                      immediate restrict
+
+: nullstring?
+ ( string -- string false  / true)
+ dup c@ 0=  dup  IF nip THEN ;
+
+
+
+
+
+\ *** Block No. 87, Hexblock 57
+
+( >interpret                  28feb85bp)
+
+Label jump
+ iny clc W )Y lda 2 # adc IP    sta
+ iny     W )Y lda 0 # adc IP 1+ sta
+ 1 # ldy  Next jmp   end-code
+
+Variable >interpret
+
+jump  ' >interpret !
+
+\\ make Variable >interpret to special
+   Defer
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 88, Hexblock 58
+
+( interpret interactive   01oct87clv/re)
+
+Defer  notfound
+
+: no.extensions  ( string -- )
+ Error" Haeh?"   ;  \ string not 0
+
+' no.extensions  Is  notfound
+
+: interpret     >interpret ;
+
+| : interactive
+ ?stack  name find  ?dup
+ IF 1 and IF execute >interpret THEN
+   Abort" compile only"  THEN
+ nullstring? ?exit   'number?
+ 0= IF  notfound  THEN  >interpret ;
+
+
+' interactive  >interpret !
+
+
+
+
+
+
+\ *** Block No. 89, Hexblock 59
+
+( compiling [ ]           01oct87clv/re)
+
+| : compiling
+ ?stack  name find   ?dup
+ IF   0> IF  execute >interpret  THEN
+  , >interpret THEN
+ nullstring? ?exit  'number?   ?dup
+   IF 0> IF swap [compile] Literal THEN
+    [compile] Literal
+   ELSE  notfound THEN    >interpret ;
+
+
+: [    ['] interactive  Is >interpret
+ state off ;  immediate
+
+: ]    ['] compiling    Is >interpret
+ state on ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 90, Hexblock 5a
+
+\ perfom  Defer Is             02nov87re
+
+| : crash   true Abort" Crash" ;
+
+: Defer   Create  ['] crash ,
+ ;Code  2 # ldy
+  W )Y lda  pha iny W )Y lda
+  W 1+ sta  pla W sta  1 # ldy
+  W 1- jmp  end-code
+
+: (is  ( cfa -- )  r>  dup  2+ >r @ ! ;
+
+| : def?  ( cfa -- )
+    @ ['] notfound   @ over =
+ swap ['] >interpret @      =  or
+ not  Abort" not deferred" ;
+
+: Is      ( cfa -- )  ( -- )
+ ' dup  def?  >body
+ state  @  IF  compile (is , exit  THEN
+ !  ; immediate
+
+
+
+
+
+\ *** Block No. 91, Hexblock 5b
+
+( ?stack                  01oct87clv/re)
+
+| Create alarm  1 allot  0 alarm c!
+
+| : stackfull   ( -- )
+ depth $20 > abort" tight stack"
+ alarm c@ 0= IF  -1 alarm c!
+    true abort" dictionary full"  THEN
+ ." still full " ;
+
+Code ?stack
+ user' dp # ldy
+ sec SP    lda  UP )Y sbc
+ iny SP 1+ lda  UP )Y sbc
+ 0= ?[ 1 # ldy ;c: stackfull ;
+       Assembler ]?  alarm stx
+ user' s0 # ldy
+ UP )Y lda SP    cmp iny
+ UP )Y lda SP 1+ sbc
+ 1 # ldy  CS ?[  Next jmp ]?
+ ;c: true Abort" stack empty" ;
+
+\\ : ?stack
+ sp@  here - $100 u< IF stackfull THEN
+ sp@  s0 @ u> Abort" stack empty" ;
+
+\ *** Block No. 92, Hexblock 5c
+
+( .status push load           08sep84ks)
+
+Defer .status    ' noop Is .status
+
+| Create pull  0  ] r> r> ! ;
+
+: push ( addr -- )
+ r> swap dup >r @ >r  pull >r >r  ;
+ restrict
+
+: load   ( blk --)
+ ?dup 0= ?exit blk push  blk !
+ >in push  >in off
+ .status interpret ;
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 93, Hexblock 5d
+
+( +load thru +thru --> rdepth depth  ks)
+
+: +load  ( offset --)  blk @  + load ;
+
+: thru  ( from to --)
+ 1+  swap  DO  I load  LOOP ;
+
+: +thru  ( off0 off1 --)
+ 1+  swap  DO  I +load LOOP ;
+
+: -->
+ 1 blk +! >in off .status  ;  immediate
+
+: rdepth  ( -- +n)  r0 @  rp@ 2+ - 2/ ;
+
+: depth   ( -- +n)  sp@ s0 @ swap - 2/ ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 94, Hexblock 5e
+
+( quit (quit abort            07jun85bp)
+
+| : prompt
+ state @  IF ."  compiling"  exit  THEN
+ ."  ok" ;
+
+: (quit
+ BEGIN .status cr query interpret prompt
+ REPEAT ;
+
+Defer 'quit    ' (quit  Is 'quit
+
+: quit     r0 @ rp! [compile] [ 'quit ;
+
+
+: standardi/o
+ [ output ] Literal output 4 cmove ;
+
+Defer 'abort   ' noop Is 'abort
+
+: abort
+ clearstack  end-trace  'abort
+ standardi/o  quit   ;
+
+
+
+\ *** Block No. 95, Hexblock 5f
+
+\ (error Abort" Error"         02nov87re
+
+Variable scr 1 scr !  Variable r# 0 r# !
+
+: (error  ( string -- )
+ standardi/o space here .name count type
+ space ?cr  blk @  ?dup
+ IF  scr !  >in @  r# !  THEN quit ;
+
+' (error  errorhandler  !
+
+: (abort"  ( flag -- )   "lit swap
+ IF    >r clearstack r>
+       errorhandler perform  exit
+ THEN  drop ;  restrict
+
+| : (err"  ( flag -- )   "lit swap
+ IF    errorhandler perform  exit
+ THEN  drop ;  restrict
+
+: Abort"  ( flag -- )   compile (abort"
+ ," ; immediate  restrict
+
+: Error"  ( flag -- )   compile (err"
+ ," ; immediate  restrict
+
+\ *** Block No. 96, Hexblock 60
+
+( -trailing                   08apr85bp)
+
+020 Constant bl
+
+Code -trailing  ( addr n1 -- adr  n2 )
+ tya   Setup jsr
+ SP X) lda  N 2+ sta   clc
+ SP )Y lda  N 1+ adc  N 3 + sta
+ N ldy  clc   CS ?[
+Label (-trail
+ dey  N 2+ )Y lda  bl # cmp
+  0<> ?[ iny  0= ?[ N 1+ inc ]?
+         tya pha  N 1+ lda Push jmp ]?
+ ]?   tya   (-trail bne
+ N 3 + dec N 1 + dec  (-trail bpl
+ tya Push0A jmp   end-code
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 97, Hexblock 61
+
+( space spaces             29jan85ks/bp)
+
+: space            bl emit ;
+
+: spaces  ( u --)  0  ?DO space LOOP ;
+
+
+\\
+: -trailing  ( addr n1 -- addr n2)
+ 2dup  bounds
+    ?DO 2dup + 1- c@ bl -
+      IF LEAVE THEN  1- LOOP  ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 98, Hexblock 62
+
+( hold <# #> sign # #s        24dec83ks)
+
+| : hld  ( -- addr)    pad 2- ;
+
+: hold  ( char -- )
+ -1 hld +! hld @ c! ;
+
+: <#                   hld hld ! ;
+
+: #>    ( 32b -- addr +n )
+ 2drop hld @  hld over - ;
+
+: sign  ( n -- )
+ 0< IF Ascii  - hold THEN ;
+
+: #     ( +d1 -- +d2)
+ base @ ud/mod rot 09 over <
+  IF  [ Ascii A  Ascii 9  - 1- ]
+      Literal  +
+  THEN  Ascii 0  +  hold ;
+
+: #s    ( +d -- 0 0 )
+ BEGIN # 2dup  d0= UNTIL ;
+
+
+
+\ *** Block No. 99, Hexblock 63
+
+( print numbers               24dec83ks)
+
+: d.r  -rot under dabs <# #s rot sign #>
+        rot over max over - spaces type
+ ;
+
+: .r    swap extend rot d.r ;
+
+: u.r   0 swap d.r ;
+
+: d.    0 d.r space ;
+
+: .     extend d. ;
+
+: u.    0 d. ;
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 100, Hexblock 64
+
+\ .s list c/l l/s             clv4:jul87
+
+: .s   sp@  s0 @  over - 020 umin
+ bounds ?DO I @ u.  2 +LOOP ;
+
+40 (C drop 29 ) Constant c/l
+   \ Screen line length
+10 (C drop 19 ) Constant l/s
+   \ lines per screen
+
+: list   ( blk --)
+ scr ! ." Scr " scr @ dup blk/drv mod u.
+       ." Dr "  drv? .
+ l/s 0 DO stop? IF leave THEN
+   cr I 2 .r space scr @  block
+      I c/l * + c/l  (C 1- )
+   -trailing type  LOOP cr ;
+
+
+
+
+
+
+
+
+
+\ *** Block No. 101, Hexblock 65
+
+( multitasker primitives      bp03nov85)
+
+Code pause   Next here 2- !  end-code
+
+: lock  ( addr --)
+ dup @  up@ =  IF  drop exit  THEN
+ BEGIN  dup @  WHILE  pause  REPEAT
+ up@ swap ! ;
+
+: unlock  ( addr --)   dup lock off ;
+
+Label wake    wake >wake !
+ pla  sec  5 # sbc  UP    sta
+ pla       0 # sbc  UP 1+ sta
+ 04C # lda  UP X) sta
+ 6 # ldy  UP )Y lda SP    sta
+     iny  UP )Y lda SP 1+ sta 1 # ldy
+ SP X) lda  RP sta
+ SP )Y lda  RP 1+ sta   SP 2inc
+ IP  # ldx  Xpull jmp
+end-code
+
+
+
+
+
+\ *** Block No. 102, Hexblock 66
+
+( buffer mechanism            15dec83ks)
+
+User file           0 file !
+        \ adr of file control block
+Variable prev       0 prev !
+        \ Listhead
+Variable buffers  0 buffers !
+        \ Semaphore
+0408 Constant b/buf
+        \ Physical Size
+
+\\ Structure of Buffer:
+ 0 : link
+ 2 : file
+ 4 : blocknr
+ 6 : statusflags
+ 8 : Data .. 1 KB ..
+
+Statusflag bits: 15   1 -> updated
+
+file = -1 empty buffer
+     = 0 no fcb , direct access
+     = else  adr of fcb
+     ( system   dependent )
+
+
+\ *** Block No. 103, Hexblock 67
+
+( search for blocks in memory 11jun85bp)
+
+Label thisbuffer?        2 # ldy
+   [[  N 4 + )Y lda N 2- ,Y cmp
+ 0= ?[[  iny  6 # cpy 0= ?] ]? rts
+              \ zero if this buffer )
+
+| Code (core?
+ ( blk file -- addr / blk  file )
+ \ N-Area : 0 blk 2 file 4 buffer
+ \          6 predecessor
+ 3 # ldy
+   [[ SP )Y lda  N ,Y sta  dey  0< ?]
+ user' offset # ldy
+ clc  UP )Y lda  N 2+  adc  N 2+  sta
+ iny  UP )Y lda  N 3 + adc  N 3 + sta
+ prev    lda  N 4 + sta
+ prev 1+ lda  N 5 + sta
+ thisbuffer? jsr    0= ?[
+
+
+
+
+
+
+
+\ *** Block No. 104, Hexblock 68
+
+(   "                         11jun85bp)
+
+Label blockfound     SP 2inc
+ 1 # ldy
+ 8 #   lda  clc N 4 + adc SP X) sta
+ N 5 + lda        0 # adc SP )Y sta
+ ' exit @ jmp  ]?
+ [[ N 4 + lda  N 6 + sta
+    N 5 + lda  N 7 + sta
+    N 6 + X) lda  N 4 + sta  1 # ldy
+    N 6 + )Y lda  N 5 + sta  N 4 + ora
+     0= ?[ ( list empty )  Next jmp ]?
+   thisbuffer? jsr 0= ?] \ found, relink
+ N 4 + X) lda  N 6 + X) sta  1 # ldy
+ N 4 + )Y lda  N 6 + )Y sta
+ prev    lda  N 4 + X) sta
+ prev 1+ lda  N 4 + )Y sta
+ N 4 + lda  prev    sta
+ N 5 + lda  prev 1+ sta
+ blockfound jmp    end-code
+
+
+
+
+
+
+\ *** Block No. 105, Hexblock 69
+
+\ (core?                       23sep85bp
+
+\\
+
+| : this?   ( blk file bufadr -- flag )
+   dup 4+ @  swap 2+ @  d= ;
+
+| : (core?
+   ( blk file -- dataaddr / blk file )
+  BEGIN  over offset @ + over  prev @
+    this? IF rdrop 2drop prev @ 8 + exit
+          THEN
+    2dup >r offset @ + >r prev @
+    BEGIN  dup @ ?dup
+       0= IF rdrop rdrop drop exit THEN
+      dup r> r> 2dup >r >r  rot this? 0=
+    WHILE  nip  REPEAT
+    dup @ rot !  prev @ over !  prev !
+    rdrop rdrop
+  REPEAT ;
+
+
+
+
+
+
+\ *** Block No. 106, Hexblock 6a
+
+( (diskerr                    11jun85bp)
+
+: (diskerr   ." error !  r to retry "
+ key dup Ascii r =  swap Ascii R =
+ or not  Abort" aborted"  ;
+
+
+Defer diskerr  ' (diskerr  Is diskerr
+
+Defer r/w
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 107, Hexblock 6b
+
+( backup emptybuf readblk     11jun85bp)
+
+| : backup   ( bufaddr --)
+ dup 6+ @  0<
+ IF  2+  dup @ 1+
+            \ buffer empty if file = -1
+  IF input push output push standardi/o
+   BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
+   WHILE ." write " diskerr
+   REPEAT   THEN
+  080 over 4+ 1+ ctoggle  THEN
+ drop ;
+
+| : emptybuf  ( bufaddr --)
+   2+ dup on 4+ off ;
+
+| : readblk
+   ( blk file addr -- blk file addr)
+ dup emptybuf  input push  output push
+ standardi/o   >r
+ BEGIN over offset @ + over
+       r@ 8 +  -rot   1  r/w
+ WHILE ." read " diskerr
+ REPEAT  r>  ;
+
+
+\ *** Block No. 108, Hexblock 6c
+
+( take mark updates? full? core?     bp)
+
+| : take   ( -- bufaddr)    prev
+ BEGIN  dup @  WHILE  @  dup 2+ @ -1 =
+ UNTIL
+ buffers lock   dup backup ;
+
+| : mark
+ ( blk file bufaddr -- blk file )
+ 2+ >r 2dup r@ !  offset @ +  r@ 2+ !
+ r> 4+ off  buffers unlock ;
+
+| : updates?  ( -- bufaddr / flag)
+ prev  BEGIN  @ dup  WHILE  dup 6+ @
+   0<  UNTIL ;
+
+| : full?   ( -- flag)
+ prev BEGIN @ dup @ 0= UNTIL  6+ @ 0< ;
+
+: core?  ( blk file -- addr /false)
+ (core? 2drop false ;
+
+
+
+
+
+\ *** Block No. 109, Hexblock 6d
+
+( block & buffer manipulation 11jun85bp)
+
+: (buffer ( blk file -- addr)
+ BEGIN  (core? take mark
+ REPEAT ;
+
+: (block  ( blk file -- addr)
+ BEGIN  (core? take readblk mark
+ REPEAT ;
+
+| Code file@  ( -- n )
+ user' file # ldy
+ UP )Y lda  pha  iny  UP )Y lda
+ Push jmp  end-code
+
+: buffer  ( blk -- addr )
+ file@  (buffer ;
+
+: block   ( blk -- addr )
+ file@  (block ;
+
+
+
+
+
+
+\ *** Block No. 110, Hexblock 6e
+
+( block & buffer manipulation 09sep84ks)
+
+: update   080 prev @  6+ 1+ c! ;
+
+: save-buffers
+ buffers lock BEGIN   updates? ?dup
+              WHILE backup REPEAT
+ buffers unlock  ;
+
+: empty-buffers
+ buffers lock  prev
+ BEGIN @ ?dup
+ WHILE dup emptybuf
+ REPEAT  buffers unlock ;
+
+: flush    save-buffers empty-buffers ;
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 111, Hexblock 6f
+
+( moving blocks               15dec83ks)
+
+ : (copy   ( from to --)
+ dup file@
+ core? IF prev @ emptybuf THEN
+ full? IF  save-buffers   THEN
+ offset @ + swap block 2- 2- !  update ;
+
+ : blkmove  ( from to quan --)
+ save-buffers >r
+ over r@ + over u> >r  2dup u< r> and
+  IF  r@ r@ d+  r> 0 ?DO -1 -2 d+
+                         2dup (copy LOOP
+  ELSE          r> 0 ?DO 2dup (copy 1
+                             1 d+   LOOP
+  THEN  save-buffers 2drop ;
+
+: copy    ( from to --)   1 blkmove ;
+
+: convey  ( [blk1 blk2] [to.blk --)
+ swap  1+  2 pick -   dup 0> not
+ Abort" no!!"  blkmove ;
+
+
+
+
+\ *** Block No. 112, Hexblock 70
+
+\ Allocating buffers          clv12jul87
+
+E400 Constant limit     Variable first
+
+: allotbuffer   ( -- )
+ first @  r0 @ -  b/buf 2+ u< ?exit
+ b/buf negate first +!
+ first @ dup emptybuf
+ prev  @ over !  prev !   ;
+
+: freebuffer    ( -- )
+ first @   limit b/buf - u<
+  IF first @ backup prev
+    BEGIN  dup @ first @  -
+    WHILE  @  REPEAT
+  first @  @ swap ! b/buf first +!
+  THEN ;
+
+: all-buffers
+ BEGIN  first @ allotbuffer
+        first @  = UNTIL ;
+
+
+
+
+
+\ *** Block No. 113, Hexblock 71
+
+( endpoints of forget      04jan85bp/ks)
+
+| : |? ( nfa -- flag )   c@  020  and ;
+
+| : forget?  ( adr nfa -- flag )
+     \ code in heap or above adr ?
+ name> under 1+ u< swap  heap?  or ;
+
+|  : endpoints  ( addr -- addr symb)
+ heap   voc-link @ >r
+ BEGIN r> @ ?dup    \ through all Vocabs
+ WHILE dup >r 4 - >r \ link on returnst.
+  BEGIN r> @ >r over 1- dup r@  u<
+                    \ until link  or
+             swap  r@ 2+ name> u< and
+                    \ code under adr
+  WHILE  r@ heap?  [ 2dup ] UNTIL
+             \ search for a name in heap
+    r@ 2+ |?  IF  over r@ 2+ forget?
+               IF r@ 2+ (name> 2+ umax
+               THEN \ then update symb
+              THEN
+  REPEAT rdrop
+ REPEAT  ;
+
+
+\ *** Block No. 114, Hexblock 72
+
+\ remove                       23jul85we
+
+| Code remove ( dic symb thr - dic symb)
+ 5 # ldy [[ SP )Y lda N ,Y sta dey 0< ?]
+ user' s0 # ldy
+ clc UP )Y lda 6 # adc N 6 + sta
+ iny UP )Y lda 0 # adc N 7 + sta
+ 1 # ldy
+ [[ N X) lda N 8 + sta
+    N )Y lda N 9 + sta N 8 + ora  0<>
+ ?[[ N 8 + lda N 6 + cmp
+     N 9 + lda N 7 + sbc CS
+   ?[ N 8 + lda N 2 + cmp
+      N 9 + lda N 3 + sbc
+   ][ N 4 + lda N 8 + cmp
+      N 5 + lda N 9 + sbc
+   ]? CC
+   ?[ N 8 + X) lda N X) sta
+      N 8 + )Y lda N )Y sta
+   ][ N 8 + lda    N    sta
+      N 9 + lda N 1+ sta ]?
+ ]]? (drop jmp   end-code
+
+
+
+
+\ *** Block No. 115, Hexblock 73
+
+( remove-     forget-words    29apr85bp)
+
+| : remove-words ( dic symb -- dic symb)
+ voc-link  BEGIN  @ ?dup
+  WHILE  dup >r 4 - remove r>  REPEAT  ;
+
+| : remove-tasks  ( dic --)
+ up@  BEGIN  1+ dup @ up@ -
+ WHILE  2dup @ swap here uwithin
+  IF dup @ 1+ @ over ! 1-  ELSE  @ THEN
+ REPEAT  2drop ;
+
+| : remove-vocs  ( dic symb -- dic symb)
+ voc-link remove thru.vocstack
+  DO  2dup I @  -rot  uwithin
+    IF   [ ' Forth 2+ ] Literal I ! THEN
+  -2 +LOOP
+ 2dup   current @  -rot   uwithin
+  IF [ ' Forth 2+ ] Literal current !
+  THEN ;
+
+Defer custom-remove
+' noop Is custom-remove
+
+
+
+\ *** Block No. 116, Hexblock 74
+
+( deleting words from dict.   13jan83ks)
+
+| : forget-words    ( dic symb --)
+ over remove-tasks remove-vocs
+      remove-words custom-remove
+ heap swap - hallot dp !  0 last ! ;
+
+: clear
+ here  dup up@ forget-words   dp ! ;
+
+: (forget ( adr --)
+ dup  heap? Abort" is symbol"
+ endpoints forget-words ;
+
+: forget  ' dup [ dp ] Literal @
+ u<  Abort" protected"
+ >name dup heap?
+ IF  name>  ELSE  2- 2-  THEN
+ (forget   ;
+
+: empty  [ dp ] Literal @
+ up@ forget-words
+ [ udp ] Literal @  udp ! ;
+
+
+
+\ *** Block No. 117, Hexblock 75
+
+\ save bye stop? ?cr         clv2:jull87
+
+: save
+ here up@ forget-words
+ voc-link @  BEGIN  dup 2- 2-  @  over
+               2- !  @ ?dup 0=  UNTIL
+ up@ origin $100 cmove   ;
+
+: bye save-buffers (bye ;
+\ : bye       flush empty (bye ;
+
+| : end?    key ( #cr ) (C 3 ) =
+            IF true rdrop THEN ;
+
+: stop?   ( -- flag)
+ key? IF end? end? THEN false ;
+
+: ?cr   col  c/l $A -  u> IF cr THEN ;
+
+
+
+
+
+
+
+
+\ *** Block No. 118, Hexblock 76
+
+( in/output structure         02mar85bp)
+
+| : Out:  Create dup c,  2+
+          Does> c@ output @ +  perform ;
+
+  : Output:  Create:
+             Does>  output ! ;
+
+0  Out: emit   Out: cr     Out: type
+   Out: del    Out: page   Out: at
+   Out: at?
+drop
+
+: row   ( -- row)  at? drop ;
+: col   ( -- col)  at? nip ;
+
+| : In:    Create dup c, 2+
+           Does> c@ input @ + perform ;
+
+  : Input:  Create:
+            Does> input ! ;
+
+0  In: key   In: key?   In: decode
+   In: expect
+drop
+
+\ *** Block No. 119, Hexblock 77
+
+( Alias  only definitionen    29jan85bp)
+
+Only definitions Forth
+
+: seal  0 ['] Only  >body  ! ;
+        \ kill all words in Only)
+
+      ' Only  Alias Only
+      ' Forth Alias Forth
+      ' words Alias words
+      ' also  Alias also
+' definitions Alias definitions
+
+Host Target
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 120, Hexblock 78
+
+\ 'cold                   01oct87clv/re)
+
+| : init-vocabularys   voc-link @
+ BEGIN  dup  2- @  over 4 - !
+        @ ?dup 0= UNTIL ;
+
+| : init-buffers
+ 0 prev !  limit first !  all-buffers ;
+
+Defer 'cold    ' noop Is 'cold
+
+| : (cold
+ init-vocabularys  init-buffers
+ Onlyforth 'cold
+ page logo count type cr
+ (restart ;
+
+Defer 'restart  ' noop Is 'restart
+
+| : (restart
+ ['] (quit Is 'quit
+ drvinit 'restart  [ errorhandler ]
+ Literal @ errorhandler !
+ [']  noop Is 'abort abort ;
+
+
+\ *** Block No. 121, Hexblock 79
+
+\ forth-init              01oct87clv/re)
+
+Label forth-init
+ Bootnextlen 1- # ldy
+ [[ Bootnext ,Y lda PutA ,Y sta
+    dey 0< ?]
+ clc s0 lda 6 # adc UP sta
+  s0 1+ lda 0 # adc UP 1+ sta
+ user' s0 # ldy  UP )Y lda SP sta
+            iny  UP )Y lda SP 1+ sta
+ user' r0 # ldy  UP )Y lda RP sta
+            iny  UP )Y lda RP 1+ sta
+ 0 # ldx 1 # ldy txa RP X) sta RP )Y sta
+Label donothing rts
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 122, Hexblock 7a
+
+\ cold restart                 06nov87re
+
+Code cold        here >cold !
+ $FF # ldx  txs
+Label bootsystem
+ donothing jsr \ patch for first-init
+ clc s0 lda 6 # adc N sta
+  s0 1+ lda 0 # adc N 1+ sta  0 # ldy
+ [[ origin ,Y lda N )Y sta iny 0= ?]
+ forth-init jsr
+ ;c: init-system  (cold ;
+
+Code restart     here >restart !
+ $FF # ldx  txs
+Label warmboot
+ donothing jsr \ patch for first-init
+ forth-init jsr
+ ;c: init-system  (restart ;
+
+Label xyNext
+ 0 # ldx 1 # ldy Next jmp end-code
+
+
+
+
+
+\ *** Block No. 123, Hexblock 7b
+
+\ System-Loadscreen       01oct87clv/re)
+
+ 3 $18 +thru          \ CBM-Interface
+(c16+    19 +load )   \ c16init RamIRQ
+
+
+Host  ' Transient 8 + @
+  Transient  Forth  Context @ 6 + !
+Target
+
+Forth also definitions
+
+(C16 : (64 ) \ jumps belhind C)
+(C64 : (16 )
+ BEGIN name count 0= abort" C) missing"
+ @ [ Ascii C Ascii ) $100 * + ] Literal
+ = UNTIL ; immediate
+
+: C)  ; immediate
+
+(C16 : (16 ) (C64 : (64 ) ; immediate
+
+: forth-83 ;  \ last word in Dictionary
+
+
+
+\ *** Block No. 124, Hexblock 7c
+
+( System dependent Constants      bp/ks)
+
+Vocabulary Assembler
+Assembler definitions
+Transient  Assembler
+
+PushA  Constant PushA
+       \ put A sign-extended on stack
+Push0A Constant Push0A
+       \ put A on stack
+Push   Constant Push
+       \ MSB in A and LSB on jsr-stack
+
+RP     Constant RP
+UP     Constant UP
+SP     Constant SP
+IP     Constant IP
+N      Constant N
+Puta   Constant Puta
+W      Constant W
+Setup  Constant Setup
+Next   Constant Next
+xyNext Constant xyNext
+(2drop Constant Poptwo
+(drop  Constant Pop
+
+\ *** Block No. 125, Hexblock 7d
+
+\ System patchup              clv06aug87
+
+Forth definitions
+
+(C64  C000 ' limit >body !
+      7B00 s0 !  7F00 r0 ! )
+
+(C16  8000 ' limit >body !
+      7700 s0 !  7b00 r0 ! )
+
+\ (C16+ fd00 ' limit >body !
+\       7B00 s0 !  7F00 r0 ! )
+
+s0 @ dup s0 2- !      6 + s0 7 - !
+here dp !
+
+Host  Tudp @          Target  udp !
+Host  Tvoc-link @     Target  voc-link !
+Host  move-threads
+
+
+
+
+
+
+
+\ *** Block No. 126, Hexblock 7e
+
+\ CBM-Labels                   05nov87re
+
+$FFA5 >label ACPTR
+$FFC6 >label CHKIN
+$FFC9 >label CHKOUT
+$FFD2 >label CHROUT
+$FF81 >label CINT
+$FFA8 >label CIOUT
+$FFC3 >label CLOSE
+$FFCC >label CLRCHN
+$FFE4 >label GETIN
+$FF84 >label IOINIT
+$FFB1 >label LISTEN
+$FFC0 >label OPEN
+$FFF0 >label PLOT
+$FF8A >label RESTOR
+$FF93 >label SECOND
+$FFE1 >label STOP
+$FFB4 >label TALK
+$FF96 >label TKSA
+$FFEA >label UDTIM
+$FFAE >label UNLSN
+$FFAB >label UNTLK
+$FFCF >label CHRIN
+$FF99 >label MEMTOP
+
+\ *** Block No. 127, Hexblock 7f
+
+\ C64-Labels                 clv13.4.87)
+
+(C64
+
+0E716 >label ConOut
+  09d >label MsgFlg
+  09a >label OutDev
+  099 >label  InDev
+0d020 >label BrdCol
+0d021 >label BkgCol
+ 0286 >label PenCol
+  0ae >label PrgEnd
+  0c1 >label IOBeg
+  0d4 >label CurFlg
+  0d8 >label InsCnt
+ 028a >label KeyRep
+
+
+
+
+
+)
+
+
+
+
+\ *** Block No. 128, Hexblock 80
+
+\ C16-Labels                 clv13.4.87)
+
+(C16
+
+0ff4c >label ConOut
+  09a >label MsgFlg
+  099 >label OutDev
+  098 >label  InDev
+0ff19 >label BrdCol
+0ff15 >label BkgCol
+ 0540 >label PenCol
+  09d >label PrgEnd
+  0b2 >label IOBeg
+  0cb >label CurFlg
+  0cf >label InsCnt
+ 0540 >label KeyRep
+
+
+
+
+ 055d >label PKeys
+)
+
+
+
+
+\ *** Block No. 129, Hexblock 81
+
+\ c64key? getkey              clv12jul87
+
+Code c64key? ( -- flag)
+(C64  0C6 lda            ( )
+(c16  0ef lda  055d ora  ( )
+ 0<> ?[  0FF # lda  ]? pha
+ Push jmp  end-code
+
+Code getkey  ( -- 8b)
+(C64 0C6 lda  0<>
+ ?[  sei  0277 ldy
+  [[  0277 1+ ,X lda  0277 ,X sta  inx
+      0C6 cpx  0= ?]
+  0C6 dec  tya  cli  0A0 # cmp
+  0= ?[  bl # lda  ]?
+ ]? ( )
+(C16 0ebdd jsr
+  0A0 # cmp 0= ?[  bl # lda  ]? ( )
+ Push0A jmp   end-code
+
+
+
+
+
+
+
+\ *** Block No. 130, Hexblock 82
+
+( curon curoff               clv12.4.87)
+
+(C16  Code curon \ --
+0ca lda clc 0c8 adc 0ff0d sta
+0c9 lda     0 # adc 0b # sbc 0ff0c sta
+next jmp end-code
+
+Code curoff \ --
+0ff # lda ff0c sta 0ff0d sta Next jmp
+end-code )
+
+(C16 \\ )
+
+Code curon   ( --)
+ 0D3 ldy  0D1 )Y lda  0CE sta  0CC stx
+ xyNext jmp   end-code
+
+Code curoff   ( --)
+ iny  0CC sty  0CD sty  0CF stx
+ 0CE lda  0D3 ldy  0D1 )Y sta
+ 1 # ldy  Next jmp   end-code
+
+
+
+
+
+\ *** Block No. 131, Hexblock 83
+
+( #bs #cr ..keyboard         clv12.4.87)
+
+
+: c64key  ( -- 8b)
+ curon BEGIN pause c64key?  UNTIL
+ curoff getkey ;
+
+14 Constant #bs   0D Constant #cr
+
+: c64decode
+ ( addr cnt1 key -- addr cnt2)
+  #bs case?  IF  dup  IF del 1- THEN
+                            exit  THEN
+  #cr case?  IF  dup span ! exit THEN
+  >r  2dup +  r@ swap c!  r> emit  1+ ;
+
+: c64expect ( addr len1 -- )
+ span !  0
+ BEGIN  dup span @  u<
+ WHILE  key  decode
+ REPEAT 2drop space ;
+
+Input: keyboard   [ here input ! ]
+ c64key c64key? c64decode c64expect ;
+
+
+\ *** Block No. 132, Hexblock 84
+
+( con! printable?            clv11.4.87)
+
+Code con!  ( 8b --)   SP X) lda
+Label (con!     ConOut jsr    SP 2inc
+Label (con!end  CurFlg stx InsCnt stx
+ 1 # ldy ;c:  pause ;
+
+Label (printable?   \ for CBM-Code !
+                    \ CS is printable
+  80 # cmp  CC ?[   bl # cmp  rts  ]?
+ 0E0 # cmp  CC ?[  0C0 # cmp  rts  ]?
+ clc  rts  end-code
+
+Code printable? ( 8b -- 8b flag)
+ SP X) lda  (printable? jsr CS ?[ dex ]?
+ txa  PushA jmp     end-code
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 133, Hexblock 85
+
+( emit cr del page at at?    clv11.4.87)
+
+Code c64emit  ( 8b -- )
+ SP X) lda  (printable? jsr
+    CC ?[  Ascii . # lda ]?
+ (con! jmp   end-code
+
+: c64cr     #cr con! ;
+
+: c64del    9D con!  space  9D con! ;
+
+: c64page   93 con! ;
+
+Code c64at  ( row col --)
+ 2 # lda  Setup jsr
+ N 2+ ldx  N ldy  clc  PLOT jsr
+(C16 \ ) 0D3 ldy  0D1 )Y lda   0CE sta
+ xyNext jmp  end-code
+
+Code c64at?  ( -- row col)
+ SP 2dec txa  SP )Y sta
+ sec  PLOT jsr
+ 28 # cpy  tya  CS ?[ 28 # sbc ]?
+ pha  txa  0 # ldx  SP X) sta  pla
+ Push0A jmp  end-code
+
+\ *** Block No. 134, Hexblock 86
+
+( type display (bye          clv11.4.87)
+
+Code  c64type  ( adr len -- )
+ 2 # lda  Setup jsr  0 # ldy
+  [[  N cpy  0<>
+  ?[[  N 2+ )Y lda  (printable? jsr
+         CC ?[  Ascii . # lda  ]?
+ ConOut jsr  iny  ]]?
+ (con!end jmp   end-code
+
+Output: display   [ here output ! ]
+ c64emit c64cr c64type c64del c64page
+ c64at c64at? ;
+
+(C64  | Create (bye  $FCE2  here 2- ! )
+
+(C16- | Create (bye  $FF52  here 2- ! )
+
+(C16+ | CODE   (bye  rom $FF52 jmp
+                             end-code )
+
+
+
+
+
+
+\ *** Block No. 135, Hexblock 87
+
+\ b/blk drive >drive drvinit  clv14:2x87
+
+400 Constant b/blk
+
+0AA Constant blk/drv
+
+Variable (drv    0 (drv !
+
+| : disk ( -- dev.no )   (drv @ 8 + ;
+
+: drive  ( drv# -- )
+ blk/drv *  offset ! ;
+
+: >drive ( block drv# -- block' )
+ blk/drv * +   offset @ - ;
+
+: drv?    ( block -- drv# )
+ offset @ + blk/drv / ;
+
+: drvinit  noop ;
+
+
+
+
+
+
+\ *** Block No. 136, Hexblock 88
+
+( i/o busoff                  10may85we)
+
+Variable i/o  0 i/o !  \ Semaphore
+
+Code busoff  ( --)   CLRCHN jsr
+Label unlocki/o  1 # ldy  0 # ldx
+ ;c:  i/o unlock ;
+
+Label nodevice     0 # ldx  1 # ldy
+ ;c:  busoff   buffers unlock
+      true Abort" no device" ;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 137, Hexblock 89
+
+\ ?device                     clv12jul87
+
+Label (?dev
+ 90 stx (C16 $ae sta ( ) LISTEN jsr
+        \ because of error in OS
+ 60 # lda  SECOND jsr  UNLSN jsr
+ 90 lda  0<> ?[ pla pla nodevice jmp ]?
+ rts    end-code
+
+ Code (?device  ( dev --)
+ SP X) lda  (?dev jsr  SP 2inc
+ unlocki/o jmp  end-code
+
+: ?device  ( dev -- )
+ i/o lock  (?device ;
+
+ Code (busout  ( dev 2nd -- )
+ MsgFlg stx  2 # lda  Setup jsr
+ N 2+ lda  (?dev jsr
+ N 2+ lda  LISTEN jsr
+ N lda  60 # ora SECOND jsr
+ N 2+ ldx  OutDev stx
+ xyNext jmp  end-code
+
+
+
+\ *** Block No. 138, Hexblock 8a
+
+\ busout/open/close/in        clv12jul87
+
+: busout    ( dev 2nd -- )
+ i/o lock (busout ;
+
+: busopen   ( dev 2nd -- )
+ 0F0 or busout ;
+
+: busclose  ( dev 2nd -- )
+ 0E0 or busout busoff ;
+
+ Code (busin  ( dev 2nd -- )
+ MsgFlg stx  2 # lda  Setup jsr
+ N 2+ lda  (?dev jsr
+ N 2+ lda  TALK jsr
+ N lda  60 # ora (C16 $ad sta ( )
+ TKSA jsr
+\ because of error in old C16 OS
+ N 2+ ldx  InDev stx
+ xyNext jmp end-code
+
+: busin  ( dev 2nd -- )
+ i/o lock  (busin ;
+
+
+
+\ *** Block No. 139, Hexblock 8b
+
+( bus-!/type/@/input derror?  24feb85re)
+
+Code bus!  ( 8b --)
+ SP X) lda  CIOUT jsr  (xydrop jmp
+ end-code
+
+: bustype  ( adr n --)
+ bounds  ?DO  I c@ bus!  LOOP pause ;
+
+Code bus@  ( -- 8b)
+ ACPTR jsr Push0A jmp  end-code
+
+: businput  ( adr n --)
+ bounds  ?DO  bus@ I c! LOOP pause ;
+
+: derror?  ( -- flag )
+ disk $F busin bus@  dup Ascii 0 -
+  IF  BEGIN emit bus@ dup #cr =  UNTIL
+  0= cr  THEN   0=  busoff ;
+
+
+
+
+
+
+
+\ *** Block No. 140, Hexblock 8c
+
+( s#>s+t  x,x                 28may85re)
+
+165 | Constant 1.t
+1EA | Constant 2.t
+256 | Constant 3.t
+
+| : (s#>s+t ( sector# -- sect track)
+      dup 1.t u< IF 15 /mod exit THEN
+ 3 +  dup 2.t u< IF 1.t - 13 /mod 11 +
+                            exit THEN
+      dup 3.t u< IF 2.t - 12 /mod 18 +
+                            exit THEN
+ 3.t - 11 /mod 1E + ;
+
+| : s#>t+s  ( sector# -- track sect )
+ (s#>s+t  1+ swap ;
+
+| : x,x ( sect track -- adr count)
+ base push  decimal
+ 0 <# #s drop Ascii , hold #s #> ;
+
+
+
+
+
+
+\ *** Block No. 141, Hexblock 8d
+
+( readsector writesector      28may85re)
+
+100 | Constant b/sek
+
+: readsector  ( adr tra# sect# -- flag)
+ disk 0F busout
+ " u1:13,0," count   bustype
+ x,x bustype busoff pause
+ derror? ?exit
+ disk 0D busin b/sek businput busoff
+ false ;
+
+: writesector  ( adr tra# sect# -- flag)
+ rot disk 0F busout
+ " b-p:13,0" count bustype busoff
+ disk 0D busout b/sek bustype busoff
+ disk 0F busout
+ " u2:13,0," count  bustype
+ x,x bustype busoff pause  derror? ;
+
+
+
+
+
+
+
+\ *** Block No. 142, Hexblock 8e
+
+( 1541r/w                     28may85re)
+
+: diskopen  ( -- flag)
+ disk 0D busopen  Ascii # bus! busoff
+ derror? ;
+
+: diskclose ( -- )
+ disk 0D busclose  busoff ;
+
+: 1541r/w  ( adr blk file r/wf -- flag)
+ swap Abort" no file"
+ -rot  blk/drv /mod  dup (drv ! 3 u>
+ IF . ." beyond capacity" nip exit  THEN
+ diskopen  IF  drop nip exit  THEN
+ 0 swap   2* 2* 4 bounds
+ DO  drop  2dup I rot
+     IF    s#>t+s readsector
+     ELSE  s#>t+s writesector THEN
+     >r b/sek + r> dup  IF  LEAVE  THEN
+ LOOP   -rot  2drop  diskclose  ;
+
+' 1541r/w  Is   r/w
+
+
+
+
+\ *** Block No. 143, Hexblock 8f
+
+\ index findex ink-pot         05nov87re
+
+: index ( from to --)
+ 1+ swap DO
+   cr  I 2 .r  I block 1+  25  type
+   stop?  IF LEAVE THEN  LOOP ;
+
+: findex ( from to --)
+ diskopen  IF  2drop  exit  THEN
+ 1+ swap DO  cr  I 2 .r
+   pad dup I 2* 2* s#>t+s readsector
+   >r 1+ 25 type
+   r> stop? or IF LEAVE THEN
+ LOOP  diskclose  ;
+
+Create ink-pot
+    \ border bkgnd pen  0
+(C64  6 c,   6 c,  3 c, 0 c,   \ Forth
+     0E c,   6 c,  3 c, 0 c,   \ Edi
+      6 c,   6 c,  3 c, 0 c, ) \ User
+(C16 f6 c, 0f6 c, 03 c, 0 c,   \ Forth
+    0eE c, 0f6 c, 03 c, 0 c,   \ Edi
+    0f6 c, 0f6 c, 03 c, 0 c, ) \ User
+
+
+
+\ *** Block No. 144, Hexblock 90
+
+\ restore                      05nov87re
+
+(C16 \\ )
+
+Label asave 0 c,    Label 1save 0 c,
+
+Label continue
+ pha  1save lda  1 sta  pla  rti
+
+Label restore   sei  asave sta
+ continue $100 /mod
+ # lda pha  # lda pha  php  \ for RTI
+ asave lda pha  txa pha  tya pha
+ 1 lda 1save sta
+ $36 # lda   1 sta  \ Basic off ROM on
+ $7F # lda  $DD0D sta
+ $DD0D ldy  0< ?[
+Label 6526-NMI $FE72 jmp  ]?
+ UDTIM jsr STOP jsr  \ RUN/STOP ?
+ 6526-NMI bne        \ not >>-->
+ ' restart @ jmp  end-code
+
+
+
+
+
+\ *** Block No. 145, Hexblock 91
+
+\ C64:Init                     06nov87re
+(C16 \\ )
+
+: init-system   $FF40 dup $C0 cmove
+ [ restore ] Literal  dup
+ $FFFA ! $318 ! ;  \ NMI-Vector to RAM
+
+Label first-init
+ sei cld
+ IOINIT jsr  CINT jsr  RESTOR jsr
+  \ init. and set I/O-Vectors
+ $36 # lda   01 sta        \ Basic off
+ ink-pot    lda BrdCol sta \ border
+ ink-pot 1+ lda BkgCol sta \ backgrnd
+ ink-pot 2+ lda PenCol sta \ pen
+$80 # lda KeyRep sta  \ repeat all keys
+$17 # lda  $D018 sta  \ low/upp +
+  0 # lda  $D01A sta  \ VIC-IRQ off
+$1B # lda  $D011 sta  \ Textmode on
+  4 # lda   $288 sta  \ low screen
+ cli rts end-code
+first-init dup bootsystem 1+ !
+               warmboot   1+ !
+Code c64init first-init jsr
+ xyNext jmp end-code
+
+\ *** Block No. 146, Hexblock 92
+
+\ C16:Init                01oct87clv/re)
+
+(C64 \\ )
+
+Code init-system $F7 # ldx  txs
+ xyNext jmp end-code
+
+$fcb3 >label IRQ   \ normal IRQ
+$fffe >label >IRQ  \ 6502-Ptr to IRQ
+
+\ selfmodifying code:
+Label RAMIRQ       \ the new IRQ
+   rom RAMIRQ $15 + sta RAMIRQ $17 + stx
+(  +9) RAMIRQ $1b + $100 u/mod # lda pha
+                               # lda pha
+(  +f) tsx $103 ,x lda pha   \ flags
+( +14) 0 # lda 0 # ldx IRQ jmp
+( +1b) ram rti end-code
+
+
+
+
+
+
+
+
+\ *** Block No. 147, Hexblock 93
+
+\ C16:..Init              01oct87clv/re)
+
+(C64 \\ )
+
+Label first-init
+   \ will be called in ROM first time
+   \ later called from RAM
+ sei rom
+ RAMIRQ $100 u/mod    \ new IRQ
+   # lda >IRQ 1+ sta  \ .. install
+   # lda >IRQ sta
+ $FF84 normJsr  $FF8A normJsr
+    \ CIAs init. and set I/O-Vectors
+ ink-pot    lda BrdCol sta \ border
+ ink-pot 1+ lda BkgCol sta \ backgrnd
+ ink-pot 2+ lda PenCol sta \ pen
+ $80 # lda KeyRep sta \ repeat all keys
+ $FF13 lda 04 # ora $FF13 sta \ low/upp
+ ram cli rts end-code
+
+first-init dup bootsystem 1+ !
+               warmboot   1+ !
+
+Code c64init first-init jsr
+ xyNext jmp end-code
+
+\ *** Block No. 148, Hexblock 94
+
+\ C16-Pushkeys C64-like   01oct87clv/re)
+
+
+(C16
+
+Label InitPKs \ Pushkeys: Daten
+00 c, 00 c,  \ curr. numb Char, currPtr
+01 c, 01 c, 01 c, 01 c, \ StrLength
+01 c, 01 c, 01 c, 01 c, \   "
+
+85 c, 86 c, 87 c, 89 c, \ Content
+8a c, 8b c, 8c c, 88 c, \   "
+
+
+here InitPKs - >label InitPKlen
+
+
+Code C64fkeys \ Pushkeys a la C64
+  InitPKlen # ldx
+  [[ dex  0>= ?[[
+    InitPKs ,X lda PKeys ,x sta ]]?
+  xyNext jmp end-code
+
+)
+
+
+\ *** Block No. 149, Hexblock 95
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 150, Hexblock 96
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 151, Hexblock 97
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 152, Hexblock 98
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 153, Hexblock 99
+
+( restart param.-passing     clv12.4.87)
+
+Code restart       here >restart !
+ ' (restart >body 100 u/mod
+ # lda  pha  # lda pha
+ warmboot jmp   end-code
+
+\ Code for parameter-passing to Forth
+
+
+      03 18 +thru     \ CBM-Interface
+(c16+ 19 1a +thru )   \ c16init RamIRQ
+
+Host  ' Transient 8 + @
+  Transient  Forth  Context @ 6 + !
+Target     \ kotz wuerg !
+
+Forth also definitions
+         : )     ; immediate
+(C64     : (C64  ; immediate )
+(C16     : (C16  ; immediate )
+(C64 \ ) : (C64  [compile] ( ; immediate
+(C16 \ ) : (C16  [compile] ( ; immediate
+: forth-83 ;  \ last word in Dictionary
+
+
+\ *** Block No. 154, Hexblock 9a
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 155, Hexblock 9b
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 156, Hexblock 9c
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 157, Hexblock 9d
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 158, Hexblock 9e
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 159, Hexblock 9f
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 160, Hexblock a0
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 161, Hexblock a1
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 162, Hexblock a2
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 163, Hexblock a3
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 164, Hexblock a4
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 165, Hexblock a5
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 166, Hexblock a6
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 167, Hexblock a7
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 168, Hexblock a8
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+\ *** Block No. 169, Hexblock a9
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+