--- gforth/kernel/int.fs 2009/09/05 17:38:38 1.169 +++ gforth/kernel/int.fs 2012/12/31 15:25:19 1.195 @@ -1,6 +1,6 @@ \ definitions needed for interpreter only -\ Copyright (C) 1995-2000,2004,2005,2007 Free Software Foundation, Inc. +\ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -51,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 @@ -171,7 +143,7 @@ has? os 0= [IF] WHILE \ there are characters left dup r> - WHILE \ the last >number parsed something - dup 1- dpl ! over c@ [char] . = + dup 1- dpl ! over c@ dp-char @ = WHILE \ the current char is '.' 1 /string REPEAT THEN \ there are unparseable characters left @@ -325,11 +297,6 @@ forth-wordlist current ! \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) ; - -: find-name-run-prelude ( c-addr u -- nt | 0 ) - \ Like find-name, but also run the prelude (if present). This is - \ used in the text interpreter and similar stuff. - find-name ; \ dup name>prelude execute ; [THEN] \ \ header, finding, ticks 17dec92py @@ -339,6 +306,7 @@ 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 @@ -462,12 +430,14 @@ 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 @@ -476,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 @@ -486,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 @@ -572,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). @@ -655,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 ; @@ -672,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 @@ -713,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-run-prelude dup + 2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup if nip nip name>int else @@ -729,6 +742,7 @@ has? backtrace [IF] then ; ' interpreter1 IS parser1 +[THEN] \ \ Query Evaluate 07apr93py @@ -873,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 @@ -913,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 @@ -954,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 @@ -1056,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-2008 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" @@ -1075,7 +1099,7 @@ has? file [IF] defer process-args [THEN] -' (bootmessage) IS bootmessage +' gforth IS bootmessage has? os [IF] Defer 'cold ( -- ) \ gforth tick-cold @@ -1100,8 +1124,7 @@ Defer 'cold ( -- ) \ gforth tick-cold process-args loadline off [ [THEN] ] - bootmessage - quit ; + 1 (bye) ; has? new-input 0= [IF] : clear-tibstack ( -- ) @@ -1120,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 @@ -1153,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] ] ;