version 1.181, 2011/11/11 18:29:10
|
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,2010 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 143 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 446 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 456 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 626 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 657 Defer interpreter-notfound1 ( c-addr cou
|
Line 680 Defer interpreter-notfound1 ( c-addr cou
|
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 858 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 940 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 1042 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-2011 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 1061 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 1086 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 1106 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 1139 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] ] |
; |
; |
|
|