--- gforth/Attic/kernal.fs 1994/08/31 19:42:48 1.17 +++ gforth/Attic/kernal.fs 1994/10/18 15:51:19 1.21 @@ -110,12 +110,28 @@ Defer source \ (word) 22feb93py -: scan ( addr1 n1 char -- addr2 n2 ) >r - BEGIN dup WHILE over c@ r@ <> WHILE 1 /string - REPEAT THEN rdrop ; -: skip ( addr1 n1 char -- addr2 n2 ) >r - BEGIN dup WHILE over c@ r@ = WHILE 1 /string - REPEAT THEN rdrop ; +: scan ( addr1 n1 char -- addr2 n2 ) + \ skip all characters not equal to char + >r + BEGIN + dup + WHILE + over c@ r@ <> + WHILE + 1 /string + REPEAT THEN + rdrop ; +: skip ( addr1 n1 char -- addr2 n2 ) + \ skip all characters equal to char + >r + BEGIN + dup + WHILE + over c@ r@ = + WHILE + 1 /string + REPEAT THEN + rdrop ; : (word) ( addr1 n1 char -- addr2 n2 ) dup >r skip 2dup r> scan nip - ; @@ -138,11 +154,10 @@ Defer source \ 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 ; @@ -160,7 +175,7 @@ Defer source : (compile) ( -- ) r> dup cell+ >r @ A, ; : postpone ( "name" -- ) - name find dup 0= abort" Can't compile " + name sfind dup 0= abort" Can't compile " 0> IF A, ELSE postpone (compile) A, THEN ; immediate restrict @@ -326,15 +341,15 @@ 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 @@ -352,9 +367,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 @@ -377,17 +392,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 ; @@ -545,18 +560,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 @@ -782,12 +792,12 @@ Avariable leave-sp leave-stack 3 cells \ with existing/independent defining words defer (header) -defer header ' (header) IS header +defer header ' (header) IS header : name, ( "name" -- ) - name c@ + name dup $1F u> -&19 and throw ( is name too long? ) - 1+ chars allot align ; + dup c, here swap chars dup allot move align ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -967,11 +977,11 @@ AVariable current Create f83search ' f83find A, ' (reveal) A, ' drop A, Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, -AVariable search G forth-wordlist search T ! +AVariable lookup G forth-wordlist lookup T ! G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup ( @ swap ) cell+ @ @ execute ; + dup cell+ @ @ execute ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) (search-wordlist) dup IF found THEN ; @@ -993,7 +1003,7 @@ Variable warnings G -1 warnings T ! 2drop 2drop ; : sfind ( c-addr u -- xt n / 0 ) - search @ search-wordlist ; + lookup @ search-wordlist ; : find ( addr -- cfa +-1 / string false ) \ !! not ANS conformant: returns +-2 for restricted words @@ -1009,7 +1019,7 @@ Variable warnings G -1 warnings T ! : rehash ( wid -- ) dup cell+ @ cell+ cell+ @ 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 @@ -1017,8 +1027,8 @@ Variable warnings G -1 warnings T ! 08 constant #bs 09 constant #tab 7F constant #del -0C constant #ff 0D constant #cr \ the newline key code +0C constant #ff 0A constant #lf : bell #bell emit ; @@ -1040,15 +1050,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 +1143,17 @@ create nl$ 1 c, A c, 0 c, \ gnu includes loadline @ >r loadfile @ >r blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; -: pop-file ( -- ) r> +: pop-file ( throw-code -- throw-code ) + dup IF + source >in @ loadline @ loadfilename 2@ + error-stack dup @ dup 1+ + max-errors 1- min error-stack ! + 6 * cells + cell+ + 5 cells bounds swap DO + I ! + -1 cells +LOOP + THEN + r> r> >in ! r> #tib ! r> >tib ! r> blk ! r> loadfile ! r> loadline ! >r ; @@ -1139,17 +1163,41 @@ 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 - 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 + +: 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 "~/"? + 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 + rdrop drop r> cell+ cell+ + LOOP + 0<> -&38 and throw ( file-id u2 ) + pathfilenamebuf swap ; : included ( i*x addr u -- j*x ) loadfilename 2@ >r >r - dup allocate throw over loadfilename 2! - over loadfilename 2@ move - r/o open-file throw include-file + 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 catch \ don't free filenames; they don't take much space \ and are used for debugging - r> r> loadfilename 2! ; + r> r> loadfilename 2! throw ; \ HEX DECIMAL 2may93jaw @@ -1159,11 +1207,12 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ DEPTH 9may93jaw : depth ( -- +n ) sp@ s0 @ swap - cell / ; +: clearstack ( ... -- ) s0 @ sp! ; \ INCLUDE 9may93jaw : include ( "file" -- ) - bl word count included ; + name included ; \ RECURSE 17may93jaw @@ -1205,47 +1254,76 @@ Defer .status \ DOERROR (DOERROR) 13jun93jaw +8 Constant max-errors +Variable error-stack 0 error-stack ! +max-errors 6 * cells allot +\ format of one cell: +\ source ( addr u ) +\ >in +\ line-number +\ Loadfilename ( addr u ) + : dec. ( n -- ) \ print value in decimal representation base @ decimal swap . base ! ; : typewhite ( addr u -- ) \ like type, but white space is printed instead of the characters - 0 ?do - dup i + c@ 9 = if \ check for tab + bounds ?do + i c@ 9 = if \ check for tab 9 else bl then emit loop - drop ; +; DEFER DOERROR +: .error-frame ( addr1 u1 n1 n2 addr2 u2 -- ) + cr error-stack @ + IF + ." in file included from " + type ." :" dec. drop 2drop + ELSE + type ." :" dec. + cr dup 2over type cr drop + nip -trailing 1- ( line-start index2 ) + 0 >r BEGIN + 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 + [char] ^ emit + loop + THEN +; + : (DoError) ( throw-code -- ) - LoadFile @ - IF - cr loadfilename 2@ type ." :" Loadline @ dec. - THEN - cr source type cr - source drop >in @ -trailing ( throw-code line-start index2 ) - here c@ 1F min dup >r - 0 max ( throw-code line-start index1 ) - typewhite - r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 - ." ^" - loop - dup -2 = - IF - "error @ ?dup - IF - cr count type - THEN - drop - ELSE - .error - THEN - normal-dp dpp ! ; + loadline @ IF + source >in @ loadline @ 0 0 .error-frame + THEN + error-stack @ 0 ?DO + -1 error-stack +! + error-stack dup @ 6 * cells + cell+ + 6 cells bounds DO + I @ + cell +LOOP + .error-frame + LOOP + dup -2 = + IF + "error @ ?dup + IF + cr count type + THEN + drop + ELSE + .error + THEN + normal-dp dpp ! ; ' (DoError) IS DoError @@ -1264,16 +1342,41 @@ DEFER DOERROR \ : words listwords @ \ BEGIN @ dup WHILE dup .name REPEAT drop ; -: >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ; -: arg ( n -- addr count ) cells argv @ + @ >len ; +: cstring>sstring ( cstring -- addr n ) -1 0 scan 0 swap 1+ /string ; +: arg ( n -- addr count ) cells argv @ + @ cstring>sstring ; : #! postpone \ ; immediate -Variable env +Create pathstring 2 cells allot \ string +Create pathdirs 2 cells allot \ dir string array, pointer and count Variable argv Variable argc 0 Value script? ( -- flag ) +: process-path ( addr1 u1 -- addr2 u2 ) + \ addr1 u1 is a path string, addr2 u2 is an array of dir strings + here >r + BEGIN + over >r [char] : scan + over r> tuck - ( rest-str this-str ) + dup + IF + 2dup 1- chars + c@ [char] / <> + IF + 2dup chars + [char] / swap c! + 1+ + THEN + 2, + ELSE + 2drop + THEN + dup + WHILE + 1 /string + REPEAT + 2drop + here r> tuck - 2 cells / ; + : ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; : do-option ( addr1 len1 addr2 len2 -- n ) 2swap @@ -1282,14 +1385,19 @@ Variable argc IF 2drop ">tib interpret 2 EXIT THEN ." Unknown option: " type cr 2drop 1 ; -: process-args ( -- ) argc @ 1 - ?DO I arg over c@ [char] - <> - IF true to script? included false to script? 1 - ELSE I 1+ arg do-option - THEN - +LOOP ; +: process-args ( -- ) + argc @ 1 + ?DO + I arg over c@ [char] - <> + IF + true to script? included false to script? 1 + ELSE + I 1+ arg do-option + THEN + +LOOP ; -: cold ( -- ) +: cold ( -- ) + pathstring 2@ process-path pathdirs 2! argc @ 1 > IF ['] process-args catch ?dup @@ -1318,8 +1426,8 @@ Variable argc ." along with this program; if not, write to the Free Software" cr ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; -: boot ( **env **argv argc -- ) - argc ! argv ! env ! main-task up! +: boot ( path **argv argc -- ) + argc ! argv ! cstring>sstring pathstring 2! main-task up! sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; : bye script? 0= IF cr THEN 0 (bye) ;