BLOCK NUMBER 81 ( CF83 Block Editor - Load Block ) ( Copyright [ c ] 1991 by BDS Software ) decimal cr cr .( Loading CF83 Block Editor ) : thrx ( +n1 +n2 -- ) 1+ swap cr do i dup 81 - cr 3 spaces ." Loading Block " space . ." of 13 " load loop ; 82 94 thrx cr cr .( Block Editor Loaded ) BLOCK NUMBER 82 ( CF83 Block Editor - 01/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal vocabulary editor editor definitions variable txcurs variable tycurs variable emode variable eblk variable padptr variable hblock variable hblkn variable hblku variable blkptr variable qcode BLOCK NUMBER 83 ( CF83 Block Editor - 02/13 ) ( Copyright [ c ] 1991 by BDS Software ) 16 base ! create ekey ( -- 8b ) here dup 2- ! 3406 , BD3F , AA4F , 3704 , 3606 , 3506 , AEA1 , 6E91 , create eemit ( char -- ) here dup 2- ! 3406 , 3706 , C17F , 220B , C121 , 2507 , 3604 , BD42 , 3920 , 03BD , 41D1 , 3506 , AEA1 , 6E91 , create (pntos) ( u +n -- n ) here dup 2- ! 3430 , 3730 , BD44 , A937 , 1035 , 30AE , A16E , 9112 , create print ( addr +n -- ) here dup 2- ! BD4F , DAAE , A16E , 9112 , create pcr ( -- ) here dup 2- ! BD4F , 91AE , A16E , 9112 , decimal BLOCK NUMBER 84 ( CF83 Block Editor - 03/13 ) ( Copyright [ c ] 1991 by BDS Software ) 16 base ! create ftype ( addr +n -- ) here dup 2- ! BD4F , 02AE , A16E , 9112 , create msc ( -- ) here dup 2- ! 3416 , DCF5 , 8620 , 3DC3 , 0A00 , 1F01 , CCFF , FFED , 818C , 1A00 , 25F9 , 3516 , AEA1 , 6E91 , decimal : xcurs ( -- addr ) 243 ; : ycurs ( -- addr ) 245 ; : home ( -- ) 0 xcurs ! 0 ycurs ! ; : cls ( -- ) 2560 6144 255 fill ; : clb ( -- ) 2560 4096 255 fill ; : pbd ( -- ) 6720 128 0 fill ; : savcrs ( -- ) xcurs @ txcurs ! ycurs @ tycurs ! ; BLOCK NUMBER 85 ( CF83 Block Editor - 04/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : rclcrs ( -- ) txcurs @ xcurs ! tycurs @ ycurs ! ; : bnt ( -- ) 8 xcurs ! 144 ycurs ! ." BLOCK NUMBER " ; : pdt ( -- ) 104 xcurs ! 160 ycurs ! ." PAD " ; : em ( -- ) savcrs 8 xcurs ! 160 ycurs ! emode @ if ." INSERT MODE " else ." OVERWRITE MODE" then rclcrs ; : bscr ( -- ) 0 emode ! cls pbd bnt em pdt home ; : bn ( -- ) savcrs 60 xcurs ! 144 ycurs ! eblk @ . space rclcrs ; : rpad ( -- ) pad padptr ! ; : epad ( -- ) 120 xcurs ! rpad 30 spaces 120 xcurs ! ; : curpad ( -- ) savcrs 160 ycurs ! epad ; : ban1 ( addr1 -- [addr1] or [addr1 addr2 addr3] ) dup 8704 = if 56 68 then ; BLOCK NUMBER 86 ( CF83 Block Editor - 05/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : ban2 ( addr1 -- [addr1] or [addr1 addr2 addr3] ) dup 9728 = if 58 69 then ; : ban3 ( addr1 -- [addr1] or [addr1 addr2 addr3] ) dup 10752 = if 60 70 then ; : ban4 ( addr1 -- [addr1] or [addr1 addr2 addr3] ) dup 11776 = if 62 71 then ; : banc ( addr1 -- addr1 addr2 addr3 ) ban1 ban2 ban3 ban4 ; : bget ( +n -- ) dup eblk ! block banc hblku ! hblkn ! hblock ! ; : upd ( -- ) -1 hblku @ c! ; : btype ( -- ) home hblock @ 1024 ftype home ; : xps ( -- +n ) xcurs @ 4 / ; : yps ( -- +n ) ycurs @ 8 / ; BLOCK NUMBER 87 ( CF83 Block Editor - 06/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : cps ( -- +n ) yps 64 * xps + ; : rtype ( -- ) savcrs 0 xcurs ! cps hblock @ + 1024 cps - ftype rclcrs ; : sptr ( -- ) cps hblock @ + blkptr ! ; : gblock ( +n -- ) bscr bget btype sptr bn em ; : rtarw ( -- ) cps 1022 > not if 1 blkptr +! xcurs @ 4 + dup 252 > if drop 0 8 ycurs +! then xcurs ! then ; : ltarw ( -- ) cps 1 < not if -1 blkptr +! xcurs @ 4 - dup 0 < if drop 252 -8 ycurs +! then xcurs ! then ; : uparw ( -- ) yps 1 < not if -64 blkptr +! -8 ycurs +! then ; : dnarw ( -- ) yps 14 > not if 64 blkptr +! 8 ycurs +! then ; : shrt ( -- ) 63 xps - blkptr +! 252 xcurs ! ; : shlt ( -- ) xps negate blkptr +! 0 xcurs ! ; BLOCK NUMBER 88 ( CF83 Block Editor - 07/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : shup ( -- ) hblock @ blkptr ! home ; : shdn ( -- ) hblock @ 1023 + blkptr ! 252 xcurs ! 120 ycurs ! ; : mbcr ( -- ) blkptr @ dup dup 1+ swap hblock @ 1023 + swap - cmove> 32 blkptr @ c! ; : mbcl ( -- ) blkptr @ 1+ dup 1- dup hblock @ 1023 + swap - cmove 32 hblock @ 1023 + c! ; : pechar ( char -- ) dup blkptr @ c! eemit rtarw ; : msbr ( -- ) cps 1023 = if 32 pechar else mbcr msc rtype then ; : msbl ( -- ) cps 1023 = if 32 pechar else mbcl msc rtype then ; : ppchar ( char -- char) dup dup padptr @ c! emit 1 padptr +! ; BLOCK NUMBER 89 ( CF83 Block Editor - 08/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : pntos ( -- n ) pad dup padptr @ swap - (pntos) rclcrs ; : savblk ( -- ) upd save-buffers ; : gblk ( +n -- ) clb bget btype sptr bn em curpad rclcrs ; : clup ( -- ) eblk @ dup 0= if drop else 1- gblk then ; : cldn ( -- ) eblk @ dup 627 < if 1+ gblk else drop then ; : delchr ( -- ) emode @ if msbl else 32 pechar then ; : addchr ( char -- ) emode @ if msbr then pechar ; : clrblk ( -- ) hblock @ 1024 32 fill clb home ; : tmode ( -- ) emode @ if 0 else -1 then emode ! em ; : dchange ( -- ) 65535 hblkn @ ! 0 hblku @ ! eblk @ gblk ; : aborted ( -- ) -1 qcode ! cls home ; : quited ( -- ) upd flush aborted ; : gpnk ( -- char ) ekey dup dup dup 8 = if -1 padptr +! -4 xcurs +! then 47 > swap 58 < and if ppchar then ; BLOCK NUMBER 90 ( CF83 Block Editor - 09/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : gpnum ( -- ) curpad begin gpnk 13 = until rclcrs ; : getblk ( -- ) gpnum pntos gblk ; : cbn ( +n -- ) -1 56 ! -1 58 ! -1 60 ! -1 62 ! dup eblk ! hblkn @ ! ; : chgblk ( -- ) gpnum pntos cbn bn curpad rclcrs ; : eenter ( -- ) 64 xps - 0 do 32 addchr loop ; : lprint ( addr -- ) 64 print pcr ; : lpr ( +n -- ) hblock @ + lprint ; : bprt ( -- ) 0 lpr 64 lpr 128 lpr 192 lpr 256 lpr 320 lpr 384 lpr 448 lpr 512 lpr 576 lpr 640 lpr 704 lpr 768 lpr 832 lpr 896 lpr 960 lpr ; : prtnum ( n -- ) 0 <# #s #> print ; : ic! ( addr char -- addr+1 ) swap dup 1+ rot rot c! ; BLOCK NUMBER 91 ( CF83 Block Editor - 10/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : prtbn ( -- ) pad 66 ic! 76 ic! 79 ic! 67 ic! 75 ic! 32 ic! 78 ic! 85 ic! 77 ic! 66 ic! 69 ic! 82 ic! 32 ic! drop pad 13 print prtnum ; : prtblk ( -- ) eblk @ prtbn pcr pcr bprt pcr ; : ek13 ( char -- char ) dup 13 = if eenter then ; : ek9 ( char -- char ) dup 9 = if rtarw then ; : ek8 ( char -- char ) dup 8 = if ltarw then ; : ek11 ( char -- char ) dup 11 = if uparw then ; : ek10 ( char -- char ) dup 10 = if dnarw then ; : ek22 ( char -- char ) dup 22 = if shrt then ; : ek21 ( char -- char ) dup 21 = if shlt then ; : ek24 ( char -- char ) dup 24 = if shup then ; : ek23 ( char -- char ) dup 23 = if shdn then ; BLOCK NUMBER 92 ( CF83 Block Editor - 11/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : ek7 ( char -- char ) dup 7 = if clup then ; : ek6 ( char -- char ) dup 6 = if cldn then ; : ek195 ( char -- char ) dup 195 = if delchr then ; : ek163 ( char -- char ) dup 163 = if delchr then ; : ek194 ( char -- char ) dup 194 = if clrblk then ; : ek162 ( char -- char ) dup 162 = if clrblk then ; : ek217 ( char -- char ) dup 217 = if dchange then ; : ek185 ( char -- char ) dup 185 = if dchange then ; : ek210 ( char -- char ) dup 210 = if savblk then ; : ek178 ( char -- char ) dup 178 = if savblk then ; : ek198 ( char -- char ) dup 198 = if getblk then ; : ek166 ( char -- char ) dup 166 = if getblk then ; : ek205 ( char -- char ) dup 205 = if chgblk then ; BLOCK NUMBER 93 ( CF83 Block Editor - 12/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : ek173 ( char -- char ) dup 173 = if chgblk then ; : ek200 ( char -- char ) dup 200 = if tmode then ; : ek168 ( char -- char ) dup 168 = if tmode then ; : ek207 ( char -- char ) dup 207 = if prtblk then ; : ek175 ( char -- char ) dup 175 = if prtblk then ; : ek192 ( char -- char ) dup 192 = if aborted then ; : ek160 ( char -- char ) dup 160 = if aborted then ; : ek208 ( char -- char ) dup 208 = if quited then ; : ek176 ( char -- char ) dup 176 = if quited then ; BLOCK NUMBER 94 ( CF83 Block Editor - 13/13 ) ( Copyright [ c ] 1991 by BDS Software ) decimal : ek0 ( char -- char ) dup 0 = if drop ekey addchr then ; : eloop ( -- ) ekey dup dup 31 > swap 128 < and if addchr else ek13 ek9 ek8 ek11 ek10 ek22 ek21 ek24 ek23 ek7 ek6 ek195 ek163 ek194 ek162 ek217 ek185 ek210 ek178 ek198 ek166 ek205 ek173 ek200 ek168 ek207 ek175 ek192 ek160 ek208 ek176 ek0 drop then ; forth definitions editor : edit ( +n -- ) -1 56 ! -1 58 ! -1 60 ! -1 62 ! editor 0 qcode ! gblock begin eloop qcode @ until forth ; forth