version 1.164, 2008/10/23 09:32:43
|
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 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 27 require ./basics.fs \ bounds decimal he
|
Line 27 require ./basics.fs \ bounds decimal he
|
require ./io.fs \ type ... |
require ./io.fs \ type ... |
require ./nio.fs \ . <# ... |
require ./nio.fs \ . <# ... |
require ./errore.fs \ .error ... |
require ./errore.fs \ .error ... |
require ./version.fs \ version-string |
require kernel/version.fs \ version-string |
|
|
has? new-input 0= [IF] |
has? new-input 0= [IF] |
: tib ( -- c-addr ) \ core-ext t-i-b |
: tib ( -- c-addr ) \ core-ext t-i-b |
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 113 Defer source ( -- c-addr u ) \ core
|
Line 85 Defer source ( -- c-addr u ) \ core
|
|
|
\ \ Number parsing 23feb93py |
\ \ Number parsing 23feb93py |
|
|
\ number? number 23feb93py |
\ (number?) number 23feb93py |
|
|
hex |
hex |
const Create bases 0A , 10 , 2 , 0A , |
const Create bases 0A , 10 , 2 , 0A , |
Line 163 has? os 0= [IF]
|
Line 135 has? os 0= [IF]
|
over c@ '' = if |
over c@ '' = if |
1 /string s'>unumber? exit |
1 /string s'>unumber? exit |
endif |
endif |
base @ >r getbase sign? >r |
base @ >r getbase sign? |
0. 2swap |
over if |
BEGIN ( d addr len ) |
>r 0. 2swap |
dup >r >number dup |
BEGIN ( d addr len ) |
WHILE \ there are characters left |
dup >r >number dup |
dup r> - |
WHILE \ there are characters left |
WHILE \ the last >number parsed something |
dup r> - |
dup 1- dpl ! over c@ [char] . = |
WHILE \ the last >number parsed something |
WHILE \ the current char is '.' |
dup 1- dpl ! over c@ dp-char @ = |
1 /string |
WHILE \ the current char is '.' |
REPEAT THEN \ there are unparseable characters left |
1 /string |
2drop rdrop false |
REPEAT THEN \ there are unparseable characters left |
|
2drop rdrop false |
|
ELSE |
|
rdrop 2drop r> ?dnegate true |
|
THEN |
ELSE |
ELSE |
rdrop 2drop r> ?dnegate true |
drop 2drop 0. false THEN |
THEN |
|
r> base ! ; |
r> base ! ; |
|
|
\ ouch, this is complicated; there must be a simpler way - anton |
\ ouch, this is complicated; there must be a simpler way - anton |
Line 207 has? os 0= [IF]
|
Line 182 has? os 0= [IF]
|
1+ |
1+ |
THEN ; |
THEN ; |
|
|
: number? ( string -- string 0 / n -1 / d 0> ) |
: (number?) ( string -- string 0 / n -1 / d 0> ) |
dup >r count snumber? dup if |
dup >r count snumber? dup if |
rdrop |
rdrop |
else |
else |
Line 215 has? os 0= [IF]
|
Line 190 has? os 0= [IF]
|
then ; |
then ; |
|
|
: number ( string -- d ) |
: number ( string -- d ) |
number? ?dup 0= abort" ?" 0< |
(number?) ?dup 0= abort" ?" 0< |
IF |
IF |
s>d |
s>d |
THEN ; |
THEN ; |
Line 287 has? f83headerstring [IF]
|
Line 262 has? f83headerstring [IF]
|
Create f83search ( -- wordlist-map ) |
Create f83search ( -- wordlist-map ) |
' f83find A, ' drop A, ' drop A, ' drop A, |
' 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 |
AValue forth-wordlist \ variable, will be redefined by search.fs |
|
|
AVariable lookup forth-wordlist lookup ! |
AVariable lookup forth-wordlist lookup ! |
Line 331 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 |
$1f constant lcount-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 |
$80000000 constant alias-mask |
1 bits/char 1 - lshift |
1 bits/char 1 - lshift |
-1 cells allot bigendian [IF] c, 0 1 cells 1- times |
-1 cells allot bigendian [IF] c, 0 1 cells 1- times |
Line 348 $20000000 constant restrict-mask
|
Line 327 $20000000 constant restrict-mask
|
1 bits/char 3 - lshift |
1 bits/char 3 - lshift |
-1 cells allot bigendian [IF] c, 0 1 cells 1- times |
-1 cells allot bigendian [IF] c, 0 1 cells 1- times |
[ELSE] 0 1 cells 1- times c, [THEN] |
[ELSE] 0 1 cells 1- times c, [THEN] |
$1fffffff constant lcount-mask |
$10000000 constant prelude-mask |
1 bits/char 3 - lshift 1 - |
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 |
-1 cells allot bigendian [IF] c, -1 1 cells 1- times |
[ELSE] -1 1 cells 1- times c, [THEN] |
[ELSE] -1 1 cells 1- times c, [THEN] |
[THEN] |
[THEN] |
Line 447 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 ) |
|
dup cell+ @ prelude-mask and if |
|
[ -1 cells ] literal + @ |
|
else |
|
drop ['] noop |
|
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 454 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 464 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 550 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 633 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 650 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 691 has? backtrace [IF]
|
Line 716 has? backtrace [IF]
|
|
|
\ interpreter 30apr92py |
\ 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 |
\ not the most efficient implementations of interpreter and compiler |
: interpreter1 ( c-addr u -- ... xt ) |
: interpreter1 ( c-addr u -- ... xt ) |
2dup find-name dup |
2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup |
if |
if |
nip nip name>int |
nip nip name>int |
else |
else |
Line 707 has? backtrace [IF]
|
Line 742 has? backtrace [IF]
|
then ; |
then ; |
|
|
' interpreter1 IS parser1 |
' interpreter1 IS parser1 |
|
[THEN] |
|
|
\ \ Query Evaluate 07apr93py |
\ \ Query Evaluate 07apr93py |
|
|
Line 851 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 891 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 932 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 1034 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-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'" |
." 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 1053 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 1078 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 1098 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 1131 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] ] |
; |
; |
|
|