--- gforth/kernel/int.fs 2007/07/06 12:54:57 1.158 +++ 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,2004,2005 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,7 +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 kernel/version.fs \ version-string has? new-input 0= [IF] : tib ( -- c-addr ) \ core-ext t-i-b @@ -52,35 +51,7 @@ 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-obsolete 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 -[ has? new-input [IF] ] - 2dup input-lexeme! -[ [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 @@ -114,7 +85,7 @@ Defer source ( -- c-addr u ) \ core \ \ Number parsing 23feb93py -\ number? number 23feb93py +\ (number?) number 23feb93py hex const Create bases 0A , 10 , 2 , 0A , @@ -141,6 +112,11 @@ const Create bases 0A , 10 , 2 , 0 THEN r> ; +: ?dnegate ( d1 f -- d2 ) + if + dnegate + then ; + has? os 0= [IF] : x@+/string ( addr u -- addr' u' c ) over c@ >r 1 /string r> ; @@ -153,27 +129,30 @@ has? os 0= [IF] endif x@+/string 0 s" '" 2rot string-prefix? ; -: s>unumber? ( addr u -- ud flag ) \ gforth - \G converts string addr u into ud, flag indicates success +: 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 - 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 + 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 @@ -184,10 +163,7 @@ has? os 0= [IF] 0= IF rdrop false ELSE \ no characters left, all ok - r> - IF - dnegate - THEN + r> ?dnegate true THEN ; @@ -206,7 +182,7 @@ has? os 0= [IF] 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 @@ -214,7 +190,7 @@ has? os 0= [IF] then ; : number ( string -- d ) - number? ?dup 0= abort" ?" 0< + (number?) ?dup 0= abort" ?" 0< IF s>d THEN ; @@ -286,7 +262,7 @@ has? f83headerstring [IF] 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 ! @@ -330,11 +306,15 @@ forth-wordlist current ! 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] +[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 @@ -347,8 +327,12 @@ $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] @@ -446,6 +430,15 @@ has? f83headerstring [IF] (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 , char ? c, char ? c, char ? c, \ ??? is used by dovar:, must be created/:dovar @@ -453,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 @@ -463,20 +483,17 @@ 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 @@ -549,19 +566,20 @@ has? flash [IF] ' flash! [ELSE] ' ! [THE 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>}. [ has? flash [IF] ] dodoes: over flash! cell+ flash! [ [ELSE] ] - dodoes: over ! cell+ ! + dodoes: any-code! [ [THEN] ] ; -' 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>}. - 2 cells constant /does-handler ( -- n ) \ gforth \G The size of a @code{DOES>}-handler (includes possible padding). @@ -632,7 +650,6 @@ Defer parser1 ( c-addr u -- ... xt) : 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 ; @@ -649,22 +666,31 @@ Defer parse-name ( "name" -- c-addr u ) ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete \G old name for @code{parse-name} +: no.extensions ( addr u -- ) + 2drop -&13 throw ; + +has? recognizer 0= [IF] Defer compiler-notfound1 ( c-addr count -- ... xt ) Defer interpreter-notfound1 ( c-addr count -- ... xt ) -: no.extensions ( addr u -- ) - 2drop -&13 throw ; ' 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 @@ -690,9 +716,19 @@ has? backtrace [IF] \ 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 : interpreter1 ( c-addr u -- ... xt ) - 2dup find-name dup + 2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup if nip nip name>int else @@ -706,6 +742,7 @@ has? backtrace [IF] then ; ' interpreter1 IS parser1 +[THEN] \ \ Query Evaluate 07apr93py @@ -832,10 +869,12 @@ Defer 'quit has? os [IF] Defer .status [ELSE] -: (bye) ( 0 -- ) \ back to DOS - drop 5 emit ; - -: bye ( -- ) 0 (bye) ; + [IFUNDEF] bye + : (bye) ( 0 -- ) \ back to DOS + drop 5 emit ; + + : bye ( -- ) 0 (bye) ; + [THEN] [THEN] : prompt state @ IF ." compiled" EXIT THEN ." ok" ; @@ -848,7 +887,7 @@ has? os [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) + -2 (bye) endif [ [THEN] ] refill WHILE interpret prompt @@ -888,7 +927,8 @@ max-errors /error * cells allot : 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 input-lexeme 2@ sourceline# + source over >r save-mem over r> - + input-lexeme 2@ >r + r> sourceline# [ has? file [IF] ] sourcefilename [ [THEN] ] ; : dec. ( n -- ) \ gforth @@ -929,12 +969,14 @@ Defer dobacktrace ( -- ) ELSE .error THEN ; +[IFUNDEF] umin : umin ( u1 u2 -- u ) 2dup u> if swap then drop ; +[THEN] Defer mark-start Defer mark-end @@ -1031,11 +1073,18 @@ Defer mark-end [ [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 ( -- ) ." Gforth " version-string type - ." , Copyright (C) 1995-2006 Free Software Foundation, Inc." cr + ." , 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" @@ -1050,7 +1099,7 @@ has? file [IF] defer process-args [THEN] -' (bootmessage) IS bootmessage +' gforth IS bootmessage has? os [IF] Defer 'cold ( -- ) \ gforth tick-cold @@ -1075,8 +1124,7 @@ Defer 'cold ( -- ) \ gforth tick-cold process-args loadline off [ [THEN] ] - bootmessage - quit ; + 1 (bye) ; has? new-input 0= [IF] : clear-tibstack ( -- ) @@ -1095,7 +1143,14 @@ has? new-input 0= [IF] : boot ( path n **argv argc -- ) [ has? no-userspace 0= [IF] ] - main-task up! + 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 @@ -1128,7 +1183,7 @@ has? new-input 0= [IF] cold [ [THEN] ] [ has? os [IF] ] - 1 (bye) \ !! determin exit code from throw code? + -1 (bye) \ !! determin exit code from throw code? [ [THEN] ] ;