--- gforth/kernel/int.fs 2000/08/18 08:56:33 1.55 +++ gforth/kernel/int.fs 2012/12/31 15:25:19 1.195 @@ -1,12 +1,12 @@ \ definitions needed for interpreter only -\ Copyright (C) 1995-2000 Free Software Foundation, Inc. +\ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ \ Revision-Log @@ -28,9 +27,9 @@ require ./basics.fs \ bounds decimal he require ./io.fs \ type ... require ./nio.fs \ . <# ... require ./errore.fs \ .error ... -require kernel/version.fs \ version-string -require ./../chains.fs +require kernel/version.fs \ version-string +has? new-input 0= [IF] : tib ( -- c-addr ) \ core-ext t-i-b \G @i{c-addr} is the address of the Terminal Input Buffer. \G OBSOLESCENT: @code{source} superceeds the function of this word. @@ -44,6 +43,7 @@ Defer source ( -- c-addr u ) \ core : (source) ( -- c-addr u ) tib #tib @ ; ' (source) IS source +[THEN] : (word) ( addr1 n1 char -- addr2 n2 ) dup >r skip 2dup r> scan nip - ; @@ -51,35 +51,18 @@ Defer source ( -- c-addr u ) \ core \ (word) should fold white spaces \ this is what (parse-white) does -\ word parse 23feb93py - -: sword ( char -- addr len ) \ gforth s-word - \G Parses like @code{word}, but the output is like @code{parse} output. - \G @xref{core-idef}. - \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and - \ dpANS6 A.6.2.2008 have a word with that name that behaves - \ differently (like NAME). - 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 "ccc-- c-addr ) \ core - \G Skip leading delimiters. Parse @i{ccc}, delimited by - \G @i{char}, in the parse area. @i{c-addr} is the address of a - \G transient region containing the parsed string in - \G counted-string format. If the parse area was empty or - \G contained no characters other than delimiters, the resulting - \G string has zero length. A program may replace characters within - \G the counted string. OBSOLESCENT: the counted string has a - \G trailing space that is not included in its length. - sword here place bl here count + c! here ; +\ parse 23feb93py : parse ( char "ccc" -- c-addr u ) \ core-ext - \G Parse @i{ccc}, delimited by @i{char}, in the parse - \G area. @i{c-addr u} specifies the parsed string within the - \G parse area. If the parse area was empty, @i{u} is 0. - >r source >in @ over min /string over swap r> scan >r - over - dup r> IF 1+ THEN >in +! ; +\G Parse @i{ccc}, delimited by @i{char}, in the parse +\G area. @i{c-addr u} specifies the parsed string within the +\G parse area. If the parse area was empty, @i{u} is 0. + >r source >in @ over min /string ( c-addr1 u1 ) + over swap r> scan >r + over - dup r> IF 1+ THEN >in +! +[ has? new-input [IF] ] + 2dup input-lexeme! +[ [THEN] ] ; \ name 13feb93py @@ -87,6 +70,9 @@ Defer source ( -- c-addr u ) \ core : (name) ( -- c-addr count ) \ gforth source 2dup >r >r >in @ /string (parse-white) +[ has? new-input [IF] ] + 2dup input-lexeme! +[ [THEN] ] 2dup + r> - 1+ r> min >in ! ; \ name count ; [THEN] @@ -95,62 +81,89 @@ Defer source ( -- c-addr u ) \ core dup 0= -&16 and throw ; : name-too-long? ( c-addr u -- c-addr u ) - dup $1F u> -&19 and throw ; + dup lcount-mask u> -&19 and throw ; \ \ Number parsing 23feb93py -\ number? number 23feb93py +\ (number?) number 23feb93py hex -const Create bases 10 , 2 , A , 100 , -\ 16 2 10 character +const Create bases 0A , 10 , 2 , 0A , +\ 10 16 2 10 \ !! protect BASE saving wrapper against exceptions : getbase ( addr u -- addr' u' ) - over c@ [char] $ - dup 4 u< + 2dup s" 0x" string-prefix? >r + 2dup s" 0X" string-prefix? r> or + base @ &34 < and if + hex 2 /string + endif + over c@ [char] # - dup 4 u< IF cells bases + @ base ! 1 /string ELSE drop THEN ; -: sign? ( addr u -- addr u flag ) +: sign? ( addr u -- addr1 u1 flag ) over c@ [char] - = dup >r IF 1 /string THEN r> ; -: s>unumber? ( addr u -- ud flag ) - base @ >r dpl on getbase - 0. 2swap - BEGIN ( d addr len ) - dup >r >number dup - WHILE \ there are characters left - dup r> - - WHILE \ the last >number parsed something - dup 1- dpl ! over c@ [char] . = - WHILE \ the current char is '.' - 1 /string - REPEAT THEN \ there are unparseable characters left - 2drop false +: ?dnegate ( d1 f -- d2 ) + if + dnegate + then ; + +has? os 0= [IF] +: x@+/string ( addr u -- addr' u' c ) + over c@ >r 1 /string r> ; +[THEN] + +: s'>unumber? ( addr u -- ud flag ) + \ convert string "C" or "C'" to character code + dup 0= if + false exit + endif + x@+/string 0 s" '" 2rot string-prefix? ; + +: s>unumber? ( c-addr u -- ud flag ) \ gforth + \G converts string c-addr u into ud, flag indicates success + dpl on + over c@ '' = if + 1 /string s'>unumber? exit + endif + base @ >r getbase sign? + over if + >r 0. 2swap + BEGIN ( d addr len ) + dup >r >number dup + WHILE \ there are characters left + dup r> - + WHILE \ the last >number parsed something + dup 1- dpl ! over c@ dp-char @ = + WHILE \ the current char is '.' + 1 /string + REPEAT THEN \ there are unparseable characters left + 2drop rdrop false + ELSE + rdrop 2drop r> ?dnegate true + THEN ELSE - rdrop 2drop true - THEN + drop 2drop 0. false THEN r> base ! ; \ ouch, this is complicated; there must be a simpler way - anton -: s>number? ( addr len -- d f ) - \ converts string addr len into d, flag indicates success +: s>number? ( addr u -- d f ) \ gforth + \G converts string addr u into d, flag indicates success sign? >r s>unumber? 0= IF rdrop false ELSE \ no characters left, all ok - r> - IF - dnegate - THEN + r> ?dnegate true THEN ; @@ -169,7 +182,7 @@ const Create bases 10 , 2 , A , 10 1+ THEN ; -: number? ( string -- string 0 / n -1 / d 0> ) +: (number?) ( string -- string 0 / n -1 / d 0> ) dup >r count snumber? dup if rdrop else @@ -177,7 +190,7 @@ const Create bases 10 , 2 , A , 10 then ; : number ( string -- d ) - number? ?dup 0= abort" ?" 0< + (number?) ?dup 0= abort" ?" 0< IF s>d THEN ; @@ -208,6 +221,13 @@ const Create bases 10 , 2 , A , 10 \G comments into documentation. POSTPONE \ ; immediate +has? ec [IF] + AVariable forth-wordlist + : find-name ( c-addr u -- nt | 0 ) \ gforth + \g Find the name @i{c-addr u} in the current search + \g order. Return its @i{nt}, if found, otherwise 0. + forth-wordlist (f83find) ; +[ELSE] \ \ object oriented search list 17mar93py \ word list structure: @@ -227,8 +247,13 @@ struct cell% field wordlist-extend \ wordlist extensions (eg bucket offset) end-struct wordlist-struct +has? f83headerstring [IF] : f83find ( addr len wordlist -- nt / false ) wordlist-id @ (f83find) ; +[ELSE] +: f83find ( addr len wordlist -- nt / false ) + wordlist-id @ (listlfind) ; +[THEN] : initvoc ( wid -- ) dup wordlist-map @ hash-method perform ; @@ -237,7 +262,7 @@ end-struct wordlist-struct Create f83search ( -- wordlist-map ) ' f83find A, ' drop A, ' drop A, ' drop A, -here G f83search T A, NIL A, NIL A, NIL A, +here f83search A, NIL A, NIL A, NIL A, AValue forth-wordlist \ variable, will be redefined by search.fs AVariable lookup forth-wordlist lookup ! @@ -253,12 +278,64 @@ Defer context ( -- addr ) \ gforth ' lookup is context forth-wordlist current ! +: (search-wordlist) ( addr count wid -- nt | false ) + dup wordlist-map @ find-method perform ; + +: search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search + \G Search the word list identified by @i{wid} for the definition + \G named by the string at @i{c-addr count}. If the definition is + \G not found, return 0. If the definition is found return 1 (if + \G the definition is immediate) or -1 (if the definition is not + \G immediate) together with the @i{xt}. In Gforth, the @i{xt} + \G returned represents the interpretation semantics. ANS Forth + \G does not specify clearly what @i{xt} represents. + (search-wordlist) dup if + (name>intn) + then ; + +: find-name ( c-addr u -- nt | 0 ) \ gforth + \g Find the name @i{c-addr u} in the current search + \g order. Return its @i{nt}, if found, otherwise 0. + lookup @ (search-wordlist) ; +[THEN] + \ \ header, finding, ticks 17dec92py -hex -80 constant alias-mask \ set when the word is not an alias! -40 constant immediate-mask -20 constant restrict-mask +\ The constants are defined as 32 bits, but then erased +\ and overwritten by the right ones + +has? f83headerstring [IF] + \ to save space, Gforth EC limits words to 31 characters + \ also, there's no predule concept in Gforth EC + $80 constant alias-mask + $40 constant immediate-mask + $20 constant restrict-mask + $1f constant lcount-mask +[ELSE] +\ 32-bit systems cannot generate large 64-bit constant in the +\ cross-compiler, so we kludge it by generating a constant and then +\ storing the proper value into it (and that's another kludge). +$80000000 constant alias-mask +1 bits/char 1 - lshift +-1 cells allot bigendian [IF] c, 0 1 cells 1- times + [ELSE] 0 1 cells 1- times c, [THEN] +$40000000 constant immediate-mask +1 bits/char 2 - lshift +-1 cells allot bigendian [IF] c, 0 1 cells 1- times + [ELSE] 0 1 cells 1- times c, [THEN] +$20000000 constant restrict-mask +1 bits/char 3 - lshift +-1 cells allot bigendian [IF] c, 0 1 cells 1- times + [ELSE] 0 1 cells 1- times c, [THEN] +$10000000 constant prelude-mask +1 bits/char 4 - lshift +-1 cells allot bigendian [IF] c, 0 1 cells 1- times + [ELSE] 0 1 cells 1- times c, [THEN] +$0fffffff constant lcount-mask +1 bits/char 4 - lshift 1 - +-1 cells allot bigendian [IF] c, -1 1 cells 1- times + [ELSE] -1 1 cells 1- times c, [THEN] +[THEN] \ higher level parts of find @@ -266,6 +343,9 @@ hex \ true becomes 1, false -1 0= 2* 1+ ; +: ticking-compile-only-error ( ... -- ) + -&2048 throw ; + : compile-only-error ( ... -- ) -&14 throw ; @@ -277,43 +357,60 @@ hex then [ [THEN] ] ; -: (x>int) ( cfa b -- xt ) +: (x>int) ( cfa w -- xt ) \ get interpretation semantics of name - restrict-mask and + restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ] if drop ['] compile-only-error else (cfa>int) then ; -: name>string ( nt -- addr count ) \ gforth head-to-string +has? f83headerstring [IF] +: name>string ( nt -- addr count ) \ gforth name-to-string \g @i{addr count} is the name of the word represented by @i{nt}. - cell+ count $1F and ; + cell+ count lcount-mask and ; : ((name>)) ( nfa -- cfa ) name>string + cfaligned ; -: (name>x) ( nfa -- cfa b ) - \ cfa is an intermediate cfa and b is the flags byte of nfa +: (name>x) ( nfa -- cfa w ) + \ cfa is an intermediate cfa and w is the flags cell of nfa dup ((name>)) swap cell+ c@ dup alias-mask and 0= IF swap @ swap THEN ; +[ELSE] +: name>string ( nt -- addr count ) \ gforth name-to-string + \g @i{addr count} is the name of the word represented by @i{nt}. + cell+ dup cell+ swap @ lcount-mask and ; + +: ((name>)) ( nfa -- cfa ) + name>string + cfaligned ; -: name>int ( nt -- xt ) \ gforth +: (name>x) ( nfa -- cfa w ) + \ cfa is an intermediate cfa and w is the flags cell of nfa + dup ((name>)) + swap cell+ @ dup alias-mask and 0= + IF + swap @ swap + THEN ; +[THEN] + +: name>int ( nt -- xt ) \ gforth name-to-int \G @i{xt} represents the interpretation semantics of the word \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is \G @code{compile-only}), @i{xt} is the execution token for - \G @code{compile-only-error}, which performs @code{-14 throw}. + \G @code{ticking-compile-only-error}, which performs @code{-2048 throw}. (name>x) (x>int) ; -: name?int ( nt -- xt ) \ gforth - \G Like @code{name>int}, but perform @code{-14 throw} if @i{nt} +: name?int ( nt -- xt ) \ gforth name-question-int + \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt} \G has no interpretation semantics. - (name>x) restrict-mask and + (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ] if - compile-only-error \ does not return + ticking-compile-only-error \ does not return then (cfa>int) ; @@ -326,47 +423,90 @@ hex interpret/compile-comp @ then [ [THEN] ] - r> immediate-mask and flag-sign + r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ; : (name>intn) ( nfa -- xt +-1 ) - (name>x) tuck (x>int) ( b xt ) - swap immediate-mask and flag-sign ; + (name>x) tuck (x>int) ( w xt ) + swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ; + +[IFDEF] prelude-mask +: name>prelude ( nt -- xt ) + dup cell+ @ prelude-mask and if + [ -1 cells ] literal + @ + else + drop ['] noop + then ; +[THEN] -const Create ??? 0 , 3 c, char ? c, char ? c, char ? c, +const Create ??? 0 , 3 , char ? c, char ? c, char ? c, \ ??? is used by dovar:, must be created/:dovar [IFDEF] forthstart \ if we have a forthstart we can define head? with it \ otherwise leave out the head? check +: one-head? ( addr -- f ) +\G heuristic check whether addr is a name token; may deliver false +\G positives; addr must be a valid address + dup dup aligned <> + if + drop false exit \ heads are aligned + then + dup cell+ @ alias-mask and 0= >r + name>string dup $20 $1 within if + rdrop 2drop false exit \ realistically the name is short + then + over + cfaligned over - 2dup bounds ?do \ should be a printable string + i c@ bl < if + 2drop unloop rdrop false exit + then + loop + + r> if \ check for valid aliases + @ dup forthstart here within + over ['] noop ['] lit-execute 1+ within or + over dup aligned = and + 0= if + drop false exit + then + then \ check for cfa - must be code field or primitive + dup @ tuck 2 cells - = swap + docol: ['] lit-execute @ 1+ within or ; + : head? ( addr -- f ) - \G heuristic check whether addr is a name token; may deliver false - \G positives; addr must be a valid address +\G heuristic check whether addr is a name token; may deliver false +\G positives; addr must be a valid address; returns 1 for +\G particularly unsafe positives \ we follow the link fields and check for plausibility; two \ iterations should catch most false addresses: on the first \ iteration, we may get an xt, on the second a code address (or \ some code), which is typically not in the dictionary. - 2 0 do - dup dup aligned <> if \ protect @ against unaligned accesses + \ we added a third iteration for working with code and ;code words. + 3 0 do + dup one-head? 0= if drop false unloop exit - then - dup @ dup - if ( addr addr1 ) - dup rot forthstart within - if \ addr1 is outside forthstart..addr, not a head + endif + dup @ dup 0= if + 2drop 1 unloop exit + else + dup rot forthstart within if drop false unloop exit - then ( addr1 ) - else \ 0 in the link field, no further checks - 2drop true unloop exit + then then loop - \ in dubio pro: drop true ; : >head-noprim ( cfa -- nt ) \ gforth to-head-noprim - $25 cell do ( cfa ) - dup i - count $9F and + cfaligned over alias-mask + = + \ also heuristic + dup forthstart - max-name-length @ + [ has? float [IF] ] float+ [ [ELSE] ] cell+ [ [THEN] ] cell+ min + cell max cell ?do ( cfa ) + dup i - dup @ [ alias-mask lcount-mask or ] literal + [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or + -1 cells allot bigendian [IF] c, -1 1 cells 1- times + [ELSE] -1 1 cells 1- times c, [THEN] ] + and ( cfa len|alias ) + swap + cell+ cfaligned over alias-mask + = if ( cfa ) dup i - cell - dup head? if @@ -381,7 +521,12 @@ const Create ??? 0 , 3 c, char ? c, cha : >head-noprim ( cfa -- nt ) \ gforth to-head-noprim $25 cell do ( cfa ) - dup i - count $9F and + cfaligned over alias-mask + = + dup i - dup @ [ alias-mask lcount-mask or ] literal + [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or + -1 cells allot bigendian [IF] c, -1 1 cells 1- times + [ELSE] -1 1 cells 1- times c, [THEN] ] + and ( cfa len|alias ) + swap + cell + cfaligned over alias-mask + = if ( cfa ) i - cell - unloop exit then cell +loop @@ -389,27 +534,56 @@ const Create ??? 0 , 3 c, char ? c, cha [THEN] -: body> 0 >body - ; +cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body +\G Get the address of the body of the word represented by @i{xt} (the +\G address of the word's data field). +drop drop + +cell% -2 * 0 0 field body> ( xt -- a_addr ) + drop drop + +has? standardthreading has? compiler and [IF] + +' @ alias >code-address ( xt -- c_addr ) \ gforth +\G @i{c-addr} is the code address of the word @i{xt}. + +: >does-code ( xt -- a_addr ) \ gforth +\G If @i{xt} is the execution token of a child of a @code{DOES>} word, +\G @i{a-addr} is the start of the Forth code after the @code{DOES>}; +\G Otherwise @i{a-addr} is 0. + dup @ dodoes: = if + cell+ @ + else + drop 0 + endif ; -: (search-wordlist) ( addr count wid -- nt | false ) - dup wordlist-map @ find-method perform ; +has? prims [IF] + : flash! ! ; + : flashc! c! ; +[THEN] -: search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search - \G Search the word list identified by @i{wid} for the definition - \G named by the string at @i{c-addr count}. If the definition is - \G not found, return 0. If the definition is found return 1 (if - \G the definition is immediate) or -1 (if the definition is not - \G immediate) together with the @i{xt}. In Gforth, the @i{xt} - \G returned represents the interpretation semantics. ANS Forth - \G does not specify clearly what @i{xt} represents. - (search-wordlist) dup if - (name>intn) - then ; +has? flash [IF] ' flash! [ELSE] ' ! [THEN] +alias code-address! ( c_addr xt -- ) \ gforth +\G Create a code field with code address @i{c-addr} at @i{xt}. + +: any-code! ( a-addr cfa code-addr -- ) + \ for implementing DOES> and ;ABI-CODE, maybe : + \ code-address is stored at cfa, a-addr at cfa+cell + over ! cell+ ! ; + +: does-code! ( a-addr xt -- ) \ gforth +\G Create a code field at @i{xt} for a child of a @code{DOES>}-word; +\G @i{a-addr} is the start of the Forth code after @code{DOES>}. + [ has? flash [IF] ] + dodoes: over flash! cell+ flash! + [ [ELSE] ] + dodoes: any-code! + [ [THEN] ] ; -: find-name ( c-addr u -- nt | 0 ) \ gforth - \g Find the name @i{c-addr u} in the current search - \g order. Return its @i{nt}, if found, otherwise 0. - lookup @ (search-wordlist) ; +2 cells constant /does-handler ( -- n ) \ gforth +\G The size of a @code{DOES>}-handler (includes possible padding). + +[THEN] : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete find-name dup @@ -447,7 +621,7 @@ const Create ??? 0 , 3 c, char ? c, cha \ ticks in interpreter : (') ( "name" -- nt ) \ gforth - name name-too-short? + parse-name name-too-short? find-name dup 0= IF drop -&13 throw @@ -470,55 +644,119 @@ has? compiler 0= [IF] \ interpreter only \ interpret 10mar92py -Defer parser ( c-addr u -- ) -Defer name ( -- c-addr count ) \ gforth +Defer parser1 ( c-addr u -- ... xt) +\ "... xt" is the action to be performed by the text-interpretation of c-addr u + +: parser ( c-addr u -- ... ) +\ text-interpret the word/number c-addr u, possibly producing a number + parser1 execute ; +has? ec [IF] + ' (name) Alias parse-name + : no.extensions 2drop -&13 throw ; + ' no.extensions Alias compiler-notfound1 + ' no.extensions Alias interpreter-notfound1 +[ELSE] +Defer parse-name ( "name" -- c-addr u ) \ gforth \G Get the next word from the input buffer -' (name) IS name -Defer compiler-notfound ( c-addr count -- ) -Defer interpreter-notfound ( c-addr count -- ) +' (name) IS parse-name +' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete +\G old name for @code{parse-name} + +' parse-name alias name ( -- c-addr u ) \ gforth-obsolete +\G old name for @code{parse-name} + : no.extensions ( addr u -- ) 2drop -&13 throw ; -' no.extensions IS compiler-notfound -' no.extensions IS interpreter-notfound +has? recognizer 0= [IF] +Defer compiler-notfound1 ( c-addr count -- ... xt ) +Defer interpreter-notfound1 ( c-addr count -- ... xt ) + +' no.extensions IS compiler-notfound1 +' no.extensions IS interpreter-notfound1 +[THEN] + +Defer before-word ( -- ) \ gforth +\ called before the text interpreter parses the next word +' noop IS before-word + +Defer before-line ( -- ) \ gforth +\ called before the text interpreter parses the next line +' noop IS before-line + +[THEN] + +has? backtrace [IF] +: interpret1 ( ... -- ... ) + rp@ backtrace-rp0 ! + [ has? EC 0= [IF] ] before-line [ [THEN] ] + BEGIN + ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup + WHILE + parser1 execute + REPEAT + 2drop ; + : interpret ( ?? -- ?? ) \ gforth \ interpret/compile the (rest of the) input buffer -[ has? backtrace [IF] ] - rp@ backtrace-rp0 ! -[ [THEN] ] + backtrace-rp0 @ >r + ['] interpret1 catch + r> backtrace-rp0 ! + throw ; +[ELSE] +: interpret ( ... -- ... ) BEGIN - ?stack name dup + ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup WHILE - parser + parser1 execute REPEAT 2drop ; +[THEN] \ interpreter 30apr92py +[IFDEF] prelude-mask +: run-prelude ( nt|0 -- nt|0 ) + \ run the prelude of the name identified by nt (if present). This + \ is used in the text interpreter and similar stuff. + dup if + dup name>prelude execute + then ; +[THEN] + +has? recognizer 0= [IF] \ not the most efficient implementations of interpreter and compiler -: interpreter ( c-addr u -- ) - 2dup find-name dup +: interpreter1 ( c-addr u -- ... xt ) + 2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup if - nip nip name>int execute + nip nip name>int else drop 2dup 2>r snumber? IF - 2rdrop + 2rdrop ['] noop ELSE - 2r> interpreter-notfound + 2r> interpreter-notfound1 THEN then ; -' interpreter IS parser +' interpreter1 IS parser1 +[THEN] \ \ Query Evaluate 07apr93py has? file 0= [IF] : sourceline# ( -- n ) 1 ; +[ELSE] +has? new-input 0= [IF] +Variable #fill-bytes +\G number of bytes read via (read-line) by the last refill +[THEN] [THEN] +has? new-input 0= [IF] +: input-start-line ( -- ) >in off ; : refill ( -- flag ) \ core-ext,block-ext,file-ext \G Attempt to fill the input buffer from the input source. When \G the input source is the user input device, attempt to receive @@ -534,21 +772,22 @@ has? file 0= [IF] \G and return true; otherwise, return false. A successful result \G includes receipt of a line containing 0 characters. [ has? file [IF] ] - blk @ IF 1 blk +! true 0 >in ! EXIT THEN + blk @ IF 1 blk +! true EXIT THEN [ [THEN] ] tib /line [ has? file [IF] ] loadfile @ ?dup - IF read-line throw + IF (read-line) throw #fill-bytes ! ELSE [ [THEN] ] sourceline# 0< IF 2drop false EXIT THEN - accept true + accept eof @ 0= [ has? file [IF] ] THEN 1 loadline +! [ [THEN] ] - swap #tib ! 0 >in ! ; + swap #tib ! + input-start-line ; : query ( -- ) \ core-ext \G Make the user input device the input source. Receive input into @@ -557,7 +796,8 @@ has? file 0= [IF] [ has? file [IF] ] blk off loadfile off [ [THEN] ] - tib /line accept #tib ! 0 >in ! ; + refill drop ; +[THEN] \ save-mem extend-mem @@ -568,16 +808,27 @@ has? os [IF] dup allocate throw swap 2dup r> -rot move ; +: free-mem-var ( addr -- ) + \ addr is the address of a 2variable containing address and size + \ of a memory range; frees memory and clears the 2variable. + dup 2@ drop dup + if ( addr mem-start ) + free throw + 0 0 rot 2! + else + 2drop + then ; + : extend-mem ( addr1 u1 u -- addr addr2 u2 ) \ extend memory block allocated from the heap by u aus - \ the (possibly reallocated piece is addr2 u2, the extension is at addr + \ the (possibly reallocated) piece is addr2 u2, the extension is at addr over >r + dup >r resize throw r> over r> + -rot ; [THEN] \ EVALUATE 17may93jaw -has? file 0= [IF] +has? file 0= has? new-input 0= and [IF] : push-file ( -- ) r> tibstack @ >r >tib @ >r #tib @ >r >tib @ tibstack @ = IF r@ tibstack +! THEN @@ -588,65 +839,107 @@ has? file 0= [IF] r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ; [THEN] +has? new-input 0= [IF] : evaluate ( c-addr u -- ) \ core,block \G Save the current input source specification. Store @code{-1} in \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to \G @code{0} and make the string @i{c-addr u} the input source \G and input buffer. Interpret. When the parse area is empty, \G restore the input source specification. +[ has? file [IF] ] + s" *evaluated string*" loadfilename>r +[ [THEN] ] push-file #tib ! >tib ! - >in off + input-start-line [ has? file [IF] ] blk off loadfile off -1 loadline ! [ [THEN] ] ['] interpret catch - pop-file throw ; + pop-file +[ has? file [IF] ] + r>loadfilename +[ [THEN] ] + throw ; +[THEN] \ \ Quit 13feb93py Defer 'quit -Defer .status +has? os [IF] + Defer .status +[ELSE] + [IFUNDEF] bye + : (bye) ( 0 -- ) \ back to DOS + drop 5 emit ; + + : bye ( -- ) 0 (bye) ; + [THEN] +[THEN] : prompt state @ IF ." compiled" EXIT THEN ." ok" ; -: (Query) ( -- ) - [ has? file [IF] ] - loadfile off blk off loadline off - [ [THEN] ] - refill drop ; - : (quit) ( -- ) \ exits only through THROW etc. -\ sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer - \ stored in the system's CATCH frame, so the stack depth will be 0 - \ after the next THROW it catches (it may be off due to BOUNCEs or - \ because process-args left something on the stack) BEGIN - .status cr (query) interpret prompt - AGAIN ; + [ has? ec [IF] ] cr [ [ELSE] ] + .status ['] cr catch if + [ has? OS [IF] ] >stderr [ [THEN] ] + cr ." Can't print to stdout, leaving" cr + \ if stderr does not work either, already DoError causes a hang + -2 (bye) + endif [ [THEN] ] + refill WHILE + interpret prompt + REPEAT + bye ; ' (quit) IS 'quit \ \ DOERROR (DOERROR) 13jun93jaw +has? os [IF] 8 Constant max-errors +5 has? file 2 and + Constant /error Variable error-stack 0 error-stack ! -max-errors 6 * cells allot +max-errors /error * cells allot \ format of one cell: -\ source ( addr u ) -\ >in +\ source ( c-addr u ) +\ last parsed lexeme ( c-addr u ) \ line-number \ Loadfilename ( addr u ) +: error> ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) + -1 error-stack +! + error-stack dup @ + /error * cells + cell+ + /error cells bounds DO + I @ + cell +LOOP ; + +: >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- ) + error-stack dup @ dup 1+ + max-errors 1- min error-stack ! + /error * cells + cell+ + /error 1- cells bounds swap DO + I ! + -1 cells +LOOP ; + +: input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) + \ error data for the current input, to be used by >error or .error-frame + source over >r save-mem over r> - + input-lexeme 2@ >r + r> sourceline# + [ has? file [IF] ] sourcefilename [ [THEN] ] ; + : dec. ( n -- ) \ gforth \G Display @i{n} as a signed decimal number, followed by a space. \ !! not used... base @ decimal swap . base ! ; -: dec.r ( u -- ) \ gforth - \G Display @i{u} as a unsigned decimal number - base @ decimal swap 0 .r base ! ; +: dec.r ( u n -- ) \ gforth + \G Display @i{u} as a unsigned decimal number in a field @i{n} + \G characters wide. + base @ >r decimal .r r> base ! ; : hex. ( u -- ) \ gforth \G Display @i{u} as an unsigned hex number, prefixed with a "$" and @@ -654,16 +947,14 @@ max-errors 6 * cells allot \ !! not used... [char] $ emit base @ swap hex u. base ! ; -: typewhite ( addr u -- ) \ gforth - \G Like type, but white space is printed instead of the characters. - bounds ?do - i c@ #tab = if \ check for tab - #tab - else - bl - then - emit - loop ; +: -trailing ( c_addr u1 -- c_addr u2 ) \ string dash-trailing +\G Adjust the string specified by @i{c-addr, u1} to remove all +\G trailing spaces. @i{u2} is the length of the modified string. + BEGIN + dup + WHILE + 1- 2dup + c@ bl <> + UNTIL 1+ THEN ; DEFER DOERROR @@ -678,43 +969,67 @@ Defer dobacktrace ( -- ) ELSE .error THEN ; -: .error-frame ( throwcode addr1 u1 n1 n2 addr2 u2 -- throwcode ) -\ addr2 u2: filename of included file -\ n2: line number -\ n1: error position in input line -\ addr1 u1: input line - - cr error-stack @ - IF - ." in file included from " - type ." :" dec.r drop 2drop - ELSE - type ." :" dec.r ." : " 3 pick .error-string 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 ; +[IFUNDEF] umin +: umin ( u1 u2 -- u ) + 2dup u> + if + swap + then + drop ; +[THEN] + +Defer mark-start +Defer mark-end + +:noname ." >>>" ; IS mark-start +:noname ." <<<" ; IS mark-end + +: part-type ( addr1 u1 u -- addr2 u2 ) + \ print first u characters of addr1 u1, addr2 u2 is the rest + over umin 2 pick over type /string ; + +: .error-line ( c-addr1 u1 c-addr2 u2 -- ) + \ print error in line c-addr1 u1, where the error-causing lexeme + \ is c-addr2 u2 + >r 2 pick - part-type ( c-addr3 u3 R: u2 ) + mark-start r> part-type mark-end ( c-addr4 u4 ) + type ; + +: .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode ) + \ addr3 u3: filename of included file - optional + \ n2: line number + \ addr2 u2: parsed lexeme (should be marked as causing the error) + \ addr1 u1: input line + error-stack @ + IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] ) + [ has? file [IF] ] \ !! unbalanced stack effect + over IF + cr ." in file included from " + type ." :" + 0 dec.r 2drop 2drop + ELSE + 2drop 2drop 2drop drop + THEN + [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 ) + ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] ) + [ has? file [IF] ] + cr type ." :" + [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 ) + dup 0 dec.r ." : " 5 pick .error-string + IF \ if line# non-zero, there is a line + cr .error-line + ELSE + 2drop 2drop + THEN + THEN ; : (DoError) ( throw-code -- ) [ has? os [IF] ] >stderr [ [THEN] ] - sourceline# IF - source >in @ sourceline# 0 0 .error-frame - THEN + input-error-data .error-frame error-stack @ 0 ?DO - -1 error-stack +! - error-stack dup @ 6 * cells + cell+ - 6 cells bounds DO - I @ - cell +LOOP + error> .error-frame LOOP drop @@ -725,62 +1040,93 @@ Defer dobacktrace ( -- ) ' (DoError) IS DoError +[ELSE] + : dec. base @ >r decimal . r> base ! ; + : DoError ( throw-code -- ) + cr source drop >in @ type ." <<< " + dup -2 = IF "error @ type drop EXIT THEN + .error ; +[THEN] + : quit ( ?? -- ?? ) \ core \G Empty the return stack, make the user input device \G the input source, enter interpret state and start \G the text interpreter. - rp0 @ rp! handler off clear-tibstack >tib @ >r + rp0 @ rp! handler off clear-tibstack + [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ] BEGIN [ has? compiler [IF] ] - postpone [ + [compile] [ [ [THEN] ] + \ stack depths may be arbitrary here ['] 'quit CATCH dup WHILE - <# \ reset hold area, or we may get another error - DoError r@ >tib ! r@ tibstack ! + <# \ reset hold area, or we may get another error + DoError + \ stack depths may be arbitrary still (or again), so clear them + clearstacks + [ has? new-input [IF] ] clear-tibstack + [ [ELSE] ] r@ >tib ! r@ tibstack ! + [ [THEN] ] REPEAT - drop r> >tib ! ; + drop [ has? new-input [IF] ] clear-tibstack + [ [ELSE] ] r> >tib ! + [ [THEN] ] ; + +: do-execute ( xt -- ) \ Gforth + \G C calling us + catch dup IF DoError cr THEN (bye) ; + +: do-find ( addr u -- ) + find-name dup IF name>int THEN (bye) ; \ \ Cold Boot 13feb93py -: (bootmessage) - ." GForth " version-string type - ." , Copyright (C) 1995-2000 Free Software Foundation, Inc." cr - ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" +: gforth ( -- ) + ." Gforth " version-string type + ." , Copyright (C) 1995-2012 Free Software Foundation, Inc." cr + ." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'" [ has? os [IF] ] cr ." Type `bye' to exit" [ [THEN] ] ; -defer bootmessage +defer bootmessage ( -- ) \ gforth +\G Hook (deferred word) executed right after interpreting the OS +\G command-line arguments. Normally prints the Gforth startup +\G message. + +has? file [IF] defer process-args +[THEN] -' (bootmessage) IS bootmessage +' gforth IS bootmessage +has? os [IF] Defer 'cold ( -- ) \ gforth tick-cold -\ hook (deferred word) for things to do right before interpreting the -\ command-line arguments +\G Hook (deferred word) for things to do right before interpreting the +\G OS command-line arguments. Normally does some initializations that +\G you also want to perform. ' noop IS 'cold - - -Variable init8 +[THEN] : cold ( -- ) \ gforth [ has? backtrace [IF] ] rp@ backtrace-rp0 ! [ [THEN] ] [ has? file [IF] ] - pathstring 2@ fpath only-path - init-included-files + os-cold [ [THEN] ] +[ has? os [IF] ] + set-encoding-fixed-width 'cold - init8 chainperform +[ [THEN] ] [ has? file [IF] ] process-args loadline off [ [THEN] ] - bootmessage - quit ; + 1 (bye) ; +has? new-input 0= [IF] : clear-tibstack ( -- ) [ has? glocals [IF] ] lp@ forthstart 7 cells + @ - @@ -788,30 +1134,56 @@ Variable init8 [ has? os [IF] ] r0 @ forthstart 6 cells + @ - [ [ELSE] ] - sp@ $10 cells + + sp@ cell+ [ [THEN] ] [ [THEN] ] - dup >tib ! tibstack ! #tib off >in off ; + dup >tib ! tibstack ! #tib off + input-start-line ; +[THEN] -: boot ( path **argv argc -- ) - main-task up! +: boot ( path n **argv argc -- ) +[ has? no-userspace 0= [IF] ] + next-task 0= IF main-task up! + ELSE + next-task @ 0= IF + throw-entry main-task udp @ throw-entry next-task - + /string >r swap r> move + next-task dup next-task 2! normal-dp dpp ! + THEN + THEN +[ [THEN] ] [ has? os [IF] ] - stdout TO outfile-id - stdin TO infile-id -\ !! [ [THEN] ] -\ !! [ has? file [IF] ] - argc ! argv ! pathstring 2! + os-boot +[ [THEN] ] +[ has? rom [IF] ] + ram-shadow dup @ dup -1 <> >r u> r> and IF + ram-shadow 2@ ELSE + ram-mirror ram-size THEN ram-start swap move [ [THEN] ] sp@ sp0 ! +[ has? peephole [IF] ] + \ only needed for greedy static superinstruction selection + \ primtable prepare-peephole-table TO peeptable +[ [THEN] ] +[ has? new-input [IF] ] + current-input off +[ [THEN] ] clear-tibstack + 0 0 includefilename 2! rp@ rp0 ! [ has? floating [IF] ] fp@ fp0 ! [ [THEN] ] +[ has? os [IF] ] handler off - ['] cold catch DoError cr + ['] cold catch dup -&2049 <> if \ broken pipe? + DoError cr + endif +[ [ELSE] ] + cold +[ [THEN] ] [ has? os [IF] ] - 1 (bye) \ !! determin exit code from throw code? + -1 (bye) \ !! determin exit code from throw code? [ [THEN] ] ;