--- gforth/kernel/int.fs 2003/01/10 21:19:59 1.86 +++ 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. \ \ Revision-Log @@ -28,8 +27,7 @@ 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 @@ -53,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 +! ; + >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 @@ -89,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] @@ -101,58 +85,85 @@ Defer source ( -- c-addr u ) \ core \ \ 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 ; @@ -171,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 @@ -179,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 ; @@ -210,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: @@ -229,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 ; @@ -239,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 ! @@ -255,11 +278,43 @@ 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 \ 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 @@ -272,10 +327,15 @@ $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] -$1fffffff constant lcount-mask -1 bits/char 3 - lshift 1 - +$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 @@ -286,6 +346,9 @@ $1fffffff constant lcount-mask : ticking-compile-only-error ( ... -- ) -&2048 throw ; +: compile-only-error ( ... -- ) + -&14 throw ; + : (cfa>int) ( cfa -- xt ) [ has? compiler [IF] ] dup interpret/compile? @@ -296,14 +359,30 @@ $1fffffff constant lcount-mask : (x>int) ( cfa w -- xt ) \ get interpretation semantics of name - restrict-mask and + restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ] if - drop ['] ticking-compile-only-error + 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 lcount-mask and ; + +: ((name>)) ( nfa -- cfa ) + name>string + cfaligned ; + +: (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 ; @@ -317,18 +396,19 @@ $1fffffff constant lcount-mask IF swap @ swap THEN ; +[THEN] -: name>int ( nt -- xt ) \ gforth +: 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{ticking-compile-only-error}, which performs @code{-2048 throw}. (name>x) (x>int) ; -: name?int ( nt -- xt ) \ gforth +: 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 ticking-compile-only-error \ does not return then @@ -343,12 +423,21 @@ $1fffffff constant lcount-mask 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) ( w xt ) - swap immediate-mask and flag-sign ; + 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 , char ? c, char ? c, char ? c, \ ??? is used by dovar:, must be created/:dovar @@ -357,6 +446,33 @@ const Create ??? 0 , 3 , char ? c, char \ 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; returns 1 for @@ -367,31 +483,30 @@ const Create ??? 0 , 3 , char ? c, char \ some code), which is typically not in the dictionary. \ we added a third iteration for working with code and ;code words. 3 0 do - dup dup aligned <> if \ protect @ against unaligned accesses + 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 1 unloop exit \ this is very unsure, so return 1 + then then loop - \ in dubio pro: drop true ; : >head-noprim ( cfa -- nt ) \ gforth to-head-noprim - \ also heuristic; finds only names with up to 32 chars - $25 cell do ( cfa ) + \ 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 + = + swap + cell+ cfaligned over alias-mask + = if ( cfa ) dup i - cell - dup head? if @@ -419,7 +534,7 @@ const Create ??? 0 , 3 , char ? c, char [THEN] -cell% 2* 0 0 field >body ( xt -- a_addr ) \ core +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 @@ -442,43 +557,34 @@ has? standardthreading has? compiler and drop 0 endif ; -' ! alias code-address! ( c_addr xt -- ) \ gforth +has? prims [IF] + : flash! ! ; + : flashc! c! ; +[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}. -: does-code! ( a_addr xt -- ) \ gforth +: 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>}. - dodoes: over ! cell+ ! ; - -' drop alias does-handler! ( a_addr -- ) \ gforth -\G Create a @code{DOES>}-handler at address @i{a-addr}. Normally, -\G @i{a-addr} points just behind a @code{DOES>}. + [ has? flash [IF] ] + dodoes: over flash! cell+ flash! + [ [ELSE] ] + dodoes: any-code! + [ [THEN] ] ; 2 cells constant /does-handler ( -- n ) \ gforth \G The size of a @code{DOES>}-handler (includes possible padding). [THEN] -: (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) ; - : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete find-name dup if ( nt ) @@ -515,7 +621,7 @@ has? standardthreading has? compiler and \ ticks in interpreter : (') ( "name" -- nt ) \ gforth - name name-too-short? + parse-name name-too-short? find-name dup 0= IF drop -&13 throw @@ -538,62 +644,105 @@ has? compiler 0= [IF] \ interpreter only \ interpret 10mar92py -Defer parser ( c-addr u -- ) -Defer parse-word ( -- c-addr count ) \ gforth -\G Get the next word from the input buffer -' (name) IS parse-word - -' parse-word alias name ( -- c-addr u ) \ gforth-obsolete -\G old name for @code{parse-word} +Defer parser1 ( c-addr u -- ... xt) +\ "... xt" is the action to be performed by the text-interpretation of c-addr u -Defer compiler-notfound ( c-addr count -- ) -Defer interpreter-notfound ( c-addr count -- ) +: 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 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 ( ... -- ... ) -[ has? backtrace [IF] ] rp@ backtrace-rp0 ! -[ [THEN] ] + [ has? EC 0= [IF] ] before-line [ [THEN] ] BEGIN - ?stack name dup + ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup WHILE - parser + parser1 execute REPEAT 2drop ; : interpret ( ?? -- ?? ) \ gforth \ interpret/compile the (rest of the) input buffer -[ has? backtrace [IF] ] backtrace-rp0 @ >r -[ [THEN] ] ['] interpret1 catch -[ has? backtrace [IF] ] r> backtrace-rp0 ! - [ [THEN] ] throw ; +[ELSE] +: interpret ( ... -- ... ) + BEGIN + ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup + WHILE + 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 @@ -607,6 +756,7 @@ Variable #fill-bytes [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 @@ -622,7 +772,7 @@ has? new-input 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] ] @@ -631,12 +781,13 @@ has? new-input 0= [IF] 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 @@ -670,7 +821,7 @@ has? os [IF] : 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] @@ -696,18 +847,17 @@ has? new-input 0= [IF] \G and input buffer. Interpret. When the parse area is empty, \G restore the input source specification. [ has? file [IF] ] - loadfilename# @ >r - 1 loadfilename# ! \ "*evaluated string*" + 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 [ has? file [IF] ] - r> loadfilename# ! + r>loadfilename [ [THEN] ] throw ; [THEN] @@ -716,56 +866,80 @@ has? new-input 0= [IF] 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" ; : (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 has? file [IF] 6 [ELSE] 4 [THEN] * 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> ( -- addr u >in line# [addr u] ) +: error> ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) -1 error-stack +! error-stack dup @ - [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+ - [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO - I @ - cell +LOOP ; -: >error ( addr u >in line# [addr u] -- ) + /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 ! - [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+ - [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO - I ! - -1 cells +LOOP ; + /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 @@ -773,16 +947,14 @@ max-errors has? file [IF] 6 [ELSE] 4 [TH \ !! 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 @@ -797,46 +969,65 @@ Defer dobacktrace ( -- ) ELSE .error THEN ; -: .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode ) -\ addr2 u2: filename of included file - optional -\ n2: line number -\ n1: error position in input line -\ addr1 u1: input line - cr error-stack @ - IF -[ has? file [IF] ] - ." in file included from " - type ." :" -[ [THEN] ] - dec.r drop 2drop - ELSE -[ has? file [IF] ] - type ." :" -[ [THEN] ] - dup >r dec.r ." : " 3 pick .error-string - r> IF \ if line# non-zero, there is a line - 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 - ELSE - 2drop drop - THEN - 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] ] - source >in @ sourceline# [ has? file [IF] ] - sourcefilename - [ [THEN] ] .error-frame + input-error-data .error-frame error-stack @ 0 ?DO error> .error-frame @@ -849,6 +1040,14 @@ 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 @@ -857,42 +1056,58 @@ Defer dobacktrace ( -- ) [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ] BEGIN [ has? compiler [IF] ] - [compile] [ + [compile] [ [ [THEN] ] + \ stack depths may be arbitrary here ['] 'quit CATCH dup WHILE - <# \ reset hold area, or we may get another error - DoError - [ has? new-input [IF] ] clear-tibstack - [ [ELSE] ] r@ >tib ! r@ tibstack ! - [ [THEN] ] + <# \ 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 [ 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 - - -AVariable init8 NIL init8 ! +[THEN] : cold ( -- ) \ gforth [ has? backtrace [IF] ] @@ -901,15 +1116,15 @@ AVariable init8 NIL init8 ! [ has? file [IF] ] os-cold [ [THEN] ] +[ has? os [IF] ] + set-encoding-fixed-width 'cold - init8 chainperform +[ [THEN] ] [ has? file [IF] ] - loadfilename# off process-args loadline off [ [THEN] ] - bootmessage - quit ; + 1 (bye) ; has? new-input 0= [IF] : clear-tibstack ( -- ) @@ -919,33 +1134,56 @@ has? new-input 0= [IF] [ 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 n **argv argc -- ) - main-task up! +[ 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] ] 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] ] - primtable prepare-peephole-table TO peeptable + \ 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] ] ;