--- gforth/Attic/kernal.fs 1995/04/20 09:42:55 1.35 +++ gforth/Attic/kernal.fs 1995/10/07 17:38:16 1.41 @@ -31,6 +31,32 @@ HEX +\ labels for some code addresses + +: docon: ( -- addr ) \ gforth + \ the code address of a @code{CONSTANT} + ['] bl >code-address ; + +: docol: ( -- addr ) \ gforth + \ the code address of a colon definition + ['] docon: >code-address ; + +: dovar: ( -- addr ) \ gforth + \ the code address of a @code{CREATE}d word + ['] udp >code-address ; + +: douser: ( -- addr ) \ gforth + \ the code address of a @code{USER} variable + ['] s0 >code-address ; + +: dodefer: ( -- addr ) \ gforth + \ the code address of a @code{defer}ed word + ['] source >code-address ; + +: dofield: ( -- addr ) \ gforth + \ the code address of a @code{field} + ['] reveal-method >code-address ; + \ Bit string manipulation 06oct92py Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, @@ -115,7 +141,7 @@ DOES> ( n -- ) + c@ ; \ input stream primitives 23feb93py : tib >tib @ ; -Defer source +Defer source \ used by dodefer:, must be defer : (source) ( -- addr count ) tib #tib @ ; ' (source) IS source @@ -346,7 +372,9 @@ hex \ ?stack 23feb93py -: ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ; +: ?stack ( ?? -- ?? ) + sp@ s0 @ > IF -4 throw THEN + fp@ f0 @ > IF -&45 throw THEN ; \ ?stack should be code -- it touches an empty stack! \ interpret 10mar92py @@ -734,11 +762,25 @@ Avariable leave-sp leave-stack 3 cells POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict -: ?DO ( -- do-sys ) +: ?do-like ( -- do-sys ) ( 0 0 0 >leave ) - POSTPONE (?do) >mark >leave - POSTPONE begin drop do-dest ; immediate restrict + POSTPONE begin drop do-dest ; + +: ?DO ( -- do-sys ) \ core-ext question-do + POSTPONE (?do) ?do-like ; immediate restrict + +: +DO ( -- do-sys ) \ gforth plus-do + POSTPONE (+do) ?do-like ; immediate restrict + +: U+DO ( -- do-sys ) \ gforth u-plus-do + POSTPONE (u+do) ?do-like ; immediate restrict + +: -DO ( -- do-sys ) \ gforth minus-do + POSTPONE (-do) ?do-like ; immediate restrict + +: U-DO ( -- do-sys ) \ gforth u-minus-do + POSTPONE (u-do) ?do-like ; immediate restrict : FOR ( -- do-sys ) POSTPONE (for) @@ -751,17 +793,21 @@ Avariable leave-sp leave-stack 3 cells >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? until-like POSTPONE done POSTPONE unloop ; -: LOOP ( do-sys -- ) +: LOOP ( do-sys -- ) \ core ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict -: +LOOP ( do-sys -- ) +: +LOOP ( do-sys -- ) \ core plus-loop ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict +\ !! should the compiler warn about +DO..-LOOP? +: -LOOP ( do-sys -- ) \ 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 ( do-sys -- ) +: S+LOOP ( do-sys -- ) \ gforth s-plus-loop ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict : NEXT ( do-sys -- ) @@ -900,31 +946,31 @@ Create ??? 0 , 3 c, char ? c, char ? c, cell +loop drop ??? ( wouldn't 0 be better? ) ; -\ indirect threading 17mar93py +\ threading 17mar93py -: cfa, ( code-address -- ) - here lastcfa ! - here 0 A, 0 , code-address! ; -: compile, ( xt -- ) A, ; -: !does ( addr -- ) lastcfa @ does-code! ; -: (;code) ( R: addr -- ) r> /does-handler + !does ; +: cfa, ( code-address -- ) \ gforth + here + dup lastcfa ! + 0 A, 0 , code-address! ; +: compile, ( xt -- ) \ core-ext + A, ; +: !does ( addr -- ) lastxt does-code! ; +: (does>) ( R: addr -- ) r> /does-handler + !does ; : dodoes, ( -- ) here /does-handler allot does-handler! ; -\ direct threading is implementation dependent - -: Create Header reveal [ :dovar ] Literal cfa, ; +: Create Header reveal dovar: cfa, ; \ DOES> 17mar93py -: DOES> ( compilation: -- ) +: DOES> ( compilation: -- ) \ core state @ IF - ;-hook postpone (;code) dodoes, + ;-hook postpone (does>) ?struc dodoes, ELSE - dodoes, here !does 0 ] + align dodoes, here !does ] THEN - :-hook ; immediate + defstart :-hook ; immediate \ Create Variable User Constant 17mar93py @@ -936,7 +982,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, : User Variable ; : AUser AVariable ; -: (Constant) Header reveal [ :docon ] Literal cfa, ; +: (Constant) Header reveal docon: cfa, ; : Constant (Constant) , ; : AConstant (Constant) A, ; @@ -950,7 +996,7 @@ Create ??? 0 , 3 c, char ? c, char ? c, : Defer ( -- ) \ !! shouldn't it be initialized with abort or something similar? - Header Reveal [ :dodefer ] Literal cfa, + Header Reveal dodefer: cfa, ['] noop A, ; \ Create ( -- ) \ ['] noop A, @@ -976,13 +1022,13 @@ Create ??? 0 , 3 c, char ? c, char ? c, defer :-hook ( sys1 -- sys2 ) defer ;-hook ( sys2 -- sys1 ) -: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; +: : ( -- colon-sys ) Header docol: cfa, defstart ] :-hook ; : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict : :noname ( -- xt colon-sys ) 0 last ! - here [ :docol ] Literal cfa, 0 ] :-hook ; + here docol: cfa, 0 ] :-hook ; \ Search list handling 23feb93py @@ -990,15 +1036,15 @@ AVariable current : last? ( -- false / nfa nfa ) last @ ?dup ; : (reveal) ( -- ) - last? - IF - dup @ 0< - IF - current @ @ over ! current @ ! - ELSE - drop - THEN - THEN ; + last? + IF + dup @ 0< + IF + current @ @ over ! current @ ! + ELSE + drop + THEN + THEN ; \ object oriented search list 17mar93py @@ -1006,7 +1052,7 @@ AVariable current struct 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) - 1 cells: field reveal-method \ xt: ( -- ) + 1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else end-struct wordlist-map-struct @@ -1096,9 +1142,10 @@ Variable warnings G -1 warnings T ! : (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 ; Create ctrlkeys - ] false false back false false false forw false + ] false false back false eof false forw false ?del false (ret) false false (ret) false false false false false false false false false false false false false false false false false false [ @@ -1148,7 +1195,7 @@ Defer key \ Query 07apr93py : refill ( -- flag ) - blk @ IF 1 blk +! true EXIT THEN + blk @ IF 1 blk +! true 0 >in ! EXIT THEN tib /line loadfile @ ?dup IF read-line throw @@ -1215,24 +1262,47 @@ create nl$ 1 c, A c, 0 c, \ gnu includes 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 ; + : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) - \ opens a file for reading, searching in the path for it; c-addr2 - \ u2 is the full filename (valid until the next call); if the file - \ is not found (or in case of other errors for each try), -38 - \ (non-existant file) is thrown. Opening for other access modes - \ makes little sense, as the path will usually contain dirs that - \ are only readable for the user - \ !! check for "/", "./", "../" in original filename; check for "~/"? + \ opens a file for reading, searching in the path for it (unless + \ the filename contains a slash); c-addr2 u2 is the full filename + \ (valid until the next call); if the file is not found (or in + \ case of other errors for each try), -38 (non-existant file) is + \ thrown. Opening for other access modes makes little sense, as + \ 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<> ) + 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 + 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 ; @@ -1311,7 +1381,7 @@ create included-files 0 , 0 , ( pointer : recurse ( -- ) lastxt compile, ; immediate restrict : recursive ( -- ) - reveal ; immediate + reveal last off ; immediate \ */MOD */ 17may93jaw @@ -1480,17 +1550,16 @@ Variable argc : process-args ( -- ) >tib @ >r - true to script? argc @ 1 ?DO I arg over c@ [char] - <> IF required 1 ELSE - I 1+ arg do-option + I 1+ argc @ = IF s" " ELSE I 1+ arg THEN + do-option THEN +LOOP - false to script? r> >tib ! ; Defer 'cold ' noop IS 'cold @@ -1501,13 +1570,15 @@ Defer 'cold ' noop IS 'cold 'cold argc @ 1 > IF + true to script? ['] process-args catch ?dup IF dup >r DoError cr r> negate (bye) THEN + cr THEN - cr - ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr + false to script? + ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr ." Type `bye' to exit" loadline off quit ;