version 1.172, 2009/12/31 15:32:36
|
version 1.195, 2012/12/31 15:25:19
|
Line 1
|
Line 1
|
\ definitions needed for interpreter only |
\ definitions needed for interpreter only |
|
|
\ Copyright (C) 1995-2000,2004,2005,2007,2009 Free Software Foundation, Inc. |
\ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 51 Defer source ( -- c-addr u ) \ core
|
Line 51 Defer source ( -- c-addr u ) \ core
|
\ (word) should fold white spaces |
\ (word) should fold white spaces |
\ this is what (parse-white) does |
\ this is what (parse-white) does |
|
|
\ word parse 23feb93py |
\ 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 "<chars>ccc<char>-- 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 ( char "ccc<char>" -- c-addr u ) \ core-ext |
: parse ( char "ccc<char>" -- c-addr u ) \ core-ext |
\G Parse @i{ccc}, delimited by @i{char}, in the parse |
\G Parse @i{ccc}, delimited by @i{char}, in the parse |
Line 171 has? os 0= [IF]
|
Line 143 has? os 0= [IF]
|
WHILE \ there are characters left |
WHILE \ there are characters left |
dup r> - |
dup r> - |
WHILE \ the last >number parsed something |
WHILE \ the last >number parsed something |
dup 1- dpl ! over c@ [char] . = |
dup 1- dpl ! over c@ dp-char @ = |
WHILE \ the current char is '.' |
WHILE \ the current char is '.' |
1 /string |
1 /string |
REPEAT THEN \ there are unparseable characters left |
REPEAT THEN \ there are unparseable characters left |
Line 334 forth-wordlist current !
|
Line 306 forth-wordlist current !
|
|
|
has? f83headerstring [IF] |
has? f83headerstring [IF] |
\ to save space, Gforth EC limits words to 31 characters |
\ to save space, Gforth EC limits words to 31 characters |
|
\ also, there's no predule concept in Gforth EC |
$80 constant alias-mask |
$80 constant alias-mask |
$40 constant immediate-mask |
$40 constant immediate-mask |
$20 constant restrict-mask |
$20 constant restrict-mask |
Line 457 has? f83headerstring [IF]
|
Line 430 has? f83headerstring [IF]
|
(name>x) tuck (x>int) ( w xt ) |
(name>x) tuck (x>int) ( w xt ) |
swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ; |
swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ; |
|
|
|
[IFDEF] prelude-mask |
: name>prelude ( nt -- xt ) |
: name>prelude ( nt -- xt ) |
dup cell+ @ prelude-mask and if |
dup cell+ @ prelude-mask and if |
[ -1 cells ] literal + @ |
[ -1 cells ] literal + @ |
else |
else |
drop ['] noop |
drop ['] noop |
then ; |
then ; |
|
[THEN] |
|
|
const Create ??? 0 , 3 , char ? c, char ? c, char ? c, |
const Create ??? 0 , 3 , char ? c, char ? c, char ? c, |
\ ??? is used by dovar:, must be created/:dovar |
\ ??? is used by dovar:, must be created/:dovar |
Line 471 const Create ??? 0 , 3 , char ? c, char
|
Line 446 const Create ??? 0 , 3 , char ? c, char
|
\ if we have a forthstart we can define head? with it |
\ if we have a forthstart we can define head? with it |
\ otherwise leave out the head? check |
\ 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 ) |
: head? ( addr -- f ) |
\G heuristic check whether addr is a name token; may deliver false |
\G heuristic check whether addr is a name token; may deliver false |
\G positives; addr must be a valid address; returns 1 for |
\G positives; addr must be a valid address; returns 1 for |
Line 481 const Create ??? 0 , 3 , char ? c, char
|
Line 483 const Create ??? 0 , 3 , char ? c, char
|
\ some code), which is typically not in the dictionary. |
\ some code), which is typically not in the dictionary. |
\ we added a third iteration for working with code and ;code words. |
\ we added a third iteration for working with code and ;code words. |
3 0 do |
3 0 do |
dup dup aligned <> if \ protect @ against unaligned accesses |
dup one-head? 0= if |
drop false unloop exit |
drop false unloop exit |
then |
endif |
dup @ dup |
dup @ dup 0= if |
if ( addr addr1 ) |
2drop 1 unloop exit |
dup rot forthstart within |
else |
if \ addr1 is outside forthstart..addr, not a head |
dup rot forthstart within if |
drop false unloop exit |
drop false unloop exit |
then ( addr1 ) |
then |
else \ 0 in the link field, no further checks |
|
2drop 1 unloop exit \ this is very unsure, so return 1 |
|
then |
then |
loop |
loop |
\ in dubio pro: |
|
drop true ; |
drop true ; |
|
|
: >head-noprim ( cfa -- nt ) \ gforth to-head-noprim |
: >head-noprim ( cfa -- nt ) \ gforth to-head-noprim |
Line 567 has? flash [IF] ' flash! [ELSE] ' ! [THE
|
Line 566 has? flash [IF] ' flash! [ELSE] ' ! [THE
|
alias code-address! ( c_addr xt -- ) \ gforth |
alias code-address! ( c_addr xt -- ) \ gforth |
\G Create a code field with code address @i{c-addr} at @i{xt}. |
\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 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>}. |
\G @i{a-addr} is the start of the Forth code after @code{DOES>}. |
[ has? flash [IF] ] |
[ has? flash [IF] ] |
dodoes: over flash! cell+ flash! |
dodoes: over flash! cell+ flash! |
[ [ELSE] ] |
[ [ELSE] ] |
dodoes: over ! cell+ ! |
dodoes: any-code! |
[ [THEN] ] ; |
[ [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 |
2 cells constant /does-handler ( -- n ) \ gforth |
\G The size of a @code{DOES>}-handler (includes possible padding). |
\G The size of a @code{DOES>}-handler (includes possible padding). |
|
|
Line 650 Defer parser1 ( c-addr u -- ... xt)
|
Line 650 Defer parser1 ( c-addr u -- ... xt)
|
: parser ( c-addr u -- ... ) |
: parser ( c-addr u -- ... ) |
\ text-interpret the word/number c-addr u, possibly producing a number |
\ text-interpret the word/number c-addr u, possibly producing a number |
parser1 execute ; |
parser1 execute ; |
|
|
has? ec [IF] |
has? ec [IF] |
' (name) Alias parse-name |
' (name) Alias parse-name |
: no.extensions 2drop -&13 throw ; |
: no.extensions 2drop -&13 throw ; |
Line 667 Defer parse-name ( "name" -- c-addr u )
|
Line 666 Defer parse-name ( "name" -- c-addr u )
|
' parse-name alias name ( -- c-addr u ) \ gforth-obsolete |
' parse-name alias name ( -- c-addr u ) \ gforth-obsolete |
\G old name for @code{parse-name} |
\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 compiler-notfound1 ( c-addr count -- ... xt ) |
Defer interpreter-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 compiler-notfound1 |
' no.extensions IS interpreter-notfound1 |
' no.extensions IS interpreter-notfound1 |
|
[THEN] |
|
|
Defer before-word ( -- ) \ gforth |
Defer before-word ( -- ) \ gforth |
\ called before the text interpreter parses the next word |
\ called before the text interpreter parses the next word |
' noop IS before-word |
' noop IS before-word |
|
|
|
Defer before-line ( -- ) \ gforth |
|
\ called before the text interpreter parses the next line |
|
' noop IS before-line |
|
|
[THEN] |
[THEN] |
|
|
has? backtrace [IF] |
has? backtrace [IF] |
: interpret1 ( ... -- ... ) |
: interpret1 ( ... -- ... ) |
rp@ backtrace-rp0 ! |
rp@ backtrace-rp0 ! |
|
[ has? EC 0= [IF] ] before-line [ [THEN] ] |
BEGIN |
BEGIN |
?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup |
?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup |
WHILE |
WHILE |
Line 708 has? backtrace [IF]
|
Line 716 has? backtrace [IF]
|
|
|
\ interpreter 30apr92py |
\ interpreter 30apr92py |
|
|
|
[IFDEF] prelude-mask |
: run-prelude ( nt|0 -- nt|0 ) |
: run-prelude ( nt|0 -- nt|0 ) |
\ run the prelude of the name identified by nt (if present). This |
\ run the prelude of the name identified by nt (if present). This |
\ is used in the text interpreter and similar stuff. |
\ is used in the text interpreter and similar stuff. |
dup if |
dup if |
dup name>prelude execute |
dup name>prelude execute |
then ; |
then ; |
|
[THEN] |
|
|
|
has? recognizer 0= [IF] |
\ not the most efficient implementations of interpreter and compiler |
\ not the most efficient implementations of interpreter and compiler |
: interpreter1 ( c-addr u -- ... xt ) |
: interpreter1 ( c-addr u -- ... xt ) |
2dup find-name run-prelude dup |
2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup |
if |
if |
nip nip name>int |
nip nip name>int |
else |
else |
Line 731 has? backtrace [IF]
|
Line 742 has? backtrace [IF]
|
then ; |
then ; |
|
|
' interpreter1 IS parser1 |
' interpreter1 IS parser1 |
|
[THEN] |
|
|
\ \ Query Evaluate 07apr93py |
\ \ Query Evaluate 07apr93py |
|
|
Line 875 has? os [IF]
|
Line 887 has? os [IF]
|
[ has? OS [IF] ] >stderr [ [THEN] ] |
[ has? OS [IF] ] >stderr [ [THEN] ] |
cr ." Can't print to stdout, leaving" cr |
cr ." Can't print to stdout, leaving" cr |
\ if stderr does not work either, already DoError causes a hang |
\ if stderr does not work either, already DoError causes a hang |
2 (bye) |
-2 (bye) |
endif [ [THEN] ] |
endif [ [THEN] ] |
refill WHILE |
refill WHILE |
interpret prompt |
interpret prompt |
Line 915 max-errors /error * cells allot
|
Line 927 max-errors /error * cells allot
|
|
|
: input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] ) |
: 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 |
\ 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] ] ; |
[ has? file [IF] ] sourcefilename [ [THEN] ] ; |
|
|
: dec. ( n -- ) \ gforth |
: dec. ( n -- ) \ gforth |
Line 956 Defer dobacktrace ( -- )
|
Line 969 Defer dobacktrace ( -- )
|
ELSE .error |
ELSE .error |
THEN ; |
THEN ; |
|
|
|
[IFUNDEF] umin |
: umin ( u1 u2 -- u ) |
: umin ( u1 u2 -- u ) |
2dup u> |
2dup u> |
if |
if |
swap |
swap |
then |
then |
drop ; |
drop ; |
|
[THEN] |
|
|
Defer mark-start |
Defer mark-start |
Defer mark-end |
Defer mark-end |
Line 1058 Defer mark-end
|
Line 1073 Defer mark-end
|
[ [ELSE] ] r> >tib ! |
[ [ELSE] ] r> >tib ! |
[ [THEN] ] ; |
[ [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 |
\ \ Cold Boot 13feb93py |
|
|
: (bootmessage) ( -- ) |
: gforth ( -- ) |
." Gforth " version-string type |
." Gforth " version-string type |
." , Copyright (C) 1995-2009 Free Software Foundation, Inc." cr |
." , Copyright (C) 1995-2012 Free Software Foundation, Inc." cr |
." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
[ has? os [IF] ] |
[ has? os [IF] ] |
cr ." Type `bye' to exit" |
cr ." Type `bye' to exit" |
Line 1077 has? file [IF]
|
Line 1099 has? file [IF]
|
defer process-args |
defer process-args |
[THEN] |
[THEN] |
|
|
' (bootmessage) IS bootmessage |
' gforth IS bootmessage |
|
|
has? os [IF] |
has? os [IF] |
Defer 'cold ( -- ) \ gforth tick-cold |
Defer 'cold ( -- ) \ gforth tick-cold |
Line 1102 Defer 'cold ( -- ) \ gforth tick-cold
|
Line 1124 Defer 'cold ( -- ) \ gforth tick-cold
|
process-args |
process-args |
loadline off |
loadline off |
[ [THEN] ] |
[ [THEN] ] |
bootmessage |
1 (bye) ; |
quit ; |
|
|
|
has? new-input 0= [IF] |
has? new-input 0= [IF] |
: clear-tibstack ( -- ) |
: clear-tibstack ( -- ) |
Line 1122 has? new-input 0= [IF]
|
Line 1143 has? new-input 0= [IF]
|
|
|
: boot ( path n **argv argc -- ) |
: boot ( path n **argv argc -- ) |
[ has? no-userspace 0= [IF] ] |
[ 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] ] |
[ [THEN] ] |
[ has? os [IF] ] |
[ has? os [IF] ] |
os-boot |
os-boot |
Line 1155 has? new-input 0= [IF]
|
Line 1183 has? new-input 0= [IF]
|
cold |
cold |
[ [THEN] ] |
[ [THEN] ] |
[ has? os [IF] ] |
[ has? os [IF] ] |
1 (bye) \ !! determin exit code from throw code? |
-1 (bye) \ !! determin exit code from throw code? |
[ [THEN] ] |
[ [THEN] ] |
; |
; |
|
|