--- gforth/Attic/kernel.fs 1996/12/28 17:19:25 1.9 +++ gforth/Attic/kernel.fs 1997/03/04 22:09:54 1.17 @@ -20,62 +20,56 @@ \ Idea and implementation: Bernd Paysan (py) -\ Log: ', '- usw. durch [char] ... ersetzt -\ man sollte die unterschiedlichen zahlensysteme -\ mit $ und & zumindest im interpreter weglassen -\ schon erledigt! -\ 11may93jaw -\ name> 0= nicht vorhanden 17may93jaw -\ nfa can be lfa or nfa! -\ find splited into find and (find) -\ (find) for later use 17may93jaw -\ search replaced by lookup because -\ it is a word of the string wordset -\ 20may93jaw -\ postpone added immediate 21may93jaw -\ to added immediate 07jun93jaw -\ cfa, header put "here lastcfa !" in -\ cfa, this is more logical -\ and noname: works wothout -\ extra "here lastcfa !" 08jun93jaw -\ (parse-white) thrown out -\ refill added outer trick -\ to show there is something -\ going on 09jun93jaw -\ leave ?leave somebody forgot UNLOOP!!! 09jun93jaw -\ leave ?leave unloop thrown out -\ unloop after loop is used 10jun93jaw - HEX \ labels for some code addresses +doer? :docon [IF] : docon: ( -- addr ) \ gforth \G the code address of a @code{CONSTANT} ['] bl >code-address ; +[THEN] : docol: ( -- addr ) \ gforth \G the code address of a colon definition - ['] docon: >code-address ; + ['] docol: >code-address ; +doer? :dovar [IF] : dovar: ( -- addr ) \ gforth \G the code address of a @code{CREATE}d word ['] udp >code-address ; +[THEN] +doer? :douser [IF] : douser: ( -- addr ) \ gforth \G the code address of a @code{USER} variable ['] s0 >code-address ; +[THEN] +doer? :dodefer [IF] : dodefer: ( -- addr ) \ gforth \G the code address of a @code{defer}ed word ['] source >code-address ; +[THEN] +doer? :dofield [IF] : dofield: ( -- addr ) \ gforth \G the code address of a @code{field} ['] reveal-method >code-address ; +[THEN] + +has-prims 0= [IF] +: dodoes: ( -- addr ) \ gforth + \G the code address of a @code{field} + ['] spaces >code-address ; +[THEN] NIL AConstant NIL \ gforth +\ Aliases + +' i Alias r@ + \ Bit string manipulation 06oct92py \ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, @@ -118,8 +112,14 @@ NIL AConstant NIL \ gforth LOOP ; \ !! this is machine-dependent, but works on all but the strangest machines -' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth -' falign Alias maxalign ( -- ) \ gforth + +: maxaligned ( addr -- f-addr ) \ float + [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ; +: maxalign ( -- ) \ float + here dup maxaligned swap + ?DO + bl c, + LOOP ; \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned" ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth @@ -178,18 +178,6 @@ $20 constant restrict-mask : bounds ( beg count -- end beg ) \ gforth over + swap ; -: save-mem ( addr1 u -- addr2 u ) \ gforth - \g 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 @@ -441,7 +429,7 @@ hex : #s ( +d -- 0 0 ) \ core number-sign-s BEGIN - # 2dup d0= + # 2dup or 0= UNTIL ; \ print numbers 07jun92py @@ -474,13 +462,26 @@ hex \ !! allow the user to add rollback actions anton \ !! use a separate exception stack? anton +has-locals [IF] : lp@ ( -- addr ) \ gforth l-p-fetch laddr# [ 0 , ] ; +[THEN] + +Defer 'catch +Defer 'throw + +' noop IS 'catch +' noop IS 'throw : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception + 'catch sp@ >r +[ has-floats [IF] ] fp@ >r +[ [THEN] ] +[ has-locals [IF] ] lp@ >r +[ [THEN] ] handler @ >r rp@ handler ! execute @@ -488,15 +489,24 @@ hex : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception ?DUP IF - [ here 9 cells ! ] \ entry point for signal handler + [ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler handler @ dup 0= IF +[ has-os [IF] ] 2 (bye) +[ [ELSE] ] + quit +[ [THEN] ] THEN rp! r> handler ! - r> lp! +[ has-locals [IF] ] + r> lp! +[ [THEN] ] +[ has-floats [IF] ] r> fp! +[ [THEN] ] r> swap >r sp! drop r> + 'throw THEN ; \ Bouncing is very fine, @@ -506,16 +516,24 @@ hex ?DUP IF handler @ rp! r> handler ! +[ has-locals [IF] ] r> lp! +[ [THEN] ] +[ has-floats [IF] ] rdrop +[ [THEN] ] rdrop + 'throw THEN ; \ ?stack 23feb93py : ?stack ( ?? -- ?? ) \ gforth - sp@ s0 @ > IF -4 throw THEN - fp@ f0 @ > IF -&45 throw THEN ; + sp@ s0 @ u> IF -4 throw THEN +[ has-floats [IF] ] + fp@ f0 @ u> IF -&45 throw THEN +[ [THEN] ] +; \ ?stack should be code -- it touches an empty stack! \ interpret 10mar92py @@ -587,291 +605,6 @@ Defer interpreter-notfound ( c-addr coun : ] ( -- ) \ core right-bracket ['] compiler IS parser state on ; -here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs -AConstant locals-list \ acts like a variable that contains - \ a linear list of locals names - - -variable dead-code \ true if normal code at "here" would be dead -variable backedge-locals - \ contains the locals list that BEGIN will assume to be live on - \ the back edge if the BEGIN is unreachable from above. Set by - \ ASSUME-LIVE, reset by UNREACHABLE. - -: UNREACHABLE ( -- ) \ gforth - \ declares the current point of execution as unreachable - dead-code on - 0 backedge-locals ! ; immediate - -: ASSUME-LIVE ( orig -- orig ) \ gforth - \ 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? - 2 pick backedge-locals ! ; immediate - -\ Control Flow Stack -\ orig, etc. have the following structure: -\ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS ) -\ address (of the branch or the instruction to be branched to) (second) -\ locals-list (valid at address) (third) - -\ types -0 constant defstart -1 constant live-orig -2 constant dead-orig -3 constant dest \ the loopback branch is always assumed live -4 constant do-dest -5 constant scopestart - -: def? ( n -- ) - defstart <> abort" unstructured " ; - -: orig? ( n -- ) - dup live-orig <> swap dead-orig <> and abort" expected orig " ; - -: dest? ( n -- ) - dest <> abort" expected dest " ; - -: do-dest? ( n -- ) - do-dest <> abort" expected do-dest " ; - -: scope? ( n -- ) - scopestart <> abort" expected scope " ; - -: non-orig? ( n -- ) - dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ; - -: cs-item? ( n -- ) - live-orig scopestart 1+ within 0= abort" expected control flow stack item" ; - -3 constant cs-item-size - -: CS-PICK ( ... u -- ... destu ) \ tools-ext - 1+ cs-item-size * 1- >r - r@ pick r@ pick r@ pick - rdrop - dup non-orig? ; - -: CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) \ tools-ext - 1+ cs-item-size * 1- >r - r@ roll r@ roll r@ roll - rdrop - dup cs-item? ; - -: cs-push-part ( -- list addr ) - locals-list @ here ; - -: cs-push-orig ( -- orig ) - cs-push-part dead-code @ - if - dead-orig - else - live-orig - then ; - -\ Structural Conditionals 12dec92py - -: ?struc ( flag -- ) abort" unstructured " ; -: sys? ( sys -- ) dup 0= ?struc ; -: >mark ( -- orig ) - cs-push-orig 0 , ; -: >resolve ( addr -- ) here over - swap ! ; -: mark POSTPONE unreachable ; immediate restrict - -: IF ( compilation -- orig ; run-time f -- ) \ core - POSTPONE ?branch >mark ; immediate restrict - -: ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if -\G This is the preferred alternative to the idiom "?DUP IF", since it can be -\G better handled by tools like stack checkers. Besides, it's faster. - POSTPONE ?dup-?branch >mark ; immediate restrict - -: ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-zero-equals-if - POSTPONE ?dup-0=-?branch >mark ; immediate restrict - -Defer then-like ( orig -- addr ) -: cs>addr ( orig/dest -- addr ) drop nip ; -' cs>addr IS then-like - -: THEN ( compilation orig -- ; run-time -- ) \ core - dup orig? then-like >resolve ; immediate restrict - -' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth -immediate restrict -\ Same as "THEN". This is what you use if your program will be seen by -\ people who have not been brought up with Forth (or who have been -\ brought up with fig-Forth). - -: ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core - POSTPONE ahead - 1 cs-roll - POSTPONE then ; immediate restrict - -Defer begin-like ( -- ) -' noop IS begin-like - -: BEGIN ( compilation -- dest ; run-time -- ) \ core - begin-like cs-push-part dest ; immediate restrict - -Defer again-like ( dest -- addr ) -' nip IS again-like - -: AGAIN ( compilation dest -- ; run-time -- ) \ core-ext - dest? again-like POSTPONE branch leave ( orig -- ) - \ push on leave-stack - leave-sp @ - dup [ leave-stack 60 cells + ] Aliteral - >= abort" leave-stack full" - tuck ! cell+ - tuck ! cell+ - tuck ! cell+ - leave-sp ! ; - -: leave> ( -- orig ) - \ pop from leave-stack - leave-sp @ - dup leave-stack <= IF - drop 0 0 0 EXIT THEN - cell - dup @ swap - cell - dup @ swap - cell - dup @ swap - leave-sp ! ; - -: DONE ( compilation orig -- ; run-time -- ) \ gforth - \ !! the original done had ( addr -- ) - drop >r drop - begin - leave> - over r@ u>= - while - POSTPONE then - repeat - >leave rdrop ; immediate restrict - -: LEAVE ( compilation -- ; run-time loop-sys -- ) \ core - POSTPONE ahead - >leave ; immediate restrict - -: ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth question-leave - POSTPONE 0= POSTPONE if - >leave ; immediate restrict - -: DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core - POSTPONE (do) - POSTPONE begin drop do-dest - ( 0 0 0 >leave ) ; immediate restrict - -: ?do-like ( -- do-sys ) - ( 0 0 0 >leave ) - >mark >leave - POSTPONE begin drop do-dest ; - -: ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ core-ext question-do - POSTPONE (?do) ?do-like ; immediate restrict - -: +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth plus-do - POSTPONE (+do) ?do-like ; immediate restrict - -: U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-plus-do - POSTPONE (u+do) ?do-like ; immediate restrict - -: -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys ) \ gforth minus-do - POSTPONE (-do) ?do-like ; immediate restrict - -: U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth u-minus-do - POSTPONE (u-do) ?do-like ; immediate restrict - -: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth - POSTPONE (for) - POSTPONE begin drop do-dest - ( 0 0 0 >leave ) ; immediate restrict - -\ LOOP etc. are just like UNTIL - -: loop-like ( do-sys xt1 xt2 -- ) - >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? - until-like POSTPONE done POSTPONE unloop ; - -: LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ core - ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict - -: +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core plus-loop - ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict - -\ !! should the compiler warn about +DO..-LOOP? -: -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth minus-loop - ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict - -\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" -\ will iterate as often as "high low ?DO inc S+LOOP". For positive -\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for -\ negative increments. -: S+LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ gforth s-plus-loop - ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict - -: NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth - ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict - -\ Structural Conditionals 12dec92py - -Defer exit-like ( -- ) -' noop IS exit-like - -: EXIT ( compilation -- ; run-time nest-sys -- ) \ core - exit-like - POSTPONE ;s - POSTPONE unreachable ; immediate restrict - -: ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth - POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict - \ Strings 22feb93py : ," ( "string"<"> -- ) [char] " parse @@ -884,13 +617,8 @@ Defer exit-like ( -- ) postpone (S") here over char+ allot place align ; immediate restrict : ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren - BEGIN - >in @ [char] ) parse nip >in @ rot - = - WHILE - loadfile @ IF - refill 0= abort" missing ')' in paren comment" - THEN - REPEAT ; immediate + [char] ) parse 2drop ; immediate + : \ ( -- ) \ core-ext backslash blk @ IF @@ -1019,12 +747,17 @@ Create ??? 0 , 3 c, char ? c, char ? c, : !does ( addr -- ) \ gforth store-does lastxt does-code! ; : (does>) ( R: addr -- ) - r> /does-handler + !does ; + r> cfaligned /does-handler + !does ; : dodoes, ( -- ) - here /does-handler allot does-handler! ; + cfalign here /does-handler allot does-handler! ; +doer? :dovar [IF] : Create ( "name" -- ) \ core Header reveal dovar: cfa, ; +[ELSE] +: Create ( "name" -- ) \ core + Header reveal here lastcfa ! 0 A, 0 , DOES> ; +[THEN] \ Create Variable User Constant 17mar93py @@ -1032,15 +765,26 @@ Create ??? 0 , 3 c, char ? c, char ? c, Create 0 , ; : AVariable ( "name" -- ) \ gforth Create 0 A, ; -: 2VARIABLE ( "name" -- ) \ double +: 2Variable ( "name" -- ) \ double create 0 , 0 , ; - + +: uallot ( n -- ) udp @ swap udp +! ; + +doer? :douser [IF] : User ( "name" -- ) \ gforth - Variable ; + Header reveal douser: cfa, cell uallot , ; : AUser ( "name" -- ) \ gforth - AVariable ; - -: (Constant) Header reveal docon: cfa, ; + User ; +[ELSE] +: User Create uallot , DOES> @ up @ + ; +: AUser User ; +[THEN] + +doer? :docon [IF] + : (Constant) Header reveal docon: cfa, ; +[ELSE] + : (Constant) Create DOES> @ ; +[THEN] : Constant ( w "name" -- ) \ core \G Defines constant @var{name} \G @@ -1048,6 +792,8 @@ Create ??? 0 , 3 c, char ? c, char ? c, (Constant) , ; : AConstant ( addr "name" -- ) \ gforth (Constant) A, ; +: Value ( w "name" -- ) \ core-ext + (Constant) , ; : 2Constant ( w1 w2 "name" -- ) \ double Create ( w1 w2 "name" -- ) @@ -1055,16 +801,23 @@ Create ??? 0 , 3 c, char ? c, char ? c, DOES> ( -- w1 w2 ) 2@ ; +doer? :dofield [IF] + : (Field) Header reveal dofield: cfa, ; +[ELSE] + : (Field) Create DOES> @ + ; +[THEN] \ IS Defer What's Defers TO 24feb93py +doer? :dodefer [IF] : Defer ( "name" -- ) \ gforth \ !! shouldn't it be initialized with abort or something similar? Header Reveal dodefer: cfa, ['] noop A, ; -\ Create ( -- ) -\ ['] noop A, -\ DOES> ( ??? ) -\ perform ; +[ELSE] +: Defer ( "name" -- ) \ gforth + Create ['] noop A, +DOES> @ execute ; +[THEN] : Defers ( "name" -- ) \ gforth ' >body @ compile, ; immediate @@ -1164,7 +917,7 @@ end-struct interpret/compile-struct (cfa>int) ; : name>comp ( nt -- w xt ) \ gforth - \G @var{w xt} is the compilation token wor the word @var{nt}. + \G @var{w xt} is the compilation token for the word @var{nt}. (name>x) >r dup interpret/compile? if interpret/compile-comp @ @@ -1297,7 +1050,7 @@ G -1 warnings T ! dup IF #bs emit bl emit #bs emit 1- rot 1- -rot THEN false ; -: (ret) true space ; +: (ret) true bl emit ; Create ctrlkeys ] false false false false false false false false @@ -1320,25 +1073,26 @@ defer everychar : accept ( addr len -- len ) \ core dup 0< IF abs over dup 1 chars - c@ tuck type \ this allows to edit given strings - ELSE 0 THEN rot over + ELSE 0 THEN rot over BEGIN key decode UNTIL 2drop nip ; \ Output 13feb93py +has-os [IF] +0 Value outfile-id ( -- file-id ) \ gforth + : (type) ( c-addr u -- ) \ gforth outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? ; -Defer type ( c-addr u -- ) \ core -\ defer type for a output buffer or fast -\ screen write - -' (type) IS Type - : (emit) ( c -- ) \ gforth outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? ; +[THEN] + +Defer type ( c-addr u -- ) \ core +' (type) IS Type Defer emit ( c -- ) \ core ' (Emit) IS Emit @@ -1348,215 +1102,46 @@ Defer key ( -- c ) \ core \ Query 07apr93py +has-files 0= [IF] +: sourceline# ( -- n ) loadline @ ; +[THEN] + : refill ( -- flag ) \ core-ext,block-ext,file-ext blk @ IF 1 blk +! true 0 >in ! EXIT THEN tib /line +[ has-files [IF] ] loadfile @ ?dup IF read-line throw - ELSE sourceline# 0< IF 2drop false EXIT THEN - accept true + ELSE +[ [THEN] ] + sourceline# 0< IF 2drop false EXIT THEN + accept true +[ has-files [IF] ] THEN +[ [THEN] ] 1 loadline +! swap #tib ! 0 >in ! ; : query ( -- ) \ core-ext \G obsolescent + blk off loadfile off tib /line accept #tib ! 0 >in ! ; -\ File specifiers 11jun93jaw - - -\ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c, -\ 2 c, here char r c, char + c, 0 c, -\ 2 c, here char w c, char + c, 0 c, align -4 Constant w/o ( -- fam ) \ file w-o -2 Constant r/w ( -- fam ) \ file r-w -0 Constant r/o ( -- fam ) \ file r-o - -\ BIN WRITE-LINE 11jun93jaw - -\ : bin dup 1 chars - c@ -\ r/o 4 chars + over - dup >r swap move r> ; +\ save-mem extend-mem -: bin ( fam1 -- fam2 ) \ file - 1 or ; - -create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos - \ or not unix environments if - \ bin is not selected - -: write-line ( c-addr u fileid -- ior ) \ file - dup >r write-file - ?dup IF - r> drop EXIT - THEN - nl$ count r> write-file ; - -\ include-file 07apr93py - -: push-file ( -- ) r> - sourceline# >r loadfile @ >r - blk @ >r tibstack @ >r >tib @ >r #tib @ >r - >tib @ tibstack @ = IF r@ tibstack +! THEN - tibstack @ >tib ! >in @ >r >r ; - -: pop-file ( throw-code -- throw-code ) - dup IF - source >in @ sourceline# sourcefilename - error-stack dup @ dup 1+ - max-errors 1- min error-stack ! - 6 * cells + cell+ - 5 cells bounds swap DO - I ! - -1 cells +LOOP - THEN - r> - r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> blk ! - r> loadfile ! r> loadline ! >r ; - -: read-loop ( i*x -- j*x ) - BEGIN refill WHILE interpret REPEAT ; - -: include-file ( i*x fid -- j*x ) \ file - push-file loadfile ! - 0 loadline ! blk off ['] read-loop catch - loadfile @ close-file swap 2dup or - pop-file drop throw throw ; - -create pathfilenamebuf 256 chars allot \ !! make this grow on demand - -\ : check-file-prefix ( addr len -- addr' len' flag ) -\ dup 0= IF true EXIT THEN -\ over c@ '/ = IF true EXIT THEN -\ over 2 S" ./" compare 0= IF true EXIT THEN -\ over 3 S" ../" compare 0= IF true EXIT THEN -\ over 2 S" ~/" compare 0= -\ IF 1 /string -\ S" HOME" getenv tuck pathfilenamebuf swap move -\ 2dup + >r pathfilenamebuf + swap move -\ pathfilenamebuf r> true -\ ELSE false -\ THEN ; - -: absolut-path? ( addr u -- flag ) \ gforth - \G a path is absolute, if it starts with a / or a ~ (~ expansion), - \G or if it is in the form ./* or ../*, extended regexp: ^[/~]|./|../ - \G 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 - \G opens a file for reading, searching in the path for it (unless - \G the filename contains a slash); c-addr2 u2 is the full filename - \G (valid until the next call); if the file is not found (or in - \G case of other errors for each try), -38 (non-existant file) is - \G thrown. Opening for other access modes makes little sense, as - \G the path will usually contain dirs that are only readable for - \G the user - \ !! use file-status to determine access mode? - 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 ) - pathfilenamebuf r> EXIT - then - pathdirs 2@ 0 -\ check-file-prefix 0= -\ IF pathdirs 2@ 0 - ?DO ( c-addr1 u1 dirnamep ) - dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u ) - 2dup pathfilenamebuf r@ chars + swap cmove ( addr u ) - pathfilenamebuf over r> + dup >r r/o open-file 0= - IF ( addr u file-id ) - nip nip r> rdrop 0 LEAVE - THEN - rdrop drop r> cell+ cell+ - LOOP -\ ELSE 2dup open-file throw -rot THEN - 0<> -&38 and throw ( file-id u2 ) - pathfilenamebuf swap ; - -create included-files 0 , 0 , ( pointer to and count of included files ) -here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells - -create image-included-files 1 , A, ( pointer to and count of included files ) -\ included-files points to ALLOCATEd space, while image-included-files -\ points to ALLOTed objects, so it survives a save-system - -: loadfilename ( -- a-addr ) - \G a-addr 2@ produces the current file name ( c-addr u ) - included-files 2@ drop loadfilename# @ 2* cells + ; - -: sourcefilename ( -- c-addr u ) \ gforth - \G the name of the source file which is currently the input - \G source. The result is valid only while the file is being - \G loaded. If the current input source is no (stream) file, the - \G result is undefined. - loadfilename 2@ ; - -: sourceline# ( -- u ) \ gforth sourceline-number - \G the line number of the line that is currently being interpreted - \G from a (stream) file. The first line has the number 1. If the - \G current input source is no (stream) file, the result is - \G undefined. - loadline @ ; - -: init-included-files ( -- ) - image-included-files 2@ 2* cells save-mem drop ( addr ) - image-included-files 2@ nip included-files 2! ; - -: included? ( c-addr u -- f ) \ gforth - \G true, iff filename c-addr u is in included-files - included-files 2@ 0 - ?do ( c-addr u addr ) - dup >r 2@ 2over compare 0= - if - 2drop rdrop unloop - true EXIT - then - r> cell+ cell+ - loop - 2drop drop false ; - -: add-included-file ( c-addr u -- ) \ gforth - \G add name c-addr u to included-files - 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 - \G include the file file-id with the name given by c-addr u - loadfilename# @ >r - save-mem add-included-file ( file-id ) - included-files 2@ nip 1- loadfilename# ! - ['] include-file catch - r> loadfilename# ! - throw ; - -: included ( i*x addr u -- j*x ) \ file - open-path-file included1 ; +has-os [IF] +: save-mem ( addr1 u -- addr2 u ) \ gforth + \g copy a memory block into a newly allocated region in the heap + swap >r + dup allocate throw + swap 2dup r> -rot move ; -: required ( i*x addr u -- j*x ) \ gforth - \G include the file with the name given by addr u, if it is not - \G included already. Currently this works by comparing the name of - \G the file (with path) against the names of earlier included - \G files; however, it would probably be better to fstat the file, - \G and compare the device and inode. The advantages would be: no - \G problems with several paths to the same file (e.g., due to - \G links) and we would catch files included with include-file and - \G write a require-file. - open-path-file 2dup included? - if - 2drop close-file throw - else - included1 - then ; +: 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 ; +[THEN] \ HEX DECIMAL 2may93jaw @@ -1572,14 +1157,6 @@ create image-included-files 1 , A, ( po : clearstack ( ... -- ) s0 @ sp! ; -\ INCLUDE 9may93jaw - -: include ( "file" -- ) \ gforth - name included ; - -: require ( "file" -- ) \ gforth - name required ; - \ RECURSE 17may93jaw : recurse ( compilation -- ; run-time ?? -- ?? ) \ core @@ -1598,6 +1175,17 @@ create image-included-files 1 , A, ( po \ EVALUATE 17may93jaw +has-files 0= [IF] +: push-file ( -- ) r> + sourceline# >r tibstack @ >r >tib @ >r #tib @ >r + >tib @ tibstack @ = IF r@ tibstack +! THEN + tibstack @ >tib ! >in @ >r >r ; + +: pop-file ( throw-code -- throw-code ) + r> + r> >in ! r> #tib ! r> >tib ! r> tibstack ! r> loadline ! >r ; +[THEN] + : evaluate ( c-addr len -- ) \ core,block push-file #tib ! >tib ! >in off blk off loadfile off -1 loadline ! @@ -1617,7 +1205,7 @@ Defer .status : prompt state @ IF ." compiled" EXIT THEN ." ok" ; : (Query) ( -- ) loadfile off blk off refill drop ; -: (quit) BEGIN .status cr (query) interpret prompt AGAIN ; +: (quit) BEGIN .status cr (query) interpret prompt AGAIN ; ' (quit) IS 'quit \ DOERROR (DOERROR) 13jun93jaw @@ -1642,8 +1230,8 @@ max-errors 6 * cells allot : typewhite ( addr u -- ) \ gforth \ like type, but white space is printed instead of the characters bounds ?do - i c@ 9 = if \ check for tab - 9 + i c@ #tab = if \ check for tab + #tab else bl then @@ -1713,87 +1301,29 @@ DEFER DOERROR \ : .name ( name -- ) name>string type space ; \ : words listwords @ \ BEGIN @ dup WHILE dup .name REPEAT drop ; - -: cstring>sstring ( cstring -- addr n ) \ gforth cstring-to-sstring - -1 0 scan 0 swap 1+ /string ; -: arg ( n -- addr count ) \ gforth - cells argv @ + @ cstring>sstring ; -: #! postpone \ ; immediate - -Create pathstring 2 cells allot \ string -Create pathdirs 2 cells allot \ dir string array, pointer and count -Variable argv -Variable argc - -0 Value script? ( -- flag ) - -: process-path ( addr1 u1 -- addr2 u2 ) - \ addr1 u1 is a path string, addr2 u2 is an array of dir strings - align here >r - BEGIN - over >r 0 scan - over r> tuck - ( rest-str this-str ) - dup - IF - 2dup 1- chars + c@ [char] / <> - IF - 2dup chars + [char] / swap c! - 1+ - THEN - 2, - ELSE - 2drop - THEN - dup - WHILE - 1 /string - REPEAT - 2drop - here r> tuck - 2 cells / ; - -: do-option ( addr1 len1 addr2 len2 -- n ) - 2swap - 2dup s" -e" compare 0= >r - 2dup s" --evaluate" compare 0= r> or - IF 2drop dup >r ['] evaluate catch - ?dup IF dup >r DoError r> negate (bye) THEN - r> >tib +! 2 EXIT THEN - ." Unknown option: " type cr 2drop 1 ; - -: process-args ( -- ) - >tib @ >r - argc @ 1 - ?DO - I arg over c@ [char] - <> - IF - required 1 - ELSE - I 1+ argc @ = IF s" " ELSE I 1+ arg THEN - do-option - THEN - +LOOP - r> >tib ! ; - Defer 'cold ' noop IS 'cold : cold ( -- ) \ gforth - stdout TO outfile-id +[ has-files [IF] ] pathstring 2@ process-path pathdirs 2! init-included-files +[ [THEN] ] 'cold +[ has-files [IF] ] argc @ 1 > IF - true to script? ['] process-args catch ?dup IF dup >r DoError cr r> negate (bye) THEN cr THEN - false to script? +[ [THEN] ] ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr - ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr - ." Type `bye' to exit" + ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" +[ has-os [IF] ] + cr ." Type `bye' to exit" +[ [THEN] ] loadline off quit ; : license ( -- ) \ gforth @@ -1813,16 +1343,43 @@ Defer 'cold ' noop IS 'cold ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; : boot ( path **argv argc -- ) - argc ! argv ! pathstring 2! main-task up! - sp@ s0 ! - lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off - rp@ r0 ! - fp@ f0 ! - ['] cold catch DoError - bye ; + main-task up! +[ has-os [IF] ] + stdout TO outfile-id +[ [THEN] ] +[ has-files [IF] ] + argc ! argv ! pathstring 2! +[ [THEN] ] + sp@ s0 ! +[ has-locals [IF] ] + lp@ forthstart 7 cells + @ - +[ [ELSE] ] + [ has-os [IF] ] + sp@ $1040 + + [ [ELSE] ] + sp@ $40 + + [ [THEN] ] +[ [THEN] ] + dup >tib ! tibstack ! #tib off >in off + rp@ r0 ! +[ has-floats [IF] ] + fp@ f0 ! +[ [THEN] ] + ['] cold catch DoError +[ has-os [IF] ] + bye +[ [THEN] ] +; +has-os [IF] : bye ( -- ) \ tools-ext - script? 0= IF cr THEN 0 (bye) ; +[ has-files [IF] ] + script? 0= IF cr THEN +[ [ELSE] ] + cr +[ [THEN] ] + 0 (bye) ; +[THEN] \ **argv may be scanned by the C starter to get some important \ information, as -display and -geometry for an X client FORTH