New bug reports. added slurp-fid; documented slurp-fid and slurp-file. bugfix in f. (thanks to Doug Bagley).: : in-dictionary? ( x -- f ) 70: forthstart dictionary-end within ; 71: 72: : in-return-stack? ( addr -- f ) 73: rp0 @ swap - [ forthstart 6 cells + ]L @ u< ; 74: 75: \ const-does> 76: 77: : compile-literals ( w*u u -- ; run-time: -- w*u ) recursive 78: \ compile u literals, starting with the bottommost one 79: ?dup-if 80: swap >r 1- compile-literals 81: r> POSTPONE literal 82: endif ; 83: 84: : compile-fliterals ( r*u u -- ; run-time: -- w*u ) recursive 85: \ compile u fliterals, starting with the bottommost one 86: ?dup-if 87: { F: r } 1- compile-fliterals 88: r POSTPONE fliteral 89: endif ; 90: 91: : (const-does>) ( w*uw r*ur uw ur target "name" -- ) 92: \ define a colon definition "name" containing w*uw r*ur as 93: \ literals and a call to target. 94: { uw ur target } 95: header docol: cfa, \ start colon def without stack junk 96: ur compile-fliterals uw compile-literals 97: target compile, POSTPONE exit reveal ; 98: 99: : const-does> ( run-time: w*uw r*ur uw ur "name" -- ) 100: \G Defines @var{name} and returns.@sp 0 101: \G @var{name} execution: pushes @var{w*uw r*ur}, then performs the 102: \G code following the @code{const-does>}. 103: here >r 0 POSTPONE literal 104: POSTPONE (const-does>) 105: POSTPONE ; 106: noname : POSTPONE rdrop 107: lastxt r> cell+ ! \ patch the literal 108: ; immediate 109: 110: \ !! rewrite slurp-file using slurp-fid 111: : slurp-file ( c-addr1 u1 -- c-addr2 u2 ) 112: \G @var{c-addr1 u1} is the filename, @var{c-addr2 u2} is the file's contents 113: r/o bin open-file throw >r 114: r@ file-size throw abort" file too large" 115: dup allocate throw swap 116: 2dup r@ read-file throw over <> abort" could not read whole file" 117: r> close-file throw ; 118: 119: : slurp-fid { fid -- addr u } 120: \G @var{addr u} is the content of the file @var{fid} 121: 0 0 begin ( awhole uwhole ) 122: dup 1024 + dup >r extend-mem ( anew awhole uwhole R: unew ) 123: rot r@ fid read-file throw ( awhole uwhole uread R: unew ) 124: r> 2dup = 125: while ( awhole uwhole uread unew ) 126: 2drop 127: repeat 128: - + dup >r resize throw r> ;