--- gforth/Attic/kernal.fs 1994/09/05 17:36:20 1.19 +++ gforth/Attic/kernal.fs 1995/06/07 10:05:06 1.38 @@ -1,4 +1,4 @@ -\ KERNAL.FS ANS figFORTH kernal 17dec92py +\ KERNAL.FS GNU FORTH kernal 17dec92py \ $ID: \ Idea and implementation: Bernd Paysan (py) \ Copyright 1992 by the ANSI figForth Development Group @@ -66,7 +66,16 @@ DOES> ( n -- ) + c@ ; bl c, LOOP ; +\ !! this is machine-dependent, but works on all but the strangest machines +' faligned Alias maxaligned +' falign Alias maxalign + +\ the code field is aligned if its body is maxaligned +\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned" +' maxaligned Alias cfaligned +' maxalign Alias cfalign +: chars ; immediate : A! ( addr1 addr2 -- ) dup relon ! ; : A, ( addr -- ) here cell allot A! ; @@ -78,9 +87,11 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py -: (name>) ( nfa -- cfa ) count $1F and + aligned ; -: name> ( nfa -- cfa ) cell+ - dup (name>) swap c@ $80 and 0= IF @ THEN ; +: (name>) ( nfa -- cfa ) + count $1F and + cfaligned ; +: name> ( nfa -- cfa ) + cell+ + dup (name>) swap c@ $80 and 0= IF @ THEN ; : found ( nfa -- cfa n ) cell+ dup c@ >r (name>) r@ $80 and 0= IF @ THEN @@ -142,27 +153,32 @@ Defer source \ word parse 23feb93py : parse-word ( char -- addr len ) - source 2dup >r >r >in @ /string + source 2dup >r >r >in @ over min /string rot dup bl = IF drop (parse-white) ELSE (word) THEN 2dup + r> - 1+ r> min >in ! ; : word ( char -- addr ) parse-word here place bl here count + c! here ; : parse ( char -- addr len ) - >r source >in @ /string over swap r> scan >r + >r source >in @ over min /string over swap r> scan >r over - dup r> IF 1+ THEN >in +! ; \ name 13feb93py -: capitalize ( addr -- addr ) - dup count chars bounds +: capitalize ( addr len -- addr len ) + 2dup chars chars bounds ?DO I c@ toupper I c! 1 chars +LOOP ; -: (name) ( -- addr ) bl word ; -: sname ( -- c-addr count ) +: (name) ( -- c-addr count ) source 2dup >r >r >in @ /string (parse-white) 2dup + r> - 1+ r> min >in ! ; \ name count ; +: name-too-short? ( c-addr u -- c-addr u ) + dup 0= -&16 and throw ; + +: name-too-long? ( c-addr u -- c-addr u ) + dup $1F u> -&19 and throw ; + \ Literal 17dec92py : Literal ( n -- ) state @ IF postpone lit , THEN ; @@ -174,10 +190,10 @@ Defer source : [char] ( 'char' -- n ) char postpone Literal ; immediate ' [char] Alias Ascii immediate -: (compile) ( -- ) r> dup cell+ >r @ A, ; +: (compile) ( -- ) r> dup cell+ >r @ compile, ; : postpone ( "name" -- ) - name find dup 0= abort" Can't compile " - 0> IF A, ELSE postpone (compile) A, THEN ; + name sfind dup 0= abort" Can't compile " + 0> IF compile, ELSE postpone (compile) A, THEN ; immediate restrict \ Use (compile) for the old behavior of compile! @@ -245,6 +261,9 @@ decimal Create spaces bl 80 times \ times from target compiler! 11may93jaw DOES> ( u -- ) swap 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; +Create backspaces 08 80 times \ times from target compiler! 11may93jaw +DOES> ( u -- ) swap + 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; hex : space 1 spaces ; @@ -342,21 +361,21 @@ Defer notfound ( c-addr count -- ) : interpret BEGIN - ?stack sname dup + ?stack name dup WHILE parser REPEAT 2drop ; -\ sinterpreter scompiler 30apr92py +\ interpreter compiler 30apr92py -: sinterpreter ( c-addr u -- ) +: interpreter ( c-addr u -- ) \ 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 + nip nip execute EXIT THEN -&14 throw THEN @@ -368,9 +387,9 @@ Defer notfound ( c-addr count -- ) 2r> notfound THEN ; -' sinterpreter IS parser +' interpreter IS parser -: scompiler ( c-addr u -- ) +: compiler ( c-addr u -- ) \ compilation semantics for the name/number c-addr u 2dup sfind dup IF @@ -393,17 +412,17 @@ Defer notfound ( c-addr count -- ) drop notfound THEN ; -: [ ['] sinterpreter IS parser state off ; immediate -: ] ['] scompiler IS parser state on ; +: [ ['] interpreter IS parser state off ; immediate +: ] ['] compiler IS parser state on ; \ locals stuff needed for control structures : compile-lp+! ( n -- ) dup negate locals-size +! 0 over = if - else -4 over = if postpone -4lp+! - else 8 over = if postpone 8lp+! - else 16 over = if postpone 16lp+! + else -1 cells over = if postpone lp- + else 1 floats over = if postpone lp+ + else 2 floats over = if postpone lp+2 else postpone lp+!# dup , then then then then drop ; @@ -418,11 +437,23 @@ AConstant locals-list \ acts like a vari variable dead-code \ true if normal code at "here" would be dead - -: unreachable ( -- ) -\ declares the current point of execution as unreachable - dead-code on ; - +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 ( -- ) + \ declares the current point of execution as unreachable + dead-code on + 0 backedge-locals ! ; immediate + +: ASSUME-LIVE ( orig -- orig ) + \ used immediateliy 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 + \ locals list operations : common-list ( list1 list2 -- list3 ) @@ -547,7 +578,7 @@ variable dead-code \ true if normal code \ Structural Conditionals 12dec92py : AHEAD ( -- orig ) - POSTPONE branch >mark unreachable ; immediate restrict + POSTPONE branch >mark POSTPONE unreachable ; immediate restrict : IF ( -- orig ) POSTPONE ?branch >mark ; immediate restrict @@ -561,18 +592,13 @@ variable dead-code \ true if normal code : THEN ( orig -- ) dup orig? - dead-code @ + dead-orig = if - dead-orig = - if - >resolve drop - else - >resolve set-locals-size-list dead-code off - then + >resolve drop else - dead-orig = - if - >resolve drop + dead-code @ + if + >resolve set-locals-size-list dead-code off else \ both live over list-size adjust-locals-size >resolve @@ -594,17 +620,10 @@ variable dead-code \ true if normal code : BEGIN ( -- dest ) dead-code @ if - \ set up an assumption of the locals visible here - \ currently we just take the top cs-item - \ it would be more intelligent to take the top orig - \ but that can be arranged by the user - dup defstart <> if - dup cs-item? - 2 pick - else - 0 - then - set-locals-size-list + \ set up an assumption of the locals visible here. if the + \ users want something to be visible, they have to declare + \ that using ASSUME-LIVE + backedge-locals @ set-locals-size-list then cs-push-part dest dead-code off ; immediate restrict @@ -620,7 +639,7 @@ variable dead-code \ true if normal code POSTPONE branch r drop +: DONE ( orig -- ) \ !! the original done had ( addr -- ) + drop >r drop begin leave> over r@ u>= @@ -752,7 +772,7 @@ Avariable leave-sp leave-stack 3 cells : EXIT ( -- ) 0 adjust-locals-size POSTPONE ;s - unreachable ; immediate restrict + POSTPONE unreachable ; immediate restrict : ?EXIT ( -- ) POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict @@ -767,13 +787,30 @@ Avariable leave-sp leave-stack 3 cells : (S") "lit count ; restrict : SLiteral postpone (S") here over char+ allot place align ; immediate restrict -: S" [char] " parse state @ IF postpone SLiteral THEN ; +create s"-buffer /line chars allot +: S" ( run-time: -- c-addr u ) + [char] " parse + state @ + IF + postpone SLiteral + ELSE + /line min >r s"-buffer r@ cmove + s"-buffer r> + THEN ; immediate : ." state @ IF postpone (.") ," align ELSE [char] " parse type THEN ; immediate : ( [char] ) parse 2drop ; immediate -: \ blk @ IF >in @ c/l / 1+ c/l * >in ! EXIT THEN - source >in ! drop ; immediate +: \ ( -- ) \ core-ext backslash + blk @ + IF + >in @ c/l / 1+ c/l * >in ! + EXIT + THEN + source >in ! drop ; immediate + +: \G ( -- ) \ new backslash + POSTPONE \ ; immediate \ error handling 22feb93py \ 'abort thrown out! 11may93jaw @@ -797,12 +834,16 @@ Avariable leave-sp leave-stack 3 cells \ information through global variables), but they are useful for dealing \ with existing/independent defining words -defer header +defer (header) +defer header ' (header) IS header + +: string, ( c-addr u -- ) + \ puts down string as cstring + dup c, here swap chars dup allot move ; : name, ( "name" -- ) - name c@ - dup $1F u> -&19 and throw ( is name too long? ) - 1+ chars allot align ; + name name-too-short? name-too-long? + string, cfalign ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -810,9 +851,9 @@ defer header : input-stream ( -- ) \ general \ switches back to getting the name from the input stream ; - ['] input-stream-header IS header ; + ['] input-stream-header IS (header) ; -' input-stream-header IS header +' input-stream-header IS (header) \ !! make that a 2variable create nextname-buffer 32 chars allot @@ -821,24 +862,24 @@ create nextname-buffer 32 chars allot \ !! f83-implementation-dependent nextname-buffer count align here last ! -1 A, - dup c, here swap chars dup allot move align + string, cfalign $80 flag! input-stream ; \ the next name is given in the string : nextname ( c-addr u -- ) \ general - dup $1F u> -&19 and throw ( is name too long? ) + name-too-long? nextname-buffer c! ( c-addr ) nextname-buffer count move - ['] nextname-header IS header ; + ['] nextname-header IS (header) ; : noname-header ( -- ) - 0 last ! + 0 last ! cfalign input-stream ; : noname ( -- ) \ general \ the next defined word remains anonymous. The xt of that word is given by lastxt - ['] noname-header IS header ; + ['] noname-header IS (header) ; : lastxt ( -- xt ) \ general \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname @@ -853,7 +894,7 @@ create nextname-buffer 32 chars allot Create ??? 0 , 3 c, char ? c, char ? c, char ? c, : >name ( cfa -- nfa ) $21 cell do - dup i - count $9F and + aligned over $80 + = if + dup i - count $9F and + cfaligned over $80 + = if i - cell - unloop exit then cell +loop @@ -899,10 +940,10 @@ Create ??? 0 , 3 c, char ? c, char ? c, : Constant (Constant) , ; : AConstant (Constant) A, ; -: 2CONSTANT - create ( w1 w2 "name" -- ) +: 2Constant + Create ( w1 w2 "name" -- ) 2, - does> ( -- w1 w2 ) + DOES> ( -- w1 w2 ) 2@ ; \ IS Defer What's Defers TO 24feb93py @@ -962,19 +1003,20 @@ AVariable current \ object oriented search list 17mar93py \ word list structure: -\ struct -\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) -\ 1 cells: field reveal-method \ xt: ( -- ) -\ 1 cells: field rehash-method \ xt: ( wid -- ) + +struct + 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) + 1 cells: field reveal-method \ xt: ( -- ) + 1 cells: field rehash-method \ xt: ( wid -- ) \ \ !! what else -\ end-struct wordlist-map-struct +end-struct wordlist-map-struct -\ struct -\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation -\ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct -\ 1 cells: field wordlist-link \ link field to other wordlists -\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) -\ end-struct wordlist-struct +struct + 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation + 1 cells: field wordlist-map \ pointer to a wordlist-map-struct + 1 cells: field wordlist-link \ link field to other wordlists + 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) +end-struct wordlist-struct : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; @@ -986,10 +1028,10 @@ AVariable lookup G forth-wordlist G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup cell+ @ @ execute ; + dup wordlist-map @ find-method @ execute ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) - (search-wordlist) dup IF found THEN ; + (search-wordlist) dup IF found THEN ; Variable warnings G -1 warnings T ! @@ -1020,11 +1062,11 @@ Variable warnings G -1 warnings T ! last? if name>string current @ check-shadow then - current @ cell+ @ cell+ @ execute ; + current @ wordlist-map @ reveal-method @ execute ; -: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; +: rehash ( wid -- ) dup wordlist-map @ rehash-method @ execute ; -: ' ( "name" -- addr ) name find 0= if drop -&13 bounce then ; +: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ; : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate \ Input 13feb93py @@ -1038,7 +1080,7 @@ Variable warnings G -1 warnings T ! : bell #bell emit ; -: backspaces 0 ?DO #bs emit LOOP ; +\ : 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 ) @@ -1055,15 +1097,19 @@ Variable warnings G -1 warnings T ! : 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 ; -Create crtlkeys +Create ctrlkeys ] false false back false false 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 [ +defer everychar +' noop IS 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 crtlkeys + @ execute EXIT THEN + dup bl < IF cells ctrlkeys + @ execute EXIT THEN >r 2over = IF rdrop bell 0 EXIT THEN r> (ins) 0 ; @@ -1129,7 +1175,7 @@ Defer key \ : bin dup 1 chars - c@ \ r/o 4 chars + over - dup >r swap move r> ; -: bin 1+ ; +: bin 1 or ; create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos \ or not unix environments if @@ -1164,41 +1210,106 @@ create nl$ 1 c, A c, 0 c, \ gnu includes : include-file ( i*x fid -- j*x ) push-file loadfile ! 0 loadline ! blk off ['] read-loop catch - loadfile @ close-file swap - pop-file throw throw ; + 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 ; + : 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 ; -: included ( i*x addr u -- j*x ) +create included-files 0 , 0 , ( pointer to and count of included files ) + +: included? ( c-addr u -- f ) + \ 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 -- ) + \ 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 ) + swap >r + dup allocate throw + swap 2dup r> -rot move ; + +: included1 ( i*x file-id c-addr u -- j*x ) + \ include the file file-id with the name given by c-addr u loadfilename 2@ >r >r - open-path-file ( file-id c-addr2 u2 ) - dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) - drop loadfilename 2@ move - include-file - \ don't free filenames; they don't take much space - \ and are used for debugging - r> r> loadfilename 2! ; + save-string 2dup loadfilename 2! add-included-file ( file-id ) + ['] include-file catch + r> r> loadfilename 2! throw ; + +: included ( i*x addr u -- j*x ) + open-path-file included1 ; + +: required ( i*x addr u -- j*x ) + \ include the file with the name given by addr u, if it is not + \ included already. Currently this works by comparing the name of + \ the file (with path) against the names of earlier included + \ files; however, it would probably be better to fstat the file, + \ and compare the device and inode. The advantages would be: no + \ problems with several paths to the same file (e.g., due to + \ links) and we would catch files included with include-file and + \ write a require-file. + open-path-file 2dup included? + if + 2drop close-file throw + else + included1 + then ; \ HEX DECIMAL 2may93jaw @@ -1208,11 +1319,15 @@ create pathfilenamebuf 256 chars allot \ \ DEPTH 9may93jaw : depth ( -- +n ) sp@ s0 @ swap - cell / ; +: clearstack ( ... -- ) s0 @ sp! ; \ INCLUDE 9may93jaw : include ( "file" -- ) - bl word count included ; + name included ; + +: require ( "file" -- ) + name required ; \ RECURSE 17may93jaw @@ -1289,10 +1404,10 @@ DEFER DOERROR ELSE type ." :" dec. cr dup 2over type cr drop - nip -trailing ( line-start index2 ) + nip -trailing 1- ( line-start index2 ) 0 >r BEGIN - 1- 2dup + c@ bl > WHILE - r> 1+ >r dup 0< UNTIL THEN 1+ + 2dup + c@ bl > WHILE + r> 1+ >r 1- dup 0< UNTIL THEN 1+ ( line-start index1 ) typewhite r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 @@ -1377,27 +1492,36 @@ Variable argc 2drop here r> tuck - 2 cells / ; -: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; - -: do-option ( addr1 len1 addr2 len2 -- n ) 2swap - 2dup s" -e" compare 0= >r - 2dup s" -evaluate" compare 0= r> or - IF 2drop ">tib interpret 2 EXIT THEN - ." Unknown option: " type cr 2drop 1 ; +: 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 + true to script? argc @ 1 ?DO I arg over c@ [char] - <> IF - true to script? included false to script? 1 + required 1 ELSE I 1+ arg do-option THEN - +LOOP ; + +LOOP + false to script? + r> >tib ! ; + +Defer 'cold ' noop IS 'cold : cold ( -- ) pathstring 2@ process-path pathdirs 2! + 0 0 included-files 2! + 'cold argc @ 1 > IF ['] process-args catch ?dup @@ -1406,10 +1530,10 @@ Variable argc THEN THEN cr - ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr + ." 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" - quit ; + loadline off quit ; : license ( -- ) cr ." This program is free software; you can redistribute it and/or modify" cr @@ -1428,7 +1552,8 @@ Variable argc : boot ( path **argv argc -- ) argc ! argv ! cstring>sstring pathstring 2! main-task up! - sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; + sp@ dup s0 ! $10 + >tib ! #tib off >in off + rp@ r0 ! fp@ f0 ! cold ; : bye script? 0= IF cr THEN 0 (bye) ;