"show" command like "see" but copies from src
Tinkerer Atlarge
\ Firmware source remaining in load-area foll previous boot command
( To try it out, boot this file, then show colon defs defined within)
\ Provide an alternative to the value word 'actual-load-size' in case
\ environment variable fcode-debug? is in default state
%r25 %r28 DO \ search fcode table
i @ 18 - @ 10616374 ( 10"act" ) = IF \ quick-find probable match
i @ 17 - " actual-load-size" comp \ verify match
0= IF ( found )
" old-load-size" i @ (is-user-word) LEAVE \ dictionary alias
THEN
THEN
i %r25 4- = IF
." show.of: installation failed: essential resource not located"
( compile will terminate with "old-load-size not found" )
THEN
4 +LOOP
0 value was-mapped-out ( bool = "most recently loaded file dealloc'd")
3a constant ':' \ use of literal incompatible with this src
3b constant ';' \ use of literal incompatible with this src
5c constant '\' \ use of literal incompatible with this src
: is-white ( addr -- flag )
c@ dup dup ( c c c )
BL = swap carret = OR ( c flag )
swap dup ( flag c c )
linefeed = swap tab = OR ( flag flag )
OR ( flag )
;
: skip-white ( addr -- addr' )
BEGIN 1+ dup is-white not UNTIL
;
: solo? ( addr -- flag ) \ single char surrounded by white space ?
dup 1+ ( addr addr+1 )
is-white ( addr flag' )
swap 1- ( flag' addr-1 )
is-white ( flag' flag" )
AND ( flag )
;
: PrintChar ( c -- ) dup linefeed = IF carret emit THEN emit ;
: SkipLine ( addr -- eol-addr )
BEGIN 1+ dup c@ linefeed = UNTIL
;
: PrintLine ( addr -- eol-addr ) \ output from addr to end of line
BEGIN 1+ dup c@ dup printchar linefeed = UNTIL
;
: PrintDef ( addr -- ;-addr ) \ output all between ':'&';' inclusive
BEGIN 1+ dup c@ dup printchar ';' = IF dup solo? ELSE 0 THEN UNTIL
;
: to-lower ( addr len -- addr len ) \ leaves parameters on stack
2dup over + swap DO i c@ lcc i c! LOOP
;
: lc-comp ( addr1 addr2 len -- mismatch? ) \ case-insensitive compare
rot 1- 0 swap 2swap ( 0 addr1-1 addr2 len ) \ init flag (?) = 0
over + swap ( 0 addr1-1 addr2+len addr2 ) \ bounds
DO
1+ dup ( ? addr1++ addr1 )
c@ ( ? addr1 c1 ) \ assumes already lower-case
i c@ lcc ( ? addr1 c1 c )
<> ( ? addr1 mismatch? )
rot OR swap ( ?' addr1 )
LOOP
drop ( mismatch? )
; \ nb: returns flag, not diff
: restore-memory-map \ use only to exit 'show' following " map..THEN"
was-mapped-out IF
load-base old-load-size " /cpus/PowerPC,G4" " unmap"
execute-device-method
INVERT IF ." WARNING: Failed to restore prior memory map " THEN
THEN
;
2variable arg$
0 value eof-addr
0 value txtptr
: show ( -- )
bl word count dup 0=
abort" Usage: show word (where 'word' defined in last file booted)"
to-lower \ for case-insensitive search
arg$ 2!
old-load-size 0=
abort" no file" \ unlikely; this or more recent file should be there
load-base cpeek invert to was-mapped-out \ any ram at virt address?
was-mapped-out IF
load-base dup old-load-size 10 " /cpus/PowerPC,G4" " map"
execute-device-method
INVERT abort" Unable to access previously loaded text "
ELSE
drop \ discard result of cpeek used for probing virt address
true abort" loaded text not compiled "
\ compile cfms syntax & ensures 'show' sees same version as 'see'.
( if text area contains valid src file, type 'go' to compile it )
THEN
load-base w@ 5c20 ( "\ " ) <> ?dup IF \ magic number
restore-memory-map
abort" load-area text not identifiable as Open Firmware src "
THEN
load-base old-load-size + to eof-addr
load-base to txtptr
BEGIN
txtptr 1+ dup to txtptr
eof-addr u<
WHILE
txtptr c@ CASE \ generate flag for UNTIL; T = drop thru, F -> loop
'\' OF txtptr solo? IF
txtptr skipline to txtptr
THEN
false \ skip char or whole line if '\' starts valid comment
ENDOF
':' OF
txtptr solo? IF
arg$ 2@ txtptr skip-white swap
2dup + is-white >r
lc-comp 0= \ strings match for arg-length ?
r> AND \ lengths also match ?
ELSE
false
THEN
ENDOF
\ default:
false \ no action for unrecognized char
swap \ char consumed by ENDCASE, flag by UNTIL
ENDCASE
UNTIL
cr ':' emit
txtptr printdef \ output text of located colon def
printline drop \ also anything following ';' on same line
THEN
restore-memory-map
;