--- gforth/Attic/kernal.fs 1995/11/09 18:06:20 1.47 +++ gforth/Attic/kernal.fs 1996/05/09 18:13:02 1.58 @@ -76,15 +76,15 @@ HEX \ Bit string manipulation 06oct92py -Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, -DOES> ( n -- ) + c@ ; +\ Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, +\ DOES> ( n -- ) + c@ ; -: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; -: +bit ( addr n -- ) >bit over c@ or swap c! ; +\ : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ; +\ : +bit ( addr n -- ) >bit over c@ or swap c! ; -: relinfo ( -- addr ) forthstart dup @ + ; -: >rel ( addr -- n ) forthstart - ; -: relon ( addr -- ) relinfo swap >rel cell / +bit ; +\ : relinfo ( -- addr ) forthstart dup @ + !!bug!! ; +\ : >rel ( addr -- n ) forthstart - ; +\ : relon ( addr -- ) relinfo swap >rel cell / +bit ; \ here allot , c, A, 17dec92py @@ -128,10 +128,13 @@ DOES> ( n -- ) + c@ ; ; immediate -: A! ( addr1 addr2 -- ) \ gforth - dup relon ! ; -: A, ( addr -- ) \ gforth - here cell allot A! ; +\ : A! ( addr1 addr2 -- ) \ gforth +\ dup relon ! ; +\ : A, ( addr -- ) \ gforth +\ here cell allot A! ; +' ! alias A! ( addr1 addr2 -- ) \ gforth +' , alias A, ( addr -- ) \ gforth + \ on off 23feb93py @@ -142,8 +145,8 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py -: (name>) ( nfa -- cfa ) - count $1F and + cfaligned ; +: (name>) ( nfa+cell -- cfa ) + 1 cells - name>string + cfaligned ; : name> ( nfa -- cfa ) \ gforth cell+ dup (name>) swap c@ $80 and 0= IF @ THEN ; @@ -158,7 +161,7 @@ DOES> ( n -- ) + c@ ; \ : (find) ( addr count nfa1 -- nfa2 / false ) \ BEGIN dup WHILE dup >r -\ cell+ count $1F and dup >r 2over r> = +\ name>string dup >r 2over r> = \ IF -text 0= IF 2drop r> EXIT THEN \ ELSE 2drop drop THEN r> @ \ REPEAT nip nip ; @@ -244,16 +247,14 @@ 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, ; @@ -450,7 +451,7 @@ hex : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception ?DUP IF - [ here 4 cells ! ] + [ here 9 cells ! ] handler @ rp! r> handler ! r> lp! @@ -489,6 +490,11 @@ Defer notfound ( c-addr count -- ) 2drop -&13 bounce ; ' no.extensions IS notfound +: compile-only ( ... -- ) + -&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 BEGIN @@ -508,7 +514,7 @@ Defer notfound ( c-addr count -- ) IF \ not restricted to compile state? nip nip execute EXIT THEN - -&14 throw + interpret-special exit THEN drop 2dup 2>r snumber? @@ -720,10 +726,11 @@ variable backedge-locals : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth question-dupe-if \ This is the preferred alternative to the idiom "?DUP IF", since it can be -\ better handled by tools like stack checkers - POSTPONE ?dup POSTPONE if ; immediate restrict +\ 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 POSTPONE 0= POSTPONE if ; immediate restrict + POSTPONE ?dup-0=-?branch >mark ; immediate restrict : THEN ( compilation orig -- ; run-time -- ) \ core dup orig? @@ -878,19 +885,19 @@ Avariable leave-sp leave-stack 3 cells : ?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 w1 w2 -- | loop-sys ) \ gforth plus-do +: +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 w1 w2 -- | loop-sys ) \ gforth u-plus-do +: 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 w1 w2 -- | loop-sys ) \ gforth minus-do +: -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 w1 w2 -- | loop-sys ) \ gforth u-minus-do +: 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 w -- loop-sys ) \ gforth +: FOR ( compilation -- do-sys ; run-time u -- loop-sys ) \ gforth POSTPONE (for) POSTPONE begin drop do-dest ( 0 0 0 >leave ) ; immediate restrict @@ -944,20 +951,18 @@ Avariable leave-sp leave-stack 3 cells 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 + [char] " parse postpone SLiteral ; immediate restrict : ." ( compilation 'ccc"' -- ; run-time -- ) \ core dot-quote - state @ IF postpone (.") ," align - ELSE [char] " parse type THEN ; immediate + postpone (.") ," align ; immediate restrict : ( ( compilation 'ccc' -- ; run-time -- ) \ core,file paren - [char] ) parse 2drop ; immediate + BEGIN + >in @ [char] ) parse nip >in @ rot - = + WHILE + loadfile @ IF + refill 0= abort" missing ')' in paren comment" + THEN + REPEAT ; immediate : \ ( -- ) \ core-ext backslash blk @ IF @@ -983,12 +988,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 $20 lastflags cset ; +: restrict $40 lastflags cset ; \ Header 23feb93py @@ -1010,7 +1023,7 @@ defer header ( -- ) \ gforth : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, - name, $80 flag! ; + name, $80 lastflags cset ; : input-stream ( -- ) \ general \ switches back to getting the name from the input stream ; @@ -1026,7 +1039,7 @@ create nextname-buffer 32 chars allot nextname-buffer count align here last ! -1 A, string, cfalign - $80 flag! + $80 lastflags cset input-stream ; \ the next name is given in the string @@ -1049,7 +1062,9 @@ create nextname-buffer 32 chars allot lastcfa @ ; : Alias ( cfa "name" -- ) \ gforth - Header reveal , $80 flag! ; + Header reveal + $80 lastflags creset + dup A, lastcfa ! ; : name>string ( nfa -- addr count ) \ gforth name-to-string cell+ count $1F and ; @@ -1084,13 +1099,8 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ 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 + ;-hook postpone (does>) ?struc dodoes, + defstart :-hook ; immediate restrict \ Create Variable User Constant 17mar93py @@ -1127,25 +1137,16 @@ Create ??? 0 , 3 c, char ? c, char ? c, \ Create ( -- ) \ ['] noop A, \ DOES> ( ??? ) -\ @ execute ; +\ perform ; : IS ( addr "name" -- ) \ gforth - ' >body - state @ - IF postpone ALiteral postpone ! - ELSE ! - THEN ; immediate + ' >body postpone ALiteral postpone ! ; immediate restrict ' IS Alias TO ( addr "name" -- ) \ core-ext -immediate +immediate restrict : What's ( "name" -- addr ) \ gforth - ' >body - state @ - IF - postpone ALiteral postpone @ - ELSE - @ - THEN ; immediate + ' >body postpone ALiteral postpone @ ; immediate restrict + : Defers ( "name" -- ) \ gforth ' >body @ compile, ; immediate @@ -1208,7 +1209,7 @@ AVariable lookup G forth-wordlist G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup wordlist-map @ find-method @ execute ; + dup wordlist-map @ find-method perform ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search (search-wordlist) dup IF found THEN ; @@ -1230,6 +1231,9 @@ G -1 warnings T ! then 2drop 2drop ; +: (sfind) ( c-addr u -- nfa | 0 ) + lookup @ (search-wordlist) ; + : sfind ( c-addr u -- xt n / 0 ) \ gforth lookup @ search-wordlist ; @@ -1243,15 +1247,15 @@ G -1 warnings T ! last? if name>string current @ check-shadow then - current @ wordlist-map @ reveal-method @ execute ; + current @ wordlist-map @ reveal-method perform ; : rehash ( wid -- ) - dup wordlist-map @ rehash-method @ execute ; + 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 + ' postpone ALiteral ; immediate restrict \ Input 13feb93py 07 constant #bell ( -- c ) \ gforth @@ -1264,8 +1268,14 @@ G -1 warnings T ! 0A constant #lf ( -- c ) \ gforth : bell #bell emit ; +: cr ( -- ) \ core + \ emit a newline + #lf ( sic! ) emit ; \ : backspaces 0 ?DO #bs emit LOOP ; + +Variable ^d-mode -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line + : >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 ) @@ -1281,7 +1291,11 @@ 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 ; +: eof ^d-mode @ IF + bye + ELSE 2 pick over <> + IF forw drop (del) ELSE #bell emit THEN 0 + THEN ; Create ctrlkeys ] false false back false eof false forw false @@ -1295,42 +1309,39 @@ defer everychar : decode ( max span addr pos1 key -- max span addr pos2 flag ) everychar dup #del = IF drop #bs THEN \ del is rubout - dup bl < IF cells ctrlkeys + @ execute EXIT THEN + 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 - : 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 - BEGIN key decode UNTIL + BEGIN key decode dup ^d-mode ! UNTIL 2drop nip ; \ Output 13feb93py +: (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) ( addr len -- ) -\ bounds ?DO I c@ emit LOOP ; - ' (type) IS Type +: (emit) ( c -- ) \ gforth + outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ? +; + Defer emit ( c -- ) \ core ' (Emit) IS Emit Defer key ( -- c ) \ core ' (key) IS key -\ : form ( -- rows cols ) &24 &80 ; -\ form should be implemented using TERMCAPS or CURSES -\ : rows form drop ; -\ : cols form nip ; - \ Query 07apr93py : refill ( -- flag ) \ core-ext,block-ext,file-ext @@ -1338,7 +1349,7 @@ Defer key ( -- c ) \ core tib /line loadfile @ ?dup IF read-line throw - ELSE loadline @ 0< IF 2drop false EXIT THEN + ELSE sourceline# 0< IF 2drop false EXIT THEN accept true THEN 1 loadline +! @@ -1355,8 +1366,8 @@ Defer key ( -- c ) \ core \ 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-o -0 Constant r/o ( -- fam ) \ file r-w +2 Constant r/w ( -- fam ) \ file r-w +0 Constant r/o ( -- fam ) \ file r-o \ BIN WRITE-LINE 11jun93jaw @@ -1380,14 +1391,14 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ include-file 07apr93py : push-file ( -- ) r> - loadline @ >r loadfile @ >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 @ loadline @ loadfilename 2@ + source >in @ sourceline# sourcefilename error-stack dup @ dup 1+ max-errors 1- min error-stack ! 6 * cells + cell+ @@ -1455,7 +1466,8 @@ create pathfilenamebuf 256 chars allot \ pathfilenamebuf swap ; create included-files 0 , 0 , ( pointer to and count of included files ) -create image-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 @@ -1463,6 +1475,20 @@ create image-included-files 0 , 0 , ( po \ a-addr 2@ produces the current file name ( c-addr u ) included-files 2@ drop loadfilename# @ 2* cells + ; +: sourcefilename ( -- c-addr u ) \ gforth + \ the name of the source file which is currently the input + \ source. The result is valid only while the file is being + \ loaded. If the current input source is no (stream) file, the + \ result is undefined. + loadfilename 2@ ; + +: sourceline# ( -- u ) \ gforth sourceline-number + \ the line number of the line that is currently being interpreted + \ from a (stream) file. The first line has the number 1. If the + \ current input source is no (stream) file, the result is + \ undefined. + loadline @ ; + : init-included-files ( -- ) image-included-files 2@ 2* cells save-string drop ( addr ) image-included-files 2@ nip included-files 2! ; @@ -1629,8 +1655,8 @@ DEFER DOERROR ; : (DoError) ( throw-code -- ) - loadline @ IF - source >in @ loadline @ 0 0 .error-frame + sourceline# IF + source >in @ sourceline# 0 0 .error-frame THEN error-stack @ 0 ?DO -1 error-stack +! @@ -1666,7 +1692,7 @@ DEFER DOERROR \ Cold 13feb93py -\ : .name ( name -- ) cell+ count $1F and type space ; +\ : .name ( name -- ) name>string type space ; \ : words listwords @ \ BEGIN @ dup WHILE dup .name REPEAT drop ; @@ -1733,6 +1759,7 @@ Variable argc Defer 'cold ' noop IS 'cold : cold ( -- ) \ gforth + stdout TO outfile-id pathstring 2@ process-path pathdirs 2! init-included-files 'cold @@ -1746,7 +1773,7 @@ Defer 'cold ' noop IS 'cold cr THEN false to script? - ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr + ." 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" loadline off quit ; @@ -1770,7 +1797,7 @@ Defer 'cold ' noop IS 'cold : boot ( path **argv argc -- ) argc ! argv ! cstring>sstring pathstring 2! main-task up! sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off - rp@ r0 ! fp@ f0 ! cold ; + rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; : bye ( -- ) \ tools-ext script? 0= IF cr THEN 0 (bye) ;