--- gforth/Attic/kernal.fs 1996/05/06 12:39:02 1.56 +++ gforth/Attic/kernal.fs 1996/09/10 16:08:39 1.63 @@ -74,6 +74,8 @@ HEX \ the code address of a @code{field} ['] reveal-method >code-address ; +NIL AConstant NIL \ gforth + \ Bit string manipulation 06oct92py \ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, @@ -143,28 +145,31 @@ HEX : off ( addr -- ) \ gforth false swap ! ; +\ dabs roll 17may93jaw + +: dabs ( d1 -- d2 ) \ double + dup 0< IF dnegate THEN ; + +: roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext + dup 1+ pick >r + cells sp@ cell+ dup cell+ rot move drop r> ; + \ name> found 17dec92py -: (name>) ( nfa+cell -- cfa ) - 1 cells - name>string + cfaligned ; -: name> ( nfa -- cfa ) \ gforth - cell+ - dup (name>) swap c@ \$80 and 0= IF @ THEN ; - -: found ( nfa -- cfa n ) \ gforth - cell+ - dup c@ >r (name>) r@ \$80 and 0= IF @ THEN - -1 r@ \$40 and IF 1- THEN - r> \$20 and IF negate THEN ; - -\ (find) 17dec92py - -\ : (find) ( addr count nfa1 -- nfa2 / false ) -\ BEGIN dup WHILE dup >r -\ name>string dup >r 2over r> = -\ IF -text 0= IF 2drop r> EXIT THEN -\ ELSE 2drop drop THEN r> @ -\ REPEAT nip nip ; +\$80 constant alias-mask \ set when the word is not an alias! +\$40 constant immediate-mask +\$20 constant restrict-mask + +: ((name>)) ( nfa -- cfa ) + name>string + cfaligned ; + +: (name>x) ( nfa -- cfa b ) + \ cfa is an intermediate cfa and b is the flags byte of nfa + dup ((name>)) + swap cell+ c@ dup alias-mask and 0= + IF + swap @ swap + THEN ; \ place bounds 13feb93py @@ -173,6 +178,18 @@ HEX : bounds ( beg count -- end beg ) \ gforth over + swap ; +: save-mem ( addr1 u -- addr2 u ) \ gforth + \ copy a memory block into a newly allocated region in the heap + swap >r + dup allocate throw + swap 2dup r> -rot move ; + +: extend-mem ( addr1 u1 u -- addr addr2 u2 ) + \ extend memory block allocated from the heap by u aus + \ the (possibly reallocated piece is addr2 u2, the extension is at addr + over >r + dup >r resize throw + r> over r> + -rot ; + \ input stream primitives 23feb93py : tib ( -- c-addr ) \ core-ext @@ -247,23 +264,27 @@ Defer source ( -- addr count ) \ core \ Literal 17dec92py : Literal ( compilation n -- ; run-time -- n ) \ core - state @ IF postpone lit , THEN ; immediate + postpone lit , ; immediate restrict : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth - state @ IF postpone lit A, THEN ; - immediate + postpone lit A, ; immediate restrict : char ( 'char' -- n ) \ core bl word char+ c@ ; : [char] ( compilation 'char' -- ; run-time -- n ) - char postpone Literal ; immediate -' [char] Alias Ascii immediate + char postpone Literal ; immediate restrict : (compile) ( -- ) \ gforth r> dup cell+ >r @ compile, ; -: postpone ( "name" -- ) \ core - name sfind dup 0= abort" Can't compile " - 0> IF compile, ELSE postpone (compile) A, THEN ; - immediate restrict + +\ not the most efficient implementation of POSTPONE, but simple +: POSTPONE ( -- ) \ core + COMP' swap POSTPONE aliteral compile, ; immediate restrict + +: interpret/compile: ( interp-xt comp-xt "name" -- ) + Create immediate swap A, A, +DOES> + abort" executed primary cfa of an interpret/compile: word" ; +\ state @ IF cell+ THEN perform ; \ Use (compile) for the old behavior of compile! @@ -486,16 +507,16 @@ Defer parser Defer name ( -- c-addr count ) \ gforth \ get the next word from the input buffer ' (name) IS name -Defer notfound ( c-addr count -- ) +Defer compiler-notfound ( c-addr count -- ) +Defer interpreter-notfound ( c-addr count -- ) : no.extensions ( addr u -- ) 2drop -&13 bounce ; -' no.extensions IS notfound +' no.extensions IS compiler-notfound +' no.extensions IS interpreter-notfound -: compile-only ( ... -- ) +: compile-only-error ( ... -- ) -&14 throw ; -Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt? -' compile-only IS interpret-special : interpret ( ?? -- ?? ) \ gforth \ interpret/compile the (rest of the) input buffer @@ -508,48 +529,41 @@ Defer interpret-special ( c-addr u xt -- \ interpreter compiler 30apr92py -: interpreter ( c-addr u -- ) \ gforth - \ interpretation semantics for the name/number c-addr u - 2dup sfind dup - IF - 1 and - IF \ not restricted to compile state? - nip nip execute EXIT - THEN - interpret-special exit - THEN - drop - 2dup 2>r snumber? - IF - 2rdrop - ELSE - 2r> notfound - THEN ; - -' interpreter IS parser - -: compiler ( c-addr u -- ) \ gforth - \ compilation semantics for the name/number c-addr u - 2dup sfind dup - IF - 0> +\ not the most efficient implementations of interpreter and compiler +: interpreter ( c-addr u -- ) + 2dup find-name dup + if + nip nip name>int execute + else + drop + 2dup 2>r snumber? IF - nip nip execute EXIT + 2rdrop + ELSE + 2r> interpreter-notfound THEN - compile, 2drop EXIT - THEN - drop - 2dup snumber? dup - IF - 0> + then ; + +: compiler ( c-addr u -- ) + 2dup find-name dup + if ( c-addr u nfa ) + nip nip name>comp execute + else + drop + 2dup snumber? dup IF - swap postpone Literal + 0> + IF + swap postpone Literal + THEN + postpone Literal + 2drop + ELSE + drop compiler-notfound THEN - postpone Literal - 2drop - ELSE - drop notfound - THEN ; + then ; + +' interpreter IS parser : [ ( -- ) \ core left-bracket ['] interpreter IS parser state off ; immediate @@ -589,7 +603,7 @@ variable backedge-locals 0 backedge-locals ! ; immediate : ASSUME-LIVE ( orig -- orig ) \ gforth - \ used immediateliy before a BEGIN that is not reachable from + \ used immediatly before a BEGIN that is not reachable from \ above. causes the BEGIN to assume that the same locals are live \ as at the orig point dup orig? @@ -627,7 +641,7 @@ variable backedge-locals over 0<> while over - name> >body @ max + ((name>)) >body @ max swap @ swap ( get next ) repeat faligned nip ; @@ -734,22 +748,23 @@ variable backedge-locals : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if POSTPONE ?dup-0=-?branch >mark ; immediate restrict -: THEN ( compilation orig -- ; run-time -- ) \ core - dup orig? - dead-orig = +: then-like ( orig -- addr ) + swap -rot dead-orig = if - >resolve drop + drop else dead-code @ if - >resolve set-locals-size-list dead-code off + set-locals-size-list dead-code off else \ both live - over list-size adjust-locals-size - >resolve + dup list-size adjust-locals-size locals-list @ common-list dup list-size adjust-locals-size locals-list ! then - then ; immediate restrict + then ; + +: THEN ( compilation orig -- ; run-time -- ) \ core + dup orig? then-like >resolve ; immediate restrict ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth immediate restrict @@ -778,13 +793,13 @@ immediate restrict \ issue a warning (see below). The following code is generated: \ lp+!# (current-local-size - dest-locals-size) \ branch -: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext - dest? + +: again-like ( dest -- addr ) over list-size adjust-locals-size - POSTPONE branch - -- ) [char] " parse here over char+ allot place align ; : "lit ( -- addr ) - r> r> dup count + aligned >r swap >r ; restrict -: (.") "lit count type ; restrict -: (S") "lit count ; restrict + r> r> dup count + aligned >r swap >r ; +: (.") "lit count type ; +: (S") "lit count ; : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string postpone (S") here over char+ allot place align ; immediate restrict -create s"-buffer /line chars allot -: S" ( compilation 'ccc"' -- ; run-time -- c-addr u ) \ core,file s-quote - [char] " parse - state @ - IF - postpone SLiteral - ELSE - /line min >r s"-buffer r@ cmove - s"-buffer r> - THEN ; immediate - -: ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote - state @ IF postpone (.") ," align - ELSE [char] " parse type THEN ; immediate : ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren BEGIN >in @ [char] ) parse nip >in @ rot - = @@ -998,12 +999,20 @@ create s"-buffer /line chars allot \ Header states 23feb93py -: flag! ( 8b -- ) - last @ dup 0= abort" last word was headerless" - cell+ tuck c@ xor swap c! ; -: immediate \$20 flag! ; -: restrict \$40 flag! ; -\ ' noop alias restrict +: cset ( bmask c-addr -- ) + tuck c@ or swap c! ; +: creset ( bmask c-addr -- ) + tuck c@ swap invert and swap c! ; +: ctoggle ( bmask c-addr -- ) + tuck c@ xor swap c! ; + +: lastflags ( -- c-addr ) + \ the address of the flags byte in the last header + \ aborts if the last defined word was headerless + last @ dup 0= abort" last word was headerless" cell+ ; + +: immediate immediate-mask lastflags cset ; +: restrict restrict-mask lastflags cset ; \ Header 23feb93py @@ -1019,14 +1028,16 @@ defer header ( -- ) \ gforth \ puts down string as cstring dup c, here swap chars dup allot move ; -: name, ( "name" -- ) \ gforth - name name-too-short? name-too-long? - string, cfalign ; -: input-stream-header ( "name" -- ) - \ !! this is f83-implementation-dependent - align here last ! -1 A, - name, \$80 flag! ; +: header, ( c-addr u -- ) \ gforth + name-too-long? + align here last ! + current @ 1 or A, \ link field; before revealing, it contains the + \ tagged reveal-into wordlist + string, cfalign + alias-mask lastflags cset ; +: input-stream-header ( "name" -- ) + name name-too-short? header, ; : input-stream ( -- ) \ general \ switches back to getting the name from the input stream ; ['] input-stream-header IS (header) ; @@ -1037,11 +1048,7 @@ defer header ( -- ) \ gforth create nextname-buffer 32 chars allot : nextname-header ( -- ) - \ !! f83-implementation-dependent - nextname-buffer count - align here last ! -1 A, - string, cfalign - \$80 flag! + nextname-buffer count header, input-stream ; \ the next name is given in the string @@ -1064,7 +1071,9 @@ create nextname-buffer 32 chars allot lastcfa @ ; : Alias ( cfa "name" -- ) \ gforth - Header reveal , \$80 flag! ; + Header reveal + alias-mask lastflags creset + dup A, lastcfa ! ; : name>string ( nfa -- addr count ) \ gforth name-to-string cell+ count \$1F and ; @@ -1072,7 +1081,7 @@ create nextname-buffer 32 chars allot Create ??? 0 , 3 c, char ? c, char ? c, char ? c, : >name ( cfa -- nfa ) \ gforth to-name \$21 cell do - dup i - count \$9F and + cfaligned over \$80 + = if + dup i - count \$9F and + cfaligned over alias-mask + = if i - cell - unloop exit then cell +loop @@ -1093,41 +1102,30 @@ Create ??? 0 , 3 c, char ? c, char ? c, : dodoes, ( -- ) here /does-handler allot does-handler! ; -: Create ( -- ) \ core +: Create ( "name" -- ) \ core Header reveal dovar: cfa, ; -\ DOES> 17mar93py - -: DOES> ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does - state @ - IF - ;-hook postpone (does>) ?struc dodoes, - ELSE - align dodoes, here !does ] - THEN - defstart :-hook ; immediate - \ Create Variable User Constant 17mar93py -: Variable ( -- ) \ core +: Variable ( "name" -- ) \ core Create 0 , ; -: AVariable ( -- ) \ gforth +: AVariable ( "name" -- ) \ gforth Create 0 A, ; : 2VARIABLE ( "name" -- ) \ double create 0 , 0 , ; -: User +: User ( "name" -- ) \ gforth Variable ; -: AUser +: AUser ( "name" -- ) \ gforth AVariable ; : (Constant) Header reveal docon: cfa, ; -: Constant ( w -- ) \ core +: Constant ( w "name" -- ) \ core (Constant) , ; -: AConstant ( addr -- ) \ gforth +: AConstant ( addr "name" -- ) \ gforth (Constant) A, ; -: 2Constant ( d -- ) \ double +: 2Constant ( w1 w2 "name" -- ) \ double Create ( w1 w2 "name" -- ) 2, DOES> ( -- w1 w2 ) @@ -1135,7 +1133,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ IS Defer What's Defers TO 24feb93py -: Defer ( -- ) \ gforth +: Defer ( "name" -- ) \ gforth \ !! shouldn't it be initialized with abort or something similar? Header Reveal dodefer: cfa, ['] noop A, ; @@ -1144,23 +1142,6 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ DOES> ( ??? ) \ perform ; -: IS ( addr "name" -- ) \ gforth - ' >body - state @ - IF postpone ALiteral postpone ! - ELSE ! - THEN ; immediate -' IS Alias TO ( addr "name" -- ) \ core-ext -immediate - -: What's ( "name" -- addr ) \ gforth - ' >body - state @ - IF - postpone ALiteral postpone @ - ELSE - @ - THEN ; immediate : Defers ( "name" -- ) \ gforth ' >body @ compile, ; immediate @@ -1169,7 +1150,7 @@ immediate defer :-hook ( sys1 -- sys2 ) defer ;-hook ( sys2 -- sys1 ) -: : ( -- colon-sys ) \ core colon +: : ( "name" -- colon-sys ) \ core colon Header docol: cfa, defstart ] :-hook ; : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core semicolon ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict @@ -1184,16 +1165,10 @@ AVariable current ( -- addr ) \ gforth : last? ( -- false / nfa nfa ) last @ ?dup ; -: (reveal) ( -- ) - last? - IF - dup @ 0< - IF - current @ @ over ! current @ ! - ELSE - drop - THEN - THEN ; +: (reveal) ( nfa wid -- ) + ( wid>wordlist-id ) dup >r + @ over ( name>link ) ! + r> ! ; \ object oriented search list 17mar93py @@ -1201,7 +1176,7 @@ AVariable current ( -- addr ) \ gforth struct 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) - 1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field + 1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else end-struct wordlist-map-struct @@ -1213,27 +1188,129 @@ struct 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) end-struct wordlist-struct -: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; +: f83find ( addr len wordlist -- nfa / false ) + ( wid>wordlist-id ) @ (f83find) ; \ Search list table: find reveal -Create f83search ' f83find A, ' (reveal) A, ' drop A, +Create f83search ( -- wordlist-map ) + ' f83find A, ' (reveal) A, ' drop A, Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, AVariable lookup G forth-wordlist lookup T ! G forth-wordlist current T ! +\ higher level parts of find + +( struct ) +0 >body cell + 1 cells: field interpret/compile-int + 1 cells: field interpret/compile-comp +end-struct interpret/compile-struct + +: interpret/compile? ( xt -- flag ) + >does-code ['] S" >does-code = ; + +: (cfa>int) ( cfa -- xt ) + dup interpret/compile? + if + interpret/compile-int @ + then ; + +: (x>int) ( cfa b -- xt ) + \ get interpretation semantics of name + restrict-mask and + if + drop ['] compile-only-error + else + (cfa>int) + then ; + +: name>int ( nfa -- xt ) \ gforth + (name>x) (x>int) ; + +: name?int ( nfa -- xt ) \ gforth + \ like name>int, but throws an error if compile-only + (name>x) restrict-mask and + if + compile-only-error \ does not return + then + (cfa>int) ; + +: name>comp ( nfa -- w xt ) \ gforth + \ get compilation semantics of name + (name>x) >r dup interpret/compile? + if + interpret/compile-comp @ + then + r> immediate-mask and if + ['] execute + else + ['] compile, + then ; + : (search-wordlist) ( addr count wid -- nfa / false ) - dup wordlist-map @ find-method perform ; + dup wordlist-map @ find-method perform ; + +: flag-sign ( f -- 1|-1 ) + \ true becomes 1, false -1 + 0= 2* 1+ ; + +: (name>intn) ( nfa -- xt +-1 ) + (name>x) tuck (x>int) ( b xt ) + swap immediate-mask and flag-sign ; + +: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search + \ xt is the interpretation semantics + (search-wordlist) dup if + (name>intn) + then ; + +: find-name ( c-addr u -- nfa/0 ) + lookup @ (search-wordlist) ; -: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search - (search-wordlist) dup IF found THEN ; +: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete + find-name dup + if ( nfa ) + state @ + if + name>comp ['] execute = flag-sign + else + (name>intn) + then + then ; + +: find ( c-addr -- xt +-1 / c-addr 0 ) \ core + dup count sfind dup + if + rot drop + then ; + +: (') ( "name" -- nfa ) \ gforth + name find-name dup 0= + IF + drop -&13 bounce + THEN ; + +: [(')] ( compilation "name" -- ; run-time -- nfa ) \ gforth bracket-paren-tick + (') postpone ALiteral ; immediate restrict + +: ' ( "name" -- xt ) \ core tick + (') name?int ; +: ['] ( compilation "name" -- ; run-time -- xt ) \ core bracket-tick + ' postpone ALiteral ; immediate restrict + +: COMP' ( "name" -- w xt ) \ gforth c-tick + (') name>comp ; +: [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick + COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict + +\ reveal words Variable warnings ( -- addr ) \ gforth G -1 warnings T ! : check-shadow ( addr count wid -- ) \ prints a warning if the string is already present in the wordlist -\ !! should be refined so the user can suppress the warnings >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if ." redefined " name>string 2dup type compare 0<> if @@ -1245,28 +1322,20 @@ G -1 warnings T ! then 2drop 2drop ; -: sfind ( c-addr u -- xt n / 0 ) \ gforth - lookup @ search-wordlist ; - -: find ( addr -- cfa +-1 / string false ) \ core,search - \ !! not ANS conformant: returns +-2 for restricted words - dup count sfind dup if - rot drop - then ; - : reveal ( -- ) \ gforth - last? if - name>string current @ check-shadow - then - current @ wordlist-map @ reveal-method perform ; + last? + if \ the last word has a header + dup ( name>link ) @ 1 and + if \ it is still hidden + dup ( name>link ) @ 1 xor ( nfa wid ) + 2dup >r name>string r> check-shadow ( nfa wid ) + dup wordlist-map @ reveal-method perform + then + then ; : rehash ( wid -- ) dup wordlist-map @ rehash-method perform ; -: ' ( "name" -- addr ) \ core tick - name sfind 0= if -&13 bounce then ; -: ['] ( compilation "name" -- ; run-time --addr ) \ core bracket-tick - ' postpone ALiteral ; immediate \ Input 13feb93py 07 constant #bell ( -- c ) \ gforth @@ -1284,29 +1353,23 @@ G -1 warnings T ! #lf ( sic! ) emit ; \ : backspaces 0 ?DO #bs emit LOOP ; -: >string ( span addr pos1 -- span addr pos1 addr2 len ) - over 3 pick 2 pick chars /string ; -: type-rest ( span addr pos1 -- span addr pos1 back ) - >string tuck type ; -: (del) ( max span addr pos1 -- max span addr pos2 ) - 1- >string over 1+ -rot move - rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ; -: (ins) ( max span addr pos1 char -- max span addr pos2 ) - >r >string over 1+ swap move 2dup chars + r> swap c! - rot 1+ -rot type-rest 1- backspaces 1+ ; -: ?del ( max span addr pos1 -- max span addr pos2 0 ) - dup IF (del) THEN 0 ; -: (ret) type-rest drop true space ; -: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; -: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; -: eof 2 pick 0= IF bye ELSE (ret) THEN ; + +: (ins) ( max span addr pos1 key -- max span addr pos2 ) + >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ; +: (bs) ( max span addr pos1 -- max span addr pos2 flag ) + dup IF + #bs emit bl emit #bs emit 1- rot 1- -rot + THEN false ; +: (ret) true space ; Create ctrlkeys - ] false false back false eof false forw false - ?del false (ret) false false (ret) false false + ] false false false false false false false false + (bs) false (ret) false false (ret) false false false false false false false false false false false false false false false false false false [ +defer insert-char +' (ins) IS insert-char defer everychar ' noop IS everychar @@ -1315,10 +1378,7 @@ defer everychar dup #del = IF drop #bs THEN \ del is rubout dup bl < IF cells ctrlkeys + perform EXIT THEN >r 2over = IF rdrop bell 0 EXIT THEN - r> (ins) 0 ; - -\ decode should better use a table for control key actions -\ to define keyboard bindings later + r> insert-char 0 ; : accept ( addr len -- len ) \ core dup 0< IF abs over dup 1 chars - c@ tuck type @@ -1441,6 +1501,17 @@ create pathfilenamebuf 256 chars allot \ \ ELSE false \ THEN ; +: absolut-path? ( addr u -- flag ) \ gforth + \ a path is absolute, if it starts with a / or a ~ (~ expansion), + \ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../ + \ Pathes simply containing a / are not absolute! + over c@ '/ = >r + over c@ '~ = >r + 2dup 2 min S" ./" compare 0= >r + 3 min S" ../" compare 0= + r> r> r> or or or ; +\ [char] / scan nip 0<> ; + : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth \ opens a file for reading, searching in the path for it (unless \ the filename contains a slash); c-addr2 u2 is the full filename @@ -1450,7 +1521,7 @@ create pathfilenamebuf 256 chars allot \ \ the path will usually contain dirs that are only readable for \ the user \ !! use file-status to determine access mode? - 2dup [char] / scan nip ( 0<> ) + 2dup absolut-path? if \ the filename contains a slash 2dup r/o open-file throw ( c-addr1 u1 file-id ) -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 ) @@ -1497,7 +1568,7 @@ create image-included-files 1 , A, ( po loadline @ ; : init-included-files ( -- ) - image-included-files 2@ 2* cells save-string drop ( addr ) + image-included-files 2@ 2* cells save-mem drop ( addr ) image-included-files 2@ nip included-files 2! ; : included? ( c-addr u -- f ) \ gforth @@ -1515,20 +1586,17 @@ create image-included-files 1 , A, ( po : add-included-file ( c-addr u -- ) \ gforth \ add name c-addr u to included-files - included-files 2@ tuck 1+ 2* cells resize throw - swap 2dup 1+ included-files 2! - 2* cells + 2! ; - -: save-string ( addr1 u -- addr2 u ) \ gforth - \ !! not a string, but a memblock word - swap >r - dup allocate throw - swap 2dup r> -rot move ; + included-files 2@ 2* cells 2 cells extend-mem + 2/ cell / included-files 2! + 2! ; +\ included-files 2@ tuck 1+ 2* cells resize throw +\ swap 2dup 1+ included-files 2! +\ 2* cells + 2! ; : included1 ( i*x file-id c-addr u -- j*x ) \ gforth \ include the file file-id with the name given by c-addr u loadfilename# @ >r - save-string add-included-file ( file-id ) + save-mem add-included-file ( file-id ) included-files 2@ nip 1- loadfilename# ! ['] include-file catch r> loadfilename# ! @@ -1579,8 +1647,8 @@ create image-included-files 1 , A, ( po : recurse ( compilation -- ; run-time ?? -- ?? ) \ core lastxt compile, ; immediate restrict -: recursive ( -- ) \ gforth - reveal last off ; immediate +' reveal alias recursive ( -- ) \ gforth + immediate \ */MOD */ 17may93jaw @@ -1628,6 +1696,10 @@ max-errors 6 * cells allot \ print value in decimal representation base @ decimal swap . base ! ; +: hex. ( u -- ) \ gforth + \ print value as unsigned hex number + '\$ emit base @ swap hex u. base ! ; + : typewhite ( addr u -- ) \ gforth \ like type, but white space is printed instead of the characters bounds ?do @@ -1814,3 +1886,5 @@ Defer 'cold ' noop IS 'cold \ or space and stackspace overrides \ 0 arg contains, however, the name of the program. + +