\ Utilities.blk 23Sep88pJa A4th A Public Domain Forth system for Amiga's based on Laxen & Perry's F83 This Forth system is Public Domain. You may freely distribute copy and use it, for any legal purposes. I cannot be held responsible for any errors and/or omissions, I do not warrant this system. I bear no responsibility for any use or abuse, with or without intend. Peter J. Appelman. \ load screen for extensions. 01Oct88pJawarning off 2 load ( view files definitions ) 3 load ( Only and Also ) from Cpu68k.blk 1 load ( machine dependent routines ) warning off 6 load ( Utilities ) 15 load ( strings ) 18 load ( editor ) 33 load ( dumping ) 36 load ( seeing ) 48 load ( showing ) 57 load ( bugging ) from Include.blk 1 load ( include file extensions ) from Tasks.blk 1 load ( task support ) cr \ Viewing source screens 23Sep88pJa 1 views Akernel.blk 2 views Utilities.blk 3 views Cpu68k.blk 4 views Include.blk 5 views Tasks.blk \ Load screen for also and only. 26Feb88pJa 1 2 +thru only forth also definitions cr .( Only and also loaded ) \s Famous vocabulary manipulators. Normally not compiled while Meta compiling, the Meta Compiler needs to be extended to handle vocabulary manipulations. \ the also and only concept 21Feb88pJacontext dup @ swap 4+ ! ( make forth also ) vocabulary root root definitions : also (s -- ) context dup 4+ #vocs 2- 4* cmove> ; : only (s -- ) ['] root >body context #vocs 1- 4* 2dup erase + ! root ; : seal (s -- ) ' >body context #vocs 4* erase context ! ; : previous (s -- ) context dup 4+ swap #vocs 2- 4* cmove context #vocs 2- 4* + off ; \ the also and only concept 21Feb88pJa: forth forth ; : definitions definitions ; : order (s -- ) cr ." Context: " context #vocs 0 do dup @ ?dup if body> >name .id then 4+ loop drop cr ." Current: " current @ body> >name .id ; : vocs (s -- ) voc-link @ begin dup #threads 4* - body> >name .id @ dup 0= until drop ; \ utilities 26Feb88pJa : u<= (s u1 u2 -- f ) u> not ; : u>= (s u1 u2 -- f ) u< not ; : <= (s n1 n2 -- f ) > not ; : >= (s n1 n2 -- f ) < not ; : 0<= (s n1 -- f ) 0> not ; : 0>= (s n1 -- f ) 0< not ; vocabulary hidden 1 8 +thru cr .( utilities loaded ) \ Output formatting. 22Feb88pJavariable lmargin 0 lmargin ! variable rmargin 70 rmargin ! : ?line (s n -- ) #out @ + rmargin @ > if cr lmargin @ spaces then ; : ?cr (s -- ) 0 ?line ; \ Managing source screens 22Feb88pJa: .scr (s -- ) ." Scr # " scr ? 8 spaces file? ; : list (s n -- ) 1 ?enough cr dup scr ! .scr l/scr 0 do cr i 3 .r space dup block i c/l * + c/l -trailing type key? ?leave loop drop cr ; : triad (s n -- ) 12 emit 3 / 3 * 3 bounds do i list loop ; : .line0 (s n -- ) dup 3 mod 0= if cr then cr dup 3 .r space block c/l -trailing type ; : index (s n1 n2 -- ) 2 ?enough 1+ swap do i .line0 loop cr ; : ind (s n -- ) begin dup .line0 1+ key? until drop ; \ Displaying words 22Feb88pJa: largest (s addr n -- addr' val ) over 0 swap rot 0 do 2dup @ u< if -rot 2drop dup @ over then 4+ loop drop ; : words (s -- ) cr lmargin @ spaces context @ here #threads 4* cmove begin here #threads largest dup while dup l>name dup c@ 31 and ?line .id space space @ swap ! key? if exit then repeat 2drop ; root definitions : words words ; forth definitions \ Iterated Interpretation. 22Feb88pJavariable #times 1 #times ! : times (s n -- ) 1 #times +! #times @ < if 1 #times ! else >in off then ; : many (s -- ) key? not if >in off then ; \ : when (s f -- ) \ not if r> 8- >r then ; : :: (s -- ) hide here >r [ ' : @ ] literal , !csp ] r@ execute r> dp ! ; \ Managing Source Screens. 24Feb88pJa: n (s -- ) 1 scr +! ; : b (s -- ) -1 scr +! ; : l (s -- ) scr @ list ; : establish (s n -- ) file @ swap 1 buffer# 2! ; : (copy) (s fr to -- ) swap in-block drop establish update ; : copy (s from to -- ) flush (copy) flush ; : @view (s cfa -- scr# viewfile# ) >view w@ dup 4095 and dup 0= abort" entered at terminal." swap 4096 / ; : view>fcb (s view# -- fcb|0 ) file-link begin @ dup while 2dup 8- @ = if 16- nip exit then repeat nip ; : view (s -- ) [ Dos ] ' @view ?dup if view>fcb ?dup if dup !files ." is in " .file open-file then else ." may be in current file: " file? then ." screen " dup . list ; \ Copying utility. 24Feb88pJavariable hopped ( # screens copy is offset ) variable u/d defer convey-copy ' (copy) is convey-copy : hop (s n -- ) hopped ! ; : .to (s n1 n2 -- n1 n2 ) cr over . ." to " dup . ; : (convey) (s blk n -- blk+n ) 0 ?do key? ?leave dup dup hopped @ + .to convey-copy u/d @ + loop flush ; : convey (s first last -- ) flush hopped @ 0< if 1+ over - 1 else dup 1+ rot - -1 then u/d ! #buffers /mod >r (convey) r> 0 ?do #buffers (convey) loop drop ; : to (s fst lst -- fst lst ) \ <1st destination> swap bl word number drop over - hop swap ; \ Open the graphics library. 01Oct88pJaGraphics Open-Graphics forth \ (spare) 26Feb88pJa \ Load screen for string functions 26Feb88pJa 1 2 +thru cr .( Strings loaded ) \s The string manipulation primitives. These are not used in the editor included in this system. The editor is a screen editor, and changes are easily made on screenSearching, replacing and deleting can be added, and I leave that up to the user; most users change the editor to suit their idea of an editor anyway. \ String functions Search. 26Feb88pJavariable found : scan-1st (s a n c -- a n ) caps @ if drop else scan then ; : search (s sadr slen badr blen -- n f ) found off swap >r 2dup u<= if over - 1+ 2 pick c@ r@ -rot >r begin r@ scan-1st dup if >r 3dup swap compare 0= if found on r> drop 0 >r then r> then dup while 1 /string repeat r> 2drop -rot then 2drop r> - found @ ; \ (spare) 26Feb88pJa \ Load screen for Editor. 05May88pJa 1 12 +thru cr .( Editor loaded ) only forth also definitions : (where) disk-error @ 0= if scr ! [ editor ] cursor - c decimal ed then ; ' (where) is where forth \s Where is now pointing at the editor and if a block does not load properly, will start the editor, with the cursor after the word not understood by the system. Normally this will be a word not yet defined. Possible confusion: 'windows' in the editor are actually pro- tected screen areas in the console device, not related to intuition type windows. \ terminal dependancy 25Feb88pJa155 constant CSI : dark control L emit #line off #out off ; : at (s row# col# -- ) 2dup <# ascii H hold 0 #s 2drop ascii ; hold 0 #s CSI hold #> type 1- #out ! 1- #line ! ; : concom0 (s c -- ) CSI emit emit ; : concom1 (s n char -- ) <# hold 0 #s CSI hold #> type ; : blot ascii K concom0 ; : blot+ ascii J concom0 ; : -line ascii M concom0 ; : +line ascii L concom0 ; : -char ascii P concom0 ; : +char ascii @ concom0 ; \ Making "windows" 25Feb88pJavocabulary editor editor definitions b/buf constant c/scr variable changed variable editing? variable editscr : leftoffset (s n-- ) 1- 8* 4+ ascii x concom1 ; : topoffset (s n-- ) 1- 8* 11 + ascii y concom1 ; : setlength (s n-- ) ascii t concom1 ; : setwidth (s n-- ) ascii u concom1 ; : bigwindow ascii u concom0 ascii t concom0 ascii y concom0 ascii x concom0 ; : setwindow (s row col width len -- ) 2swap swap topoffset leftoffset swap setwidth setlength ; : editwindow bigwindow 2 5 c/l l/scr setwindow ; : lowerwindow bigwindow 18 1 79 5 setwindow 5 1 at ; \ Showing and move cursor around. 25Feb88pJa: .block (s -- ) bigwindow 1 1 at blot .scr 2 5 c/l l/scr setwindow scr @ dup editscr ! block c/scr 1- 1 1 at type ; : .all (s -- ) scr @ editscr @ <> if .block lowerwindow then cr ; variable command : top (s -- ) r# off ; : c (s n -- ) r# @ + c/scr mod r# ! ; : up (s -- ) c/l negate c ; : down (s -- ) c/l c ; : cursor (s -- n ) r# @ ; : line# (s -- n ) cursor c/l / 1+ ; : col# (s -- n ) cursor c/l mod 1+ ; : setcursor (s -- ) line# col# at ; : modified (s -- ) changed on update ; \ Inserting, deleting lines. 25Feb88pJa: 'start (s -- adr ) scr @ block ; : 'cursor (s -- adr ) 'start cursor + ; : nextline (s -- ) line# top c/l * c ; : 'line (s -- adr ) 'cursor col# 1- - ; : thisline (s -- ) col# 1- negate c ; : #after (s -- n ) c/l col# - ; : makeroom (s -- ) 'line dup c/l + c/scr line# c/l * - cmove> modified ; : inline (s -- ) +line makeroom 'line c/l blank thisline setcursor ; : delline (s -- ) -line 'line dup c/l + swap c/scr line# c/l * - cmove modified 'start l/scr 1- c/l * + c/l blank setcursor ; \ Installing, date stamp, done. 25Feb88pJa: install (s -- ) editing? @ not if ['] .all is status also editing? on changed off dark .scr l/scr 0 do i 2+ 1 at i 3 .r i 2+ 70 at i . loop lowerwindow then ; 11 constant id-len create id id-len allot align id id-len blank : stamp (s -- ) id 'start c/l + id-len 1- - id-len 1- cmove ; : ?stamp (s -- ) changed @ if stamp changed off then ; : get-id (s -- ) id id-len -trailing nip 0= if cr ." Enter your ID: " id-len 0 do ascii . emit loop id-len backspaces id id-len expect then ; : done (s -- ) editing? @ if previous editing? off bigwindow 23 1 at save-buffers then ['] cr is status cr ; \ Character deleting, inserting. 25Feb88pJavariable inserting inserting off variable bschars bs cflip dup bl or flip or bschars ! : backspace (s -- ) col# 1 > if bschars 3 type -1 c bl 'cursor c! modified then ; : <left (s -- ) 'cursor dup 1+ swap #after cmove bl 'cursor #after + c! modified ; : delchar (s -- ) -char <left ; : >right (s -- ) 'cursor dup 1+ #after cmove> modified ; : inschar (s char -- ) +char dup emit >right 'cursor c! 1 c ; : overwrite (s char -- ) dup emit 'cursor c! 1 c modified ; \ Tabbing, splitting, blotting. 26Feb88pJa: character (s char -- ) inserting @ if inschar else overwrite then ; 3 constant #tab : tab (s -- ) inserting @ if #tab 0 ?do bl inschar loop else #tab c setcursor then ; : deleol (s -- ) blot 'cursor #after 1+ blank modified ; : split (s -- ) 'cursor #after 1+ pad place deleol nextline setcursor inline pad count 'cursor swap cmove pad count type setcursor ; : join (s -- ) cursor nextline 'line swap cursor - c 'cursor #after 1+ cmove 'cursor #after 1+ type setcursor modified ; \ Shadow Screen support. 26Feb88pJaforth definitions vocabulary shadow also shadow definitions : (>shadow) (s scr# fcb -- scr#' ) 4+ @ 1+ b/buf / tuck 2/ + swap mod ; : >shadow (s scr# -- scr#' ) file @ (>shadow) ; : >in-shadow (s scr# -- scr#' ) in-file @ (>shadow) ; only forth also definitions : a (s -- ) scr @ [ shadow ] >shadow scr ! ; only forth also editor definitions \ Moving around the screen. 25Feb88pJa: docommand (s key -- ) dup ascii A = if up else dup ascii B = if down else dup ascii C = if 1 c else dup ascii D = if -1 c else dup ascii T = if ?stamp b .block else dup ascii S = if ?stamp n .block else dup 32 = if key drop ?stamp a .block else then then then then then then then drop setcursor command off ; \ Command level. 25Feb88pJa: doedit dup 155 = if 1 command ! else dup 13 = if nextline setcursor else dup 127 = if delchar else dup 8 = if backspace else dup 9 = if tab else dup 14 = if inline else dup 25 = if delline else dup 20 = if deleol else dup 19 = if split else dup 10 = if join else dup 21 = if inserting on else dup 15 = if inserting off else dup 31 > if dup character then then then then then then then then then then then then then drop ; \ Editor interface 26Feb88pJa: wipe 'start b/buf blank modified editscr off ; : g (s scr line -- ) thisline editscr off makeroom c/l * swap block + 'line c/l cmove nextline stamp ; : bring (s scr first last -- ) 1+ swap do dup i g loop drop ; : e (s -- ) editwindow setcursor begin key dup command @ if docommand else doedit then control C = until ?stamp .block lowerwindow ; forth definitions : ed (s -- ) [ editor ] get-id install editor editscr on inserting off .all e ; : edit (s n -- ) [ editor ] 1 ?enough scr ! top ed ; \ Shadow Screen Editing. 26Feb88pJaonly forth also editor also shadow also definitions : copy (s from to -- ) flush 2dup (copy) >shadow swap >in-shadow swap (copy) flush ; : convey (s first last -- ) 2dup convey >in-shadow swap >in-shadow swap 0 >shadow 0 >in-shadow - hopped +! convey ; : g (s scr# line -- ) 2dup g a c/l negate c swap >in-shadow swap g a ; : bring (s scr# l1 l2 -- ) 1+ swap do dup [ forth ] i [ shadow ] g loop drop ; only forth also editor definitions \ (spare) 26Feb88pJa \ (spare) 26Feb88pJa \ Load screen for Dumping Utility. 26Feb88pJa1 2 +thru cr .( Dumping loaded ) \s The dump utility gives you a formatted hex dump with the ascii text corresponding to the bytes on the right hand side of the screen. 'dl' can be used to dump a line of text from a screen. 'du' can be used to incrementally dump 64 bytes of data and will leave the address following on the stack. \ Output 26Feb88pJa: .4 (s n -- ) 0 <# # # # # #> type space ; : dln (s addr -- ) cr dup 6 u.r ." - " dup 16 bounds do i w@ .4 2 +loop space 16 bounds do i c@ 127 and dup bl 126 between not if drop ascii . then emit loop ; : ?.n (s n1 n2 -- n1 ) 2dup = if ." V" drop else 2 .r then ; : ?.a (s n1 n2 -- n1 ) 2dup = if ." v" drop else 1 .r then ; \ Dump utility. 26Feb88pJa: .head (s addr len -- addr' len' ) swap dup -16 and swap 15 and cr 8 spaces 16 0 do i ?.n i 1 and if space then loop space 16 0 do i ?.a loop rot + ; : dump (s addr len -- ) base @ -rot hex swap even swap .head bounds do i dln key? ?leave 16 +loop base ! cr ; : du (s addr -- addr+64 ) dup 64 dump 64 + ; : dl (s line# -- ) c/l * scr @ block + c/l dump ; \ Load screen for Decompiler. 27Feb88pJa1 11 +thru cr .( Decompiler loaded ) \s A Forth decompiler is a utility program that translates executable forth code back into source code. Normally this is impossible, since traditional compilers produce more object code than source, but in Forth it is quite easy. The decompiler is almost one to one, failing only to correctly decompile the various Forth control structures and special compiling words. It was written with modifiablility in nind, so if you add your own special compiling words, it will be easy to change the decompiler to include them. This code is highly implementation dependant, and will NOT work on other Forth systems. To invoke the decompiler, use the word see <name> where <name> is the name of a Forth word. \ Positional case defining word. 27Feb88pJa( subscripts start from 0 ) : out (s # apf -- ) cr ." Subscript out of range on " dup body> >name .id ." Max is " ? ." tried " . quit ; : map (s # apf -- a ) 2dup @ u< if 4+ swap 4* + else out then ; : case: (s n -- ) constant hide ] does> (s #subscript -- ) map perform ; \ Table lookup defining word. 27Feb88pJa : associative: constant does> (s n -- index ) dup @ ( n pfa cnt ) -rot dup @ 0 ( cnt n pfa cnt 0 ) do 4+ 2dup @ = ( cnt n pfa' bool ) if 2drop drop i 0 0 leave then loop 2drop ; \ Decompile each type of word. 28Sep88pJadefer (see) hidden definitions : .word (s ip -- ip' ) dup @ >name .id 4+ ; : .inline (s ip -- ip' ) .word dup @ . 4+ ; : .branch (s ip -- ip' ) .word dup @ over - . 4+ ; : .quote (s ip -- ip' ) .word .word ; : .string (s ip -- ip' ) .word count 2dup type space + even ; : .astring (s ip -- ip' ) .word dup a"count 2dup type space + even ; \ Decompile each type of word. 27Feb88pJa: does? (s ip -- ip' f ) ['] forth @ 3 0 do dup 2+ swap w@ rot dup 2+ swap w@ rot = -rot swap loop drop >r and and r> swap ; : .(;code) (s ip -- ip' ) .word does? if ." does> " else drop false then ; : .unnest (s ip --ip' ) ." ; " drop 0 ; : .finish (s ip -- ip' ) .word drop 0 ; \ Classify each word in a definition. 28Sep88pJa15 associative: execution-class ( 0 ) ' (lit) , ( 1 ) ' ?branch , ( 2 ) ' branch , ( 3 ) ' (loop) , ( 4 ) ' (+loop) , ( 5 ) ' (do) , ( 6 ) ' compile , ( 7 ) ' (.") , ( 8 ) ' (abort") , ( 9 ) ' (;code) , ( 10 ) ' unnest , ( 11 ) ' (") , ( 12 ) ' (?do) , ( 13 ) ' (;uses) , ( 14 ) ' (a") , \ Classify each word in a definition. 28Sep88pJa16 case: .execution-class ( 0 ) .inline ( 1 ) .branch ( 2 ) .branch ( 3 ) .branch ( 4 ) .branch ( 5 ) .branch ( 6 ) .quote ( 7 ) .string ( 8 ) .string ( 9 ) .(;code) ( 10 ) .unnest ( 11 ) .string ( 12 ) .branch ( 13 ) .finish ( 14 ) .astring ( 15 ) .word ; \ Decompile a : definition. 25Jun88pJa: .pfa (s cfa -- ) >body begin ?cr dup @ execution-class .execution-class dup 0= key? or until drop ; : .immediate (s cfa -- ) >name c@ 64 and if ." immediate " then ; : libs: (s n -- ) create dup 1- 4* , 0 ?do ' >name , loop does> tuck @ over < if ." ???" 2drop else 4+ + @ .id then ; libbase# @ libs: .lib >Exec >Dos >Intuition >Graphics \ Display catagory of word. 25Sep88pJa: .constant (s cfa -- ) dup >body ? ." constant " >name .id ; : .variable (s cfa -- ) dup >body . ." variable " dup >name .id ." Value = " >body ? ; : .: (s cfa -- ) ." : " dup >name .id 2 spaces .pfa ; : .does> (s cfa -- ) ." does> " body> .pfa ; : .user-variable (s cfa -- ) dup >body ? ." user variable " dup >name .id ." Value = " >is ? ; : .user-defer (s cfa -- ) ." user deferred " dup >name .id ." is " >is @ (see) ; \ Display catagory of word. 04May88pJa: .defer (s cfa -- ) ." deferred " dup >name .id ." is " >body @ (see) ; : .romcall (s cfa -- ) base @ hex swap dup >name .id ." = " >body dup 4+ w@ w>s dup 255 and .lib 0< if ." Returns a value. " then dup 2+ w@ w>s ." Offset$" . w@ ." Mask$" . base ! ; : .other (s cfa -- ) dup >name .id dup @ over >body = if drop ." is Code " exit then dup @ does? if .does> drop exit then 2drop ." is Unknown " ; \ Classify a word based on its cfa. 25Sep88pJa7 associative: definition-class ( 0 ) ' quit @ , ( 1 ) ' 0 @ , ( 2 ) ' scr @ , ( 3 ) ' load @ , ( 4 ) ' type @ , ( 5 ) ' base @ , ( 6 ) Exec ' OpenLibrary @ , hidden 8 case: .definition-class ( 0 ) .: ( 1 ) .constant ( 2 ) .variable ( 3 ) .defer ( 4 ) .user-defer ( 5 ) .user-variable ( 6 ) .romcall ( 7 ) .other ; \ Top level of the Decompiler see. 27Feb88pJa: ((see)) (s cfa -- ) cr dup dup @ definition-class .definition-class .immediate ; ' ((see)) is (see) forth definitions : see (s -- ) ' (see) ; \ Load screen for Print utility. 27Feb88pJaonly forth also definitions 1 7 +thru cr .( Printing loaded ) only forth also definitions \s The print utility allows you to print a range of screens on your printer. If your printer allows it, you can print 6 screens per page. The top level word is show which takes a starting and ending screen number and prints all the non blank screens within the range. The printer is initialized by init-pr, which defaults to noop. Set it to your printer initialization sequence. If your printer cannot print 132 columns per line, then you should use triad-print, or triad-listing instead. \ Variables and setup 890114kel : Tally 27 emit ascii [ emit ascii 6 emit ascii w emit ; defer init-pr ' noop is init-pr defer footing 66 constant l/page 0 constant logo variable #page : page (s -- ) does> perform 1 #page +! #line off #out off ; page : form-feed (s -- ) control M emit control L emit ; : (page) (s -- ) l/page #line @ over min ?do cr loop ; ' form-feed is page hidden also definitions create scr#s 28 allot ( room for 6 screens and a count ) \ Print 2 screens across on a page. 27Feb88pJa: text? (s scr# -- f ) block dup c@ bl ascii ~ between if b/buf -trailing nip 0<> else false then ; : pr (s scr -- ) dup capacity >= if drop logo then 1 scr#s +! scr#s dup @ 4* + ! ; : 2pr (s scr1# scr2# line# -- ) cr dup 2 .r space c/l * >r pad 129 blank swap block r@ + pad c/l cmove block r> + pad c/l + 1+ c/l cmove pad 129 -trailing type ; : 2scr (s scr1 scr2 -- ) cr cr 4 spaces over 4 .r 61 spaces dup 4 .r 16 0 do 2dup i 2pr loop 2drop ; \ Prints 6 screens on a page. 27Feb88pJa: p-heading (s -- ) cr cr 5 spaces ." Page# " #page ? 8 spaces file? cr ; : p-footing (s -- ) cr cr 55 spaces ." Forth Amiga Model" page ; ' p-footing is footing \ Amiga printer handling. 890114kel variable Printer defer p-name : (p-name) (s -- adr ) " PRT:" drop ; ' (p-name) is p-name : p-close (s -- ) Printer @ ?dup if [ Dos ] Close Printer off then ; : p-abort (s -- ) ['] (type) is type p-close ." Printer error" abort ; : p-open (s -- ) Printer @ 0= if 1006 p-name [ Dos ] Open ?dup if Printer ! else p-abort then then ; : ptype (s adr len -- ) swap Printer @ ?dup 0= if 2drop p-abort then [ Dos ] Write #out +! key? if p-abort then ; \ Prints 6 screens on a page. 27Feb88pJa: pr-start (s -- ) #line off p-open ['] ptype is type scr#s off 1 #page ! init-pr ; : pr-stop (s -- ) ['] (type) is type p-close ; : pr-page (s -- ) p-heading scr#s off scr#s 4+ 3 0 do dup @ over 12+ @ 2scr 4+ loop drop footing ; : pr-s-page (s -- ) p-heading scr#s off scr#s 4+ 3 0 do dup @ over 4+ @ 2scr 8+ loop drop footing ; : pr-flush (s -- f ) scr#s @ dup if begin scr#s @ 5 < while 0 pr repeat logo pr then 0<> ; \ Print Page with shadows. 27Feb88pJaforth definitions : show (s first last -- ) [ hidden ] pr-start 1+ swap ?do i text? if i pr then scr#s @ 6 = if pr-page then loop pr-flush if pr-page then pr-stop ; shadow definitions : show (s first last -- ) [ hidden also ] pr-start 1+ swap ?do i text? if i pr i [ shadow ] >shadow pr then scr#s @ 6 = if pr-s-page then loop pr-flush if pr-s-page then pr-stop ; only forth also definitions \ Listing 27Feb88pJa: listing (s -- ) 0 capacity 2/ 1- [ shadow ] show ; : triad-print (s n -- ) [ hidden ] pr-start triad pr-stop ; : triad-listing (s -- ) capacity 0 ?do i triad-print 3 +loop ; \ (spare) 27Feb88pJa \ Load screen for Debugger Utility. 28Feb88pJaonly forth also definitions 1 2 +thru cr .( Debugging loaded ) only forth also definitions \s The debugger is designed to let the user single step the execu- tion of a high level definition. To invoke the debugger, type debug XXX where XXX is the name of the word you wish to trace. When XXX executes, you will get a single step trace showing you the word within XXX that is about to execute, and the contents of the parameter stack. If you wish to poke around, type F and you can interpret Forth commands until you type resume, and execution of XXX will continue where it left off. This debugger works by jumping to a different next routine and is highly machine dependent. \ Print a high level trace. 28Feb88pJabug also definitions : l.id (s nfa len -- ) swap dup .id c@ 31 and - dup 0> if spaces else drop then ; variable slow variable res : (debug) (s low-adr hi-adr -- ) 1 cnt ! ip> ! <ip ! pnext ; : 'unnest (s pfa -- pfa' ) begin 2+ dup @ ['] unnest = until ; \ Enter and Leave the Debugger. 28Feb88pJa: trace (s ip -- ) >r .s r> cr @ >name 10 l.id slow @ not key? or if slow off res off ." --> " key upc ascii C over = if slow @ not slow ! then ascii F over = if drop begin query run res @ until then ascii Q over = abort" Unbug" drop then pnext ; ' trace 'debug ! forth definitions : debug (s -- ) ' dup [ bug ] 'unnest (debug) ; : resume (s -- ) [ bug ] res on 0 pnext ; only forth also definitions \ Utilities.blk 26Feb88pJaThis file will extend the Forth kernel, Akernel.blk. From the Amiga Dos prompt you can type: [RUN] FORTH [[nnnn] string] where: nnnn is a number in hexadecimal. This number is the amount of bytes allocated for your dictionary. Default is 64k. Limit is your available memory. string is any valid Forth command, the most useful being: _open Utilities.blk ok_ (without the underlines) This will load the file Utilities.blk into your dictionary. Change the load screen of Utilities.blk to in/exclude the required tools and utilities. \ load screen for extensions. 26Feb88pJa view files definitions Viewing words in their respective filesOnly and Also Vocabulary manipulations. Cpu68k.blk The assembler and low level debugger. Utilities General utilities. strings Character manipulations. editor Editor adapted to Amiga dumping Hex dump routines. seeing Decompiler utility. showing Printing utility. bugging High level trace utility. Load these routines, they will take room up in the 'user dic- tionary'. Adjust the size of to allow room for your definitions.\ Viewing source screens 24Feb88pJa Akernel.blk Created the kernel. Utilities.blk Loads on top of the kernel to extend it. Cpu68k.blk Assembler. The view files depend on the linked list of files. The files are in a linked list to prevent the files not being closed on leaving Forth. The view number is set in the fcb for the file and inspected for a match if a word is to be 'viewed'. See the word view later. You can add your own viewfiles to this, and list any word defined within a numbered viewfile. Declare the number in your file before any words are defined. Or better, declare the file here and open your file when ready. It will already have the number set in the fcb. \ the also and only concept 24Feb88pJa root A small vocabulary for controlling search order. also (s -- ) Adds another vocabulary to the search order. only (s -- ) Erases the search order and forces the root vocabulary to be the first and last. seal (s -- ) Usage: 'seal forth' will change the search order such that only forth will be searched. previous (s -- ) The inverse of also, removes the most recently referenced vocabulary from the search order. \ the also and only concept 24Feb88pJaWe initialize the root vocabulary with a few definitions that allow us to do vocabulary related things. order (s -- ) Displays the search order currently in effect. Also displays the current vocabulary, which is were definitions are placed. vocs (s -- ) Lists all of the vocabularies that have been defined so far, in the order of their definition. \ utilities 24Feb88pJa u<= Unsigned less than or equal. u>= Unsigned greater than or equal. <= Less than or equal. >= Greater than or equal. 0<= Less than or equal to zero. 0>= Greater than or equal to zero. hidden is a vocabulary for internal routines to avoid cluttering up forth with all manner of junk. load the rest of the utilities. \ Output formatting. 24Feb88pJalmargin is the column number of the left margin. rmargin is the column number of the right margin. ?line (s n -- ) Move to the left margin on next line if we will be past the right margin after printing n characters. ?cr (s -- ) Move to left margin on next line of we are past the right margin. These words are useful for a variety of output formatting needs.Only 'words' uses the margins currently. See chapter 12 of Starting Forth for more ideas. \ Managing source screens 24Feb88pJa.scr (s -- ) Print current screen number and file name. list (s n -- ) List the specified screen as 16 lines with 64 characters each. Pressing a key aborts the listing. List also makes the specified screen the current screen. triad (s n -- ) Lists three screens per page. For 80 column printers. .line0 (s n -- ) Print line 0 of block n. index (s n1 n2 -- ) Lists the first line of every screen, form n1 through n2. Useful to get an overview of the files contents. ind (s n -- ) A single argument to index. \ Displaying words 24Feb88pJalargest (s addr n -- addr' val ) Given an address and a number of words to examine, return the address and the value of the largest entry in the array. words (s -- ) List the words in the context vocabulary. This can be interrupted any time by pressing any key. Adds words to root vocabulary. \ Iterated Interpretation. 24Feb88pJa#times A variable that keeps track of how many times. times (s n -- ) Re-execute the input stream a specified number of times. many (s -- ) Re-execute the input stream until the user presses a key. \ when (s f -- ) \ Re-execute the previous word until it returns true. \ usage: : test key? when ." ready " cr ; :: (s -- ) Compile and execute nameless Forth code, then forget it. \ Managing Source Screens. 24Feb88pJan Make the next screen the current one. b Make the previous (before) screen the current one. l List the current screen. establish Sets the block number of recently referenced block. (copy) (s fr to -- ) Copies one screen to another. copy (s from to -- ) Copies one screen to another and saves. @view (s cfa -- scr# viewfile# ) Converts a cfa to a screen number and viewfile number, aborts if entered at the terminal with a message. view>fcb (s view# -- fcb|0 ) converts a view number to the fcb of the file, returns 0 if not found. view <name> Will display the name of the file and number of the screen containing the scource code for <name>. The file is opened and the screen listed. \ Copying utility. 24Feb88pJahopped The number of screens to skip when copying. u/d The direction of the copy, prevents overlap. convey-copy deferred for use in different contexts. hop specifies the number of screens to hop over. .to Print a message to keep the user happy. (convey) (s blk n -- blk+n ) Moves a set of screens in the direction of the copy. convey (s first last -- ) Moves a set of screens by first determining the direction to prevent overlap, and then moving them as a set whose size is determined by the number of available buffers. to (s fst lst -- fst lst ) <1st destination> Specifies the destination screen for a copy e.g.: 15 20 to 30 convey \ String functions Search 26Feb88pJafound A local variable to make life easier. scan-1st Scan for the first character of a string. search (s sadr slen badr blen -- n f ) search for the s string inside of the b string. If found f is true and n is the offset from the beginning of the string to where the pattern was found. If not found, f is false and n is meaningless. I have included this word from the listing of L&P F83. I don't use it in this editor, you can, but be aware I have not tested it. \ Load screen for Editor. 25Feb88pJaThis editor is made for the Amiga. It assumes you start with a regular sized window (640x200). This editor will not take windowsize changes into consideration. The editing is done on screen. The arrow keys move around with wrap on the boundaries. Shift-arrow keys allow next/previous screens and Alternate screens. See the command screens for whichkeys do what. Lots of improvements possible, it's up to you. - Detect if the window is interlaced, (640x400), and put the Al- ternate screen at the bottom half. - Get the time/date from Dos instead of the user. - Table driven command manipulation. - searching and replacing. ..... \ terminal dependancy 25Feb88pJaCSI Amiga's Command Sequence Introducer for console device. dark Clear the the window and home the cursor. at Position the cursor at the given row and column co-ordinates. concom0 Send a command sequence with no parameters concom1 Send a command sequence with one parameter. blot clear to end of line blot+ clear to end of window. -line delete current line +line insert a line -char delete current char. +char insert a blank char. \ Making "windows" 25Feb88pJaeditor vocabulary for editor words. c/scr number of characters on a screen. changed indicates whether the screen being edited has been. editing? Flag indicates whether you are editing. editscr The screen you are editing. leftoffset For amiga windows. N is in characters from current topoffset left/top window border. setlength Also expect n in characters. These two set the setwidth height and width of the active area in a window bigwindow Resets the window to full size. Used after a (some) active fields were defined setwindow Sets an active area sized with the given character values. The cursor will stay within the area. editwindow Make active area for a standard Forth screen. lowerwindow Make bottom 5 lines active area. \ Showing and move cursor around. 25Feb88pJa.block Print out the current block in the editor format. Leaves the cursor in the screen's area. .all Print current screen and set cursor in lower command area command Flag to track keyboard command sequences. top Go to the top of the screen. c Move n characters right or left. Negative for left. up/down Move cursor up/down one line, all movements will wrap.cursor Current cursor position on the block. line#/col# Current line and colomn number of cursor. setcursor Update the cursor position on display-screen. modified Indicate current screen is changed. \ Inserting, deleting lines. 25Feb88pJa'start Memory address of start of the screen. 'cursor Memory address of current position. nextline Move to the beginning of next line. 'line Memory address of start of current line. thisline Move to the beginning of this line. #after Returns number of characters after cursor on this linemakeroom Move current line and remaining lines down one, losing the last line. Makes room for a new line. inline Inserts a blank line before current line; current line is moved down one, the last line is lost. delline Deletes the current line and inserts a blank line on the last display line. \ Installing, date stamp, done. 25Feb88pJainstall Start the editor, sets the status to update display displays current screen. id-len Length of id string. id The address of the id string. stamp Place id in upper part of the screen. ?stamp Update id if screen has changed, and clear flag. get-id Get user id string, currently date and initials. Can be updated to get Dos's date and time, provides id string automatically. done Exits the editor, restores system to same as before the editor was invoked. Saves any changes. \ Character deleting, inserting. 25Feb88pJainserting True if inserting, overtype is default. bschars Holds backspace sequence: bs bl bs backspace Moves cursor one character back, blanks the character on the left. <left Shift all characters on this line one left, deleting the one under the cursor. delchar Deletes character under the cursor. >right Shift all characters on this line one right. inschar Inserts given character in the current cursor position, loosing the last char on the line. overwrite Overwrite given character on the current cursor position. \ Tabbing, splitting, blotting. 25Feb88pJacharacter Inserts a character if inserting. Overtypes normally. #tab Number of characters to tab. tab Uses #tab to tab, skipping if inserting off, otherwise will insert #tab blanks. deleol Deletes to the end of the current line. split Split the current line in two at the cursor position. Inserts the remainder of the current line, looses the last line. join Put a copy of the next line from the cursor to the end of this line. \ Shadow Screen support. 25Feb88pJashadow Vocabulary for shadow screen support. (>shadow) (s scr# fcb -- scr#' ) Converts to shadow screen for given fcb. >shadow (s scr# -- scr#' ) Convert to shadow screen for current file. >in-shadow (s scr# -- scr#' ) Convert to shadow screen for current input file. only forth also definitions a (s -- ) Toggle between screen and shadow. ( Alternate ) \ Moving around the screen. 25Feb88pJadocommand (s key -- ) Processes the remainder of a keyboard special key, such as the arrow keys. The first character is CSI, which sets the flag 'command' any characters after that come here. The current keys are mapped as follows: up arrow = line up | down arrow = line down |> The moves will wrap at left arrow = left char |> boundaries. right arrow = right char | shift up arrow = previous screen shift down arrow = next screen shift left arrow = shadow toggle shift rignt arrow = shadow toggle \ Command level. 25Feb88pJadoedit The edit loop, processes keyboard entry. Mapping is as: CSI set command flag on, next char is for docommand. return moves to first position of the next line. del deletes one character backspace backspace;destructive, use arrow for non destruct. tab tabs Control keys as follows: ^n insertline ^y delete line ^t delete to eol ^s split ^j join ^u inserting on ^o inserting off \ Editor interface 26Feb88pJawipe Clear current edit screen. g (s scr line -- ) Get a line from screen scr and insert at cursor position bring (s scr first last -- ) Get a range of lines from screen scr and insert at cursore (s -- ) Sets up the display and collects key presses and routes them to the correct routines. Control C will stop editing. ed (s -- ) Start editing current screen. edit (s n -- ) Edit screen n in current file. \ Shadow Screen Editing. 26Feb88pJa copy (s from to -- ) Copy a screen and it's shadow. convey (s first last -- ) Copy a range of screens and its shadows. g (s scr# line -- ) Get a line and its shadow. bring (s scr# l1 l2 -- ) Get a range of lines and their shadows. \ Output 26Feb88pJa.4 Display a 4 digit number followed by a space. dln (s addr -- ) Dump 16 bytes worth of data starting at the specified address. First the address is displayed, then 8 sets of words, followed by the Ascii equivalent. ?.n If the two numbers match, display a downwards pointer, otherwise display the number. ?.a If the two numbers match, display a downwards pointer, otherwise display the number. \ Dump utility. 26Feb88pJa.head (s addr len -- addr' len' ) Display the header field of a dump, making it easy to index into the data portion of the display. dump (s addr len -- ) Dump memory in the range specified. The dump is always in hex, but the current base is unaltered. du (s addr -- addr+64 ) Dump 64 bytes at the specified address, and increment it. dl (s line# -- ) dump the specified line number on the current screen. \ Positional case defining word. 27Feb88pJa out (s # apf -- ) Display an error message if the index is out of range as pointed to by the parameter field. map (s # apf -- a ) Map a subscript and a pfa into an actual address. case: (s n -- ) A positional case statement. The number of cases is specified for error checking. At runtime, the nth word is executed, depending upon the value on the stack. \ Table lookup defining word. 27Feb88pJa associative: An associative memory word. It must be followed by a set of values to be looked up. At Runtime, the values stored in the parameter field are searched for a match. If one is found, the index to that value is returned. If no match is made, then the number of entries, ie max index + 1 is returned. This is the inverse of an array. \ Decompile each type of word. 28Sep88pJa(see) Forward reference to decompile deferred words. The following are used only by the decompiler: .word (s ip -- ip' ) Display the name of a word, and bump the simulated ip by 4. .inline (s ip -- ip' ) Display a word that contains an inline literal value. .branch (s ip -- ip' ) Display a word that contains an inline branch. .quote (s ip -- ip' ) Handles the special case of compile xxxx. .string (s ip -- ip' ) Displays a word with an inline string argument .astring (s ip -- ip' ) Displays a word with an inline amiga type string. \ Decompile each type of word. 27Feb88pJadoes? (s ip -- ip' f ) Increments simulated ip and returns true if call dodoes is there. .(;code) (s ip -- ip' ) Perhaps continue to decompile a defining word. .unnest (s ip --ip' ) The end of a colon word is reached, stop decompiling. .finish (s ip -- ip' ) Display current word and quit. \ Classify each word in a definition. 27Feb88pJaexecution-class This table lists all of the special cases that must be decompiled differently from ordinary Forth words like dup and + etc. At runtime, if the simulated ip points to a word in this group, the correspoinding index from this table will be returned, and placed upon the stack. If there is no match, then the last index + 1 is returned. \ Classify each word in a definition. 27Feb88pJa.execution-class This case statement handles the special case decompiling needed. Each entry corresponds to an entry in the previous execution-class associative table. The function of each of these words is to decompile the current word that the simulated ip is pointing to, and advance the simulated ip accordingly. If no match in the table, .word is used. \ Decompile a : definition. 04May88pJa.pfa (s cfa -- ) This decompiles a parameter field which contains a list of code fields, as is found in : definitions. .immediate (s cfa -- ) This indicates whether the current word is Immediate or not. libs: (s n -- ) Create a word that looks up the n'th nfa when it executes and prints the id. Add the appropriate Amiga library base names as per example. \ Display catagory of word. 25Sep88pJa.constant (s cfa -- ) Decompile a constant, and prints its value. .variable (s cfa -- ) Decompile a variable, giving its location and value. .: (s cfa -- ) Decompile a high level : definiton. .does> (s cfa -- ) Decompile a word defined by a create..does> word. .user-variable (s cfa -- ) Decompile a task variable, giving offset and value .user-defer (s cfa -- ) Decompile what the task deferred is currently pointing to. \ Display catagory of word. 04May88pJa.defer (s cfa -- ) Tell the user this is a deferred word and decompile its current defintion. .romcall (s cfa -- ) Prints the type of romcall, whether it returns a value, the offset and the register mask, in hex. This info is stored in the three words following the cfa. First one is the registermask, second word the offset, third word is the combined value return flag and library base array index. .other (s cfa -- ) This decompiles words whose category is not known. Code words are recognized, as are words defined by defining words. The runtime portion of a word defined by a defining word is decompiled, since the parameter field is determined by the create portion and cannot be deciphered. If all else fails, the word is listed as unknown. \ Classify a word based on its cfa. 27Feb88pJadefinition-class This categorizes the different classes of words that the decompiler will handle. For each class, determined by the type of defining word used, the code field is identical. Thus the standard classes are recognized. .definition-class These are the routines that handle the decompilation of each class. The most useful, and of course most common one is ." which decompiles : definitions. If the class is not recognized, we check to see if it is a code word or perhaps defined by a high level create.. does> word. \ Top level of the Decompiler see. 27Feb88pJa((see)) (s cfa -- ) Takes an arbitrary code field address and decompiles it based upon its definition class. Upon completion, it indicates whether or not the word is immediate. see (s -- ) The user interface. To decompile something type see XXX. \ Load screen for print utility. 27Feb88pJaThis utility prints to a file. In Amiga the file can be PRT: which is the printer you select with 'Preferences'. If your printer is not supported, you can use SER: or PAR:. The word p-name in the hidden vocabulary defines the name of thefile and is deferred. You can alter this to save the informationto a diskfile for instance. Note that most defined strings in colon definitions have a zero byte appended and output this to the printer. If your output device cannot handle it, you will have to insert a filter in theoutput routine. \ Variables and setup 27Feb88pJaTally Sets a Mannesmann-Tally to 132 columns init-pr Sets printer to 132 columns, default is Tally footing Print a message at the bottom of the page. l/page The number of lines per page. logo The screen number of your Logo screen. #page The current page number while printing. page Printer dependent. Get to a new page. Increment the page number and reset the line number and the column number. form-feed Print a form feed character. (page) Print line feeds to get to next page. The following words are used only in this utility. scr#s An array to hold a count and 6 screen numbers. \ Print 2 screens across on a page. 27Feb88pJatext? (s scr# -- f ) Given a screen number, returns true if the first character in the screen is printable and the screen is not blank. pr (s scr -- ) Add the screen to the array and increment the pointers. If it is out of range, replace it with the logo screen. 2pr (s scr1# scr2# line# -- ) Print the specified line from the two screens given on the stack. The line from scr1 is copied to pad and the line from scr2 is appended, and the result is printed. 2scr (s scr1 scr2 -- ) Print 2 screens across on a page. Calls 2pr on a line by line basis. \ Prints 6 screens on a page. 27Feb88pJap-heading (s -- ) Prints the heading for each new page. p-footing (s -- ) Prints the footing for each new page. Assumes form feed works \ Amiga printer handling. 27Feb88pJaPrinter Holds the (Dos) file handle for the printer. p-name Returns an address of a file name, mine is SER: (p-name) Default for p-name. p-close (s -- ) Closes the printer and returns the file handle to Dos. p-abort (s -- ) On error, reset the type vector and print message. p-open (s -- ) Open a printer for subsequent output. Will print message if unable to open. You can use any file handle, to output. ptype (s adr len -- ) Prints a string to the printer file. Will print error mess. if the printer wasn't opened, or if any key is pressed. You can abort fouled up printing. \ Prints 6 screens on a page. 27Feb88pJapr-start Initialize printer, open the file, redirect. pr-stop Resets the redirection and closes printer. pr-page (s -- ) Prints a page worth of screens without shadows. The screens are printed in vertical columns, 6 on a page. pr-s-page (s -- ) Prints a page worth of screens with shadows. The wource code appears in the left column, and the associated shadow on the right column. pr-flush (s -- f ) Fills the scr#s array if a page is partially filled. Returns true if there is more to print, otherwise false. \ Print Page with shadows. 27Feb88pJashow (s first last -- ) Is used to print a range of screens, from first to last. Screens are printed six to each page. This requires a printer capable of 132 columns per line. Some printers, like the Epson, must be put into a mode where 132 columns per line are available. Blank screens are not printed. shadow show (s first last -- ) Is similar, but prints three screens and their three shadows on each page. Typical usage: 1 20 show or 1 20 shadow show \ Listing 27Feb88pJalisting (s -- ) Print the entire file, with shadows. triad-print (s n -- ) Print a triad of screen on the current printer. triad-listing (s -- ) Print the entire file in triad format, use on printers with- out 132 column capability. 28Feb88pJafor example debug words will trace the execution of words the next time it is used. \ Print a high level trace. 28Feb88pJaPut component words in the bug vocabulary. l.id (s nfa len -- ) Print the name of a word left justified in a field of at least ten characters. slow when true, step continuously. res when true, resume debugging. See trace. (debug) (s low-adr hi-adr -- ) Sets the upper and lower limits of the tracing window to the given values, and patches the next jump. 'unnest (s pfa -- pfa' ) Find end of word to debug. \ Enter and Leave the Debugger. 28Feb88pJatrace Is executed every other pass through next. It displays the contents of the parameter stack and the name of the next word to be executed in the rouinte being debugged Trace then waits for a key unless slow is true. If the key is c, f or q, special action is taken, otherwise a single step is performed. C turns on continuous running ( and slow ). F re-enters Forth and interprets commands until resume is executed. Q aborts the trace and restores the next jump. debug Patches next to the debugging version of next. Debug also sets the upper and lower limits of the tracing region to the ends of the parameter field of the specified word. resume Turns on res, which enables tracing to continue
