--- gforth/Attic/kernel.fs 1997/02/08 22:58:10 1.14 +++ gforth/Attic/kernel.fs 1997/03/28 14:06:23 1.23 @@ -24,35 +24,52 @@ 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@ +' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch +\ copy w from the return stack to the data stack \ Bit string manipulation 06oct92py @@ -248,7 +265,7 @@ Defer source ( -- addr count ) \ core : (compile) ( -- ) \ gforth r> dup cell+ >r @ compile, ; -: postpone, ( w xt -- ) +: postpone, ( w xt -- ) \ gforth postpone-comma \g Compiles the compilation semantics represented by @var{w xt}. dup ['] execute = if @@ -473,7 +490,7 @@ Defer 'throw : 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) @@ -731,12 +748,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 @@ -744,15 +766,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 ; + User ; +[ELSE] +: User Create uallot , DOES> @ up @ + ; +: AUser User ; +[THEN] -: (Constant) Header reveal docon: cfa, ; +doer? :docon [IF] + : (Constant) Header reveal docon: cfa, ; +[ELSE] + : (Constant) Create DOES> @ ; +[THEN] : Constant ( w "name" -- ) \ core \G Defines constant @var{name} \G @@ -760,6 +793,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" -- ) @@ -767,16 +802,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 @@ -920,7 +962,7 @@ end-struct interpret/compile-struct then then ; -: find ( c-addr -- xt +-1 / c-addr 0 ) \ core +: find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search dup count sfind dup if rot drop @@ -996,7 +1038,10 @@ G -1 warnings T ! 0C constant #ff ( -- c ) \ gforth 0A constant #lf ( -- c ) \ gforth -: bell #bell emit ; +: bell ( -- ) \ gforth + \g makes a beep and flushes the output buffer + #bell emit + outfile-id flush-file drop ; : cr ( -- ) \ core \ emit a newline #lf ( sic! ) emit ; @@ -1220,6 +1265,10 @@ DEFER DOERROR ; : (DoError) ( throw-code -- ) + [ has-os [IF] ] + outfile-id dup flush-file drop >r + stderr to outfile-id + [ [THEN] ] sourceline# IF source >in @ sourceline# 0 0 .error-frame THEN @@ -1241,7 +1290,9 @@ DEFER DOERROR ELSE .error THEN - normal-dp dpp ! ; + normal-dp dpp ! + [ has-os [IF] ] r> to outfile-id [ [THEN] ] +; ' (DoError) IS DoError @@ -1260,24 +1311,24 @@ DEFER DOERROR \ : .name ( name -- ) name>string type space ; \ : words listwords @ \ BEGIN @ dup WHILE dup .name REPEAT drop ; -Defer 'cold ' noop IS 'cold +Defer 'cold ( -- ) \ gforth tick-cold +\ hook (deferred word) for things to do right before interpreting the +\ command-line arguments +' noop IS 'cold : cold ( -- ) \ gforth -[ has-os [IF] ] - stdout TO outfile-id -[ [THEN] ] [ has-files [IF] ] pathstring 2@ process-path pathdirs 2! init-included-files [ [THEN] ] 'cold [ has-files [IF] ] - argc @ 1 > + ['] process-args catch ?dup IF - ['] process-args catch ?dup - IF - dup >r DoError cr r> negate (bye) - THEN + dup >r DoError cr r> negate (bye) + THEN + argc @ 1 > + IF \ there may be some unfinished line, so let's finish it cr THEN [ [THEN] ] @@ -1305,10 +1356,13 @@ Defer 'cold ' noop IS 'cold ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; : boot ( path **argv argc -- ) + main-task up! +[ has-os [IF] ] + stdout TO outfile-id +[ [THEN] ] [ has-files [IF] ] argc ! argv ! pathstring 2! [ [THEN] ] - main-task up! sp@ s0 ! [ has-locals [IF] ] lp@ forthstart 7 cells + @ -