--- gforth/Attic/kernal.fs 1994/05/05 15:46:46 1.4 +++ gforth/Attic/kernal.fs 1994/07/21 10:52:44 1.12 @@ -45,6 +45,7 @@ DOES> ( n -- ) + c@ ; \ here allot , c, A, 17dec92py +: dp ( -- addr ) dpp @ ; : here ( -- here ) dp @ ; : allot ( n -- ) dp +! ; : c, ( c -- ) here 1 chars allot c! ; @@ -56,6 +57,17 @@ DOES> ( n -- ) + c@ ; [ cell 1- ] Literal + [ -1 cells ] Literal and ; : align ( -- ) here dup aligned swap ?DO bl c, LOOP ; +: faligned ( addr -- f-addr ) + [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; + +: falign ( -- ) + here dup faligned swap + ?DO + bl c, + LOOP ; + + + : A! ( addr1 addr2 -- ) dup relon ! ; : A, ( addr -- ) here cell allot A! ; @@ -67,13 +79,13 @@ DOES> ( n -- ) + c@ ; \ name> found 17dec92py : (name>) ( nfa -- cfa ) count $1F and + aligned ; -: name> ( nfa -- cfa ) +: 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 -\ -1 r@ $40 and IF 1- THEN - -1 r> $20 and IF negate THEN ; + -1 r@ $40 and IF 1- THEN + r> $20 and IF negate THEN ; \ (find) 17dec92py @@ -130,12 +142,13 @@ Defer source dup count chars bounds ?DO I c@ toupper I c! 1 chars +LOOP ; : (name) ( -- addr ) bl word ; +\ : (cname) ( -- addr ) bl word capitalize ; \ Literal 17dec92py -: Literal ( n -- ) state @ 0= ?EXIT postpone lit , ; +: Literal ( n -- ) state @ IF postpone lit , THEN ; immediate -: ALiteral ( n -- ) state @ 0= ?EXIT postpone lit A, ; +: ALiteral ( n -- ) state @ IF postpone lit A, THEN ; immediate : char ( 'char' -- n ) bl word char+ c@ ; @@ -153,7 +166,10 @@ Defer source \ digit? 17dec92py : digit? ( char -- digit true/ false ) - base @ $100 = ?dup ?EXIT + base @ $100 = + IF + true EXIT + THEN toupper [char] 0 - dup 9 u> IF [ 'A '9 1 + - ] literal - dup 9 u<= IF @@ -178,15 +194,18 @@ Create bases 10 , 2 , A , 100 , \ !! this saving and restoring base is an abomination! - anton : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u< IF cells bases + @ base ! 1 /string ELSE drop THEN ; -: number? ( string -- string 0 / n -1 ) base @ >r - dup count over c@ [char] - = dup >r IF 1 /string THEN +: s>number ( addr len -- d ) base @ >r dpl on + over c@ '- = dup >r IF 1 /string THEN getbase dpl on 0 0 2swap BEGIN dup >r >number dup WHILE dup r> - WHILE dup dpl ! over c@ [char] . = WHILE 1 /string - REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN - 2drop rot drop rdrop r> IF dnegate THEN - dpl @ dup 0< IF nip THEN r> base ! ; + REPEAT THEN 2drop rdrop dpl off ELSE + 2drop rdrop r> IF dnegate THEN + THEN r> base ! ; +: number? ( string -- string 0 / n -1 / d 0> ) + dup count s>number dpl @ 0= IF 2drop false EXIT THEN + rot drop dpl @ dup 0> 0= IF nip THEN ; : s>d ( n -- d ) dup 0< ; : number ( string -- d ) number? ?dup 0= abort" ?" 0< IF s>d THEN ; @@ -239,23 +258,42 @@ hex \ catch throw 23feb93py \ bounce 08jun93jaw -\ !! what about the other stacks (FP, locals) anton \ !! allow the user to add rollback actions anton \ !! use a separate exception stack? anton +: lp@ ( -- addr ) + laddr# [ 0 , ] ; + : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) - >r sp@ r> swap \ don't count xt! jaw - >r handler @ >r rp@ handler ! execute - r> handler ! rdrop 0 ; -: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn ) - dup 0= IF drop EXIT THEN - handler @ rp! r> handler ! r> swap >r sp! r> ; + >r sp@ r> swap >r \ don't count xt! jaw + fp@ >r + lp@ >r + handler @ >r + rp@ handler ! + execute + r> handler ! rdrop rdrop rdrop 0 ; + +: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) + ?DUP IF + [ here 4 cells ! ] + handler @ rp! + r> handler ! + r> lp! + r> fp! + r> swap >r sp! r> + THEN ; + \ Bouncing is very fine, \ programming without wasting time... jaw -: bounce ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn ) -\ a throw without data stack restauration? anton !! stack diagram bad - dup 0= IF drop EXIT THEN - handler @ rp! r> handler ! r> drop ; +: bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) +\ a throw without data or fp stack restauration + ?DUP IF + handler @ rp! + r> handler ! + r> lp! + rdrop + rdrop + THEN ; \ ?stack 23feb93py @@ -268,7 +306,7 @@ Defer parser Defer name ' (name) IS name Defer notfound -: no.extensions ( string -- ) IF &-13 bounce THEN ; +: no.extensions ( string -- ) IF -&13 bounce THEN ; ' no.extensions IS notfound @@ -291,72 +329,366 @@ Defer notfound : [ ['] 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 postpone lp+!# dup , + then then then then drop ; + +: adjust-locals-size ( n -- ) + \ sets locals-size to n and generates an appropriate lp+! + locals-size @ swap - compile-lp+! ; + + +here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs +AConstant locals-list \ acts like a variable that contains + \ a linear list of locals names + + +variable dead-code \ true if normal code at "here" would be dead + +: unreachable ( -- ) +\ declares the current point of execution as unreachable + dead-code on ; + +\ locals list operations + +: common-list ( list1 list2 -- list3 ) +\ list1 and list2 are lists, where the heads are at higher addresses than +\ the tail. list3 is the largest sublist of both lists. + begin + 2dup u<> + while + 2dup u> + if + swap + then + @ + repeat + drop ; + +: sub-list? ( list1 list2 -- f ) +\ true iff list1 is a sublist of list2 + begin + 2dup u< + while + @ + repeat + = ; + +: list-size ( list -- u ) +\ size of the locals frame represented by list + 0 ( list n ) + begin + over 0<> + while + over + name> >body @ max + swap @ swap ( get next ) + repeat + faligned nip ; + +: set-locals-size-list ( list -- ) + dup locals-list ! + list-size locals-size ! ; + +: check-begin ( list -- ) +\ warn if list is not a sublist of locals-list + locals-list @ sub-list? 0= if + \ !! print current position + ." compiler was overly optimistic about locals at a BEGIN" cr + \ !! print assumption and reality + then ; + +\ Control Flow Stack +\ orig, etc. have the following structure: +\ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS ) +\ address (of the branch or the instruction to be branched to) (second) +\ locals-list (valid at address) (third) + +\ types +0 constant defstart +1 constant live-orig +2 constant dead-orig +3 constant dest \ the loopback branch is always assumed live +4 constant do-dest +5 constant scopestart + +: def? ( n -- ) + defstart <> abort" unstructured " ; + +: orig? ( n -- ) + dup live-orig <> swap dead-orig <> and abort" expected orig " ; + +: dest? ( n -- ) + dest <> abort" expected dest " ; + +: do-dest? ( n -- ) + do-dest <> abort" expected do-dest " ; + +: scope? ( n -- ) + scopestart <> abort" expected scope " ; + +: non-orig? ( n -- ) + dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ; + +: cs-item? ( n -- ) + live-orig scopestart 1+ within 0= abort" expected control flow stack item" ; + +3 constant cs-item-size + +: CS-PICK ( ... u -- ... destu ) + 1+ cs-item-size * 1- >r + r@ pick r@ pick r@ pick + rdrop + dup non-orig? ; + +: CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) + 1+ cs-item-size * 1- >r + r@ roll r@ roll r@ roll + rdrop + dup cs-item? ; + +: cs-push-part ( -- list addr ) + locals-list @ here ; + +: cs-push-orig ( -- orig ) + cs-push-part dead-code @ + if + dead-orig + else + live-orig + then ; + \ Structural Conditionals 12dec92py : ?struc ( flag -- ) abort" unstructured " ; : sys? ( sys -- ) dup 0= ?struc ; -: >mark ( -- sys ) here 0 , ; -: >resolve ( sys -- ) here over - swap ! ; -: mark ( -- orig ) + cs-push-orig 0 , ; +: >resolve ( addr -- ) here over - swap ! ; +: mark ; immediate restrict -: IF postpone ?branch >mark ; immediate restrict +: AHEAD ( -- orig ) + POSTPONE branch >mark unreachable ; immediate restrict + +: IF ( -- orig ) + POSTPONE ?branch >mark ; immediate restrict + : ?DUP-IF \ general \ 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 + POSTPONE ?dup POSTPONE if ; immediate restrict : ?DUP-NOT-IF \ general - postpone ?dup postpone 0= postpone if ; immediate restrict -: THEN sys? dup @ ?struc >resolve ; immediate restrict + POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict + +: THEN ( orig -- ) + dup orig? + dead-code @ + if + dead-orig = + if + >resolve drop + else + >resolve set-locals-size-list dead-code off + then + else + dead-orig = + if + >resolve drop + else \ both live + over list-size adjust-locals-size + >resolve + locals-list @ common-list dup list-size adjust-locals-size + locals-list ! + then + then ; immediate restrict + ' THEN alias ENDIF immediate restrict \ general \ Same as "THEN". This is what you use if your program will be seen by \ people who have not been brought up with Forth (or who have been \ brought up with fig-Forth). -: ELSE sys? postpone AHEAD swap postpone THEN ; - immediate restrict - -: BEGIN here ; immediate restrict -: WHILE sys? postpone IF swap ; immediate restrict -: AGAIN sys? postpone branch if + dup cs-item? + 2 pick + else + 0 + then + set-locals-size-list + then + cs-push-part dest + dead-code off ; immediate restrict + +\ AGAIN (the current control flow joins another, earlier one): +\ If the dest-locals-list is not a subset of the current locals-list, +\ issue a warning (see below). The following code is generated: +\ lp+!# (current-local-size - dest-locals-size) +\ branch +: AGAIN ( dest -- ) + dest? + over list-size adjust-locals-size + POSTPONE branch + (current-local-size - dest-locals-size) +: until-like ( list addr xt1 xt2 -- ) + \ list and addr are a fragment of a cs-item + \ xt1 is the conditional branch without lp adjustment, xt2 is with + >r >r + locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment ) + r> drop r> compile, + swap compile, drop + then ( list ) + check-begin ; + +: UNTIL ( dest -- ) + dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict + +: WHILE ( dest -- orig dest ) + POSTPONE if + 1 cs-roll ; immediate restrict + +: REPEAT ( orig dest -- ) + POSTPONE again + POSTPONE then ; immediate restrict + + +\ counted loops + +\ leave poses a little problem here +\ we have to store more than just the address of the branch, so the +\ traditional linked list approach is no longer viable. +\ This is solved by storing the information about the leavings in a +\ special stack. + +\ !! remove the fixed size limit. 'Tis not hard. +20 constant leave-stack-size +create leave-stack 60 cells allot +Avariable leave-sp leave-stack 3 cells + leave-sp ! + +: clear-leave-stack ( -- ) + leave-stack leave-sp ! ; + +\ : leave-empty? ( -- f ) +\ leave-sp @ leave-stack = ; + +: >leave ( orig -- ) + \ push on leave-stack + leave-sp @ + dup [ leave-stack 60 cells + ] Aliteral + >= abort" leave-stack full" + tuck ! cell+ + tuck ! cell+ + tuck ! cell+ + leave-sp ! ; + +: leave> ( -- orig ) + \ pop from leave-stack + leave-sp @ + dup leave-stack <= IF + drop 0 0 0 EXIT THEN + cell - dup @ swap + cell - dup @ swap + cell - dup @ swap + leave-sp ! ; + +: DONE ( orig -- ) drop >r drop + \ !! the original done had ( addr -- ) + begin + leave> + over r@ u>= + while + POSTPONE then + repeat + >leave rdrop ; immediate restrict + +: LEAVE ( -- ) + POSTPONE ahead + >leave ; immediate restrict + +: ?LEAVE ( -- ) + POSTPONE 0= POSTPONE if + >leave ; immediate restrict + +: DO ( -- do-sys ) + POSTPONE (do) + POSTPONE begin drop do-dest + ( 0 0 0 >leave ) ; immediate restrict + +: ?DO ( -- do-sys ) + ( 0 0 0 >leave ) + POSTPONE (?do) + >mark >leave + POSTPONE begin drop do-dest ; immediate restrict + +: FOR ( -- do-sys ) + POSTPONE (for) + POSTPONE begin drop do-dest + ( 0 0 0 >leave ) ; immediate restrict + +\ LOOP etc. are just like UNTIL + +: loop-like ( do-sys xt1 xt2 -- ) + >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? + until-like POSTPONE done POSTPONE unloop ; + +: LOOP ( do-sys -- ) + ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict + +: +LOOP ( do-sys -- ) + ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict + +\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" +\ will iterate as often as "high low ?DO inc S+LOOP". For positive +\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for +\ negative increments. +: S+LOOP ( do-sys -- ) + ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict -: DONE ( addr -- ) leavings @ - BEGIN 2dup u<= WHILE dup @ swap >resolve REPEAT - leavings ! drop ; immediate restrict +: NEXT ( do-sys -- ) + ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict \ Structural Conditionals 12dec92py -: DO postpone (do) here ; immediate restrict - -: ?DO postpone (?do) (leave) here ; - immediate restrict -: FOR postpone (for) here ; immediate restrict - -: loop] dup -&19 and throw ( is name too long? ) + 1+ chars allot align ; : input-stream-header ( "name" -- ) \ !! this is f83-implementation-dependent align here last ! -1 A, @@ -411,11 +747,11 @@ defer header ' input-stream-header IS header \ !! make that a 2variable -create nextname-string 2 cells allot \ should we use a buffer that keeps the name? +create nextname-buffer 32 chars allot : nextname-header ( -- ) \ !! f83-implementation-dependent - nextname-string 2@ + nextname-buffer count align here last ! -1 A, dup c, here swap chars dup allot move align $80 flag! @@ -423,7 +759,9 @@ create nextname-string 2 cells allot \ s \ the next name is given in the string : nextname ( c-addr u -- ) \ general - nextname-string 2! + dup $1F u> -&19 and throw ( is name too long? ) + nextname-buffer c! ( c-addr ) + nextname-buffer count move ['] nextname-header IS header ; : noname-header ( -- ) @@ -444,7 +782,7 @@ create nextname-string 2 cells allot \ s : name>string ( nfa -- addr count ) cell+ count $1F and ; -Create ??? ," ???" +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 @@ -470,8 +808,14 @@ Create ??? ," ???" \ DOES> 17mar93py -: DOES> state @ IF postpone (;code) dodoes, - ELSE dodoes, here !does 0 ] THEN ; immediate +: DOES> ( compilation: -- ) + state @ + IF + ;-hook postpone (;code) dodoes, + ELSE + dodoes, here !does 0 ] + THEN + :-hook ; immediate \ Create Variable User Constant 17mar93py @@ -486,12 +830,20 @@ Create ??? ," ???" : (Constant) Header reveal [ :docon ] Literal cfa, ; : Constant (Constant) , ; : AConstant (Constant) A, ; -: 2Constant ( w1 w2 "name" -- ) \ double - Create 2, DOES> 2@ ; + +: 2CONSTANT + create ( w1 w2 "name" -- ) + 2, + does> ( -- w1 w2 ) + 2@ ; \ IS Defer What's Defers TO 24feb93py -: Defer Create ['] noop A, DOES> @ execute ; +: Defer + Create ( -- ) + ['] noop A, + DOES> ( ??? ) + @ execute ; : IS ( addr "name" -- ) ' >body @@ -505,38 +857,65 @@ Create ??? ," ???" state @ IF postpone ALiteral postpone @ ELSE @ THEN ; immediate : Defers ( "name" -- ) ' >body @ compile, ; - immediate restrict + immediate \ : ; 24feb93py -: EXIT ( -- ) postpone ;s ; immediate +defer :-hook ( sys1 -- sys2 ) +defer ;-hook ( sys2 -- sys1 ) -: : ( -- colon-sys ) Header [ :docol ] Literal cfa, 0 ] ; -: ; ( colon-sys -- ) ?struc postpone exit reveal postpone [ ; +: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; +: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict -: :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] ; + +: :noname ( -- xt colon-sys ) + 0 last ! + here [ :docol ] Literal cfa, 0 ] :-hook ; \ Search list handling 23feb93py AVariable current : last? ( -- false / nfa nfa ) last @ ?dup ; -: (reveal) ( -- ) last? - IF dup @ 0< - IF current @ @ over ! current @ ! - ELSE drop THEN THEN ; +: (reveal) ( -- ) + last? + IF + dup @ 0< + IF + current @ @ over ! current @ ! + ELSE + drop + THEN + THEN ; \ 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 -- ) +\ \ !! what else +\ 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 + +: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; + \ Search list table: find reveal +Create f83search ' f83find A, ' (reveal) A, ' drop A, -Create f83search ' (f83find) A, ' (reveal) A, Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, AVariable search G forth-wordlist search T ! G forth-wordlist current T ! : (search-wordlist) ( addr count wid -- nfa / false ) - dup @ swap cell+ @ @ execute ; + dup ( @ swap ) cell+ @ @ execute ; : search-wordlist ( addr count wid -- 0 / xt +-1 ) (search-wordlist) dup IF found THEN ; @@ -566,6 +945,8 @@ Variable warnings G -1 warnings T ! then current @ cell+ @ cell+ @ execute ; +: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; + : ' ( "name" -- addr ) name find 0= no.extensions ; : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate \ Input 13feb93py @@ -622,14 +1003,14 @@ Create crtlkeys DEFER type \ defer type for a output buffer or fast \ screen write -: (type) ( addr len -- ) - bounds ?DO I c@ emit LOOP ; +\ : (type) ( addr len -- ) +\ bounds ?DO I c@ emit LOOP ; ' (TYPE) IS Type -\ DEFER Emit +DEFER Emit -\ ' (Emit) IS Emit +' (Emit) IS Emit \ : form ( -- rows cols ) &24 &80 ; \ form should be implemented using TERMCAPS or CURSES @@ -641,15 +1022,15 @@ DEFER type \ defer type for a outpu : refill ( -- flag ) tib /line loadfile @ ?dup - IF dup file-position throw linestart 2! + IF \ dup file-position throw linestart 2! read-line throw - ELSE linestart @ IF 2drop false EXIT THEN + ELSE loadline @ 0< IF 2drop false EXIT THEN accept true THEN 1 loadline +! - swap #tib ! >in off ; + swap #tib ! 0 >in ! ; -: Query ( -- ) loadfile off refill drop ; +: Query ( -- ) 0 loadfile ! refill drop ; \ File specifiers 11jun93jaw @@ -677,20 +1058,29 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ include-file 07apr93py -: include-file ( i*x fid -- j*x ) - linestart @ >r loadline @ >r loadfile @ >r - blk @ >r >tib @ >r #tib @ dup >r >in @ >r +: push-file ( -- ) r> + ( linestart 2@ >r >r ) loadline @ >r loadfile @ >r + blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; + +: pop-file ( -- ) r> + r> >in ! r> #tib ! r> >tib ! r> blk ! + r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ; - >tib +! loadfile ! +: include-file ( i*x fid -- j*x ) + push-file loadfile ! 0 loadline ! blk off BEGIN refill WHILE interpret REPEAT loadfile @ close-file throw - - r> >in ! r> #tib ! r> >tib ! r> blk ! - r> loadfile ! r> loadline ! r> linestart ! ; + pop-file ; : included ( i*x addr u -- j*x ) - r/o open-file throw include-file ; + loadfilename 2@ >r >r + dup allocate throw over loadfilename 2! + over loadfilename 2@ move + r/o open-file throw include-file + \ don't free filenames; they don't take much space + \ and are used for debugging + r> r> loadfilename 2! ; \ HEX DECIMAL 2may93jaw @@ -703,13 +1093,15 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ INCLUDE 9may93jaw -: include - bl word count included ; +: include ( "file" -- ) + bl word count included ; \ RECURSE 17may93jaw -: recurse last @ cell+ name> a, ; immediate restrict -\ !! does not work with anonymous words; use lastxt compile, +: recurse ( -- ) + lastxt compile, ; immediate restrict +: recursive ( -- ) + reveal ; immediate \ */MOD */ 17may93jaw @@ -720,16 +1112,12 @@ create nl$ 1 c, A c, 0 c, \ gnu includes \ EVALUATE 17may93jaw : evaluate ( c-addr len -- ) - linestart @ >r loadline @ >r loadfile @ >r - blk @ >r >tib @ >r #tib @ dup >r >in @ >r - - >tib +! dup #tib ! >tib @ swap move - >in off blk off loadfile off -1 linestart ! + push-file dup #tib ! >tib @ swap move + >in off blk off loadfile off -1 loadline ! BEGIN interpret >in @ #tib @ u>= UNTIL - r> >in ! r> #tib ! r> >tib ! r> blk ! - r> loadfile ! r> loadline ! r> linestart ! ; + pop-file ; : abort -1 throw ; @@ -747,24 +1135,58 @@ Defer .status \ DOERROR (DOERROR) 13jun93jaw +: 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 + 9 + else + bl + then + emit + loop + drop ; + DEFER DOERROR : (DoError) ( throw-code -- ) - LoadFile @ IF ." Error in line: " Loadline @ . cr THEN - cr source type cr - source drop >in @ -trailing - here c@ 1F min dup >r - 1- 0 max nip - dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^" - dup -2 = - IF "error @ ?dup IF cr count type THEN drop - ELSE .error THEN ; + 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 ! ; ' (DoError) IS DoError : quit r0 @ rp! handler off >tib @ >r - BEGIN postpone [ ['] 'quit catch dup WHILE - DoError r@ >tib ! - REPEAT drop r> >tib ! ; + BEGIN + postpone [ + ['] 'quit CATCH dup + WHILE + DoError r@ >tib ! + REPEAT + drop r> >tib ! ; \ Cold 13feb93py @@ -780,24 +1202,55 @@ Variable env Variable argv Variable argc -: get-args ( -- ) #tib off - argc @ 1 ?DO I arg 2dup source + swap move - #tib +! drop bl source + c! 1 #tib +! LOOP - >in off #tib @ 0<> #tib +! ; - -: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; - -: cold ( -- ) argc @ 1 > - IF script? - IF 1 arg ['] included ELSE get-args ['] interpret THEN - catch ?dup IF dup >r DoError cr r> (bye) THEN THEN - ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; +0 Value script? ( -- flag ) + +: ">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 ; + +: 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 ( -- ) + argc @ 1 > + IF + ['] process-args catch ?dup + IF + dup >r DoError cr r> negate (bye) + THEN + THEN + ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" cr + ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" + cr quit ; + +: license ( -- ) cr + ." This program is free software; you can redistribute it and/or modify" cr + ." it under the terms of the GNU General Public License as published by" cr + ." the Free Software Foundation; either version 1, or (at your option)" cr + ." any later version." cr cr + + ." This program is distributed in the hope that it will be useful," cr + ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr + ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr + ." GNU General Public License for more details." cr cr + + ." You should have received a copy of the GNU General Public License" cr + ." 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! sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; -: bye cr 0 (bye) ; +: bye script? 0= IF cr THEN 0 (bye) ; \ **argv may be scanned by the C starter to get some important \ information, as -display and -geometry for an X client FORTH