--- gforth/Attic/kernal.fs 1994/09/12 19:00:32 1.20 +++ gforth/Attic/kernal.fs 1995/04/30 23:18:23 1.36 @@ -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,14 +153,14 @@ 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 @@ -162,6 +173,12 @@ Defer source 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 ; @@ -173,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 sfind dup 0= abort" Can't compile " - 0> IF A, ELSE postpone (compile) A, THEN ; + 0> IF compile, ELSE postpone (compile) A, THEN ; immediate restrict \ Use (compile) for the old behavior of compile! @@ -244,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 ; @@ -355,7 +375,7 @@ Defer notfound ( c-addr count -- ) IF 1 and IF \ not restricted to compile state? - nip nip execute EXIT + nip nip execute EXIT THEN -&14 throw THEN @@ -417,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 ) @@ -546,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 @@ -588,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 @@ -614,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>= @@ -746,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 @@ -761,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 @@ -794,10 +837,13 @@ Avariable leave-sp leave-stack 3 cells 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 - dup $1F u> -&19 and throw ( is name too long? ) - dup c, here swap chars dup allot move align ; + name name-too-short? name-too-long? + string, cfalign ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -816,19 +862,19 @@ 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) ; : noname-header ( -- ) - 0 last ! + 0 last ! cfalign input-stream ; : noname ( -- ) \ general @@ -848,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 @@ -894,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 @@ -957,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) ; @@ -981,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 ! @@ -1015,9 +1062,9 @@ 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 sfind 0= if -&13 bounce then ; : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate @@ -1033,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 ) @@ -1050,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 ; @@ -1124,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,6 +1215,19 @@ 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 @@ -1172,28 +1236,72 @@ create pathfilenamebuf 256 chars allot \ \ makes little sense, as the path will usually contain dirs that \ are only readable for the user \ !! check for "/", "./", "../" in original filename; check for "~/"? - 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 ) + IF ( addr u file-id ) nip nip r> rdrop 0 leave - then + 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 + save-string 2dup loadfilename 2! add-included-file ( file-id ) ['] include-file catch - \ don't free filenames; they don't take much space - \ and are used for debugging 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 @@ -1203,12 +1311,16 @@ create pathfilenamebuf 256 chars allot \ \ DEPTH 9may93jaw : depth ( -- +n ) sp@ s0 @ swap - cell / ; +: clearstack ( ... -- ) s0 @ sp! ; \ INCLUDE 9may93jaw : include ( "file" -- ) name included ; +: require ( "file" -- ) + name required ; + \ RECURSE 17may93jaw : recurse ( -- ) @@ -1372,27 +1484,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 @@ -1404,7 +1525,7 @@ Variable argc ." GNU Forth 0.0alpha, 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 @@ -1423,7 +1544,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) ;