version 1.5, 1996/10/01 16:25:59
|
version 1.10, 1997/01/04 16:32:30
|
Line 20
|
Line 20
|
|
|
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
|
|
\ Log: ', '- usw. durch [char] ... ersetzt |
|
\ man sollte die unterschiedlichen zahlensysteme |
|
\ mit $ und & zumindest im interpreter weglassen |
|
\ schon erledigt! |
|
\ 11may93jaw |
|
\ name> 0= nicht vorhanden 17may93jaw |
|
\ nfa can be lfa or nfa! |
|
\ find splited into find and (find) |
|
\ (find) for later use 17may93jaw |
|
\ search replaced by lookup because |
|
\ it is a word of the string wordset |
|
\ 20may93jaw |
|
\ postpone added immediate 21may93jaw |
|
\ to added immediate 07jun93jaw |
|
\ cfa, header put "here lastcfa !" in |
|
\ cfa, this is more logical |
|
\ and noname: works wothout |
|
\ extra "here lastcfa !" 08jun93jaw |
|
\ (parse-white) thrown out |
|
\ refill added outer trick |
|
\ to show there is something |
|
\ going on 09jun93jaw |
|
\ leave ?leave somebody forgot UNLOOP!!! 09jun93jaw |
|
\ leave ?leave unloop thrown out |
|
\ unloop after loop is used 10jun93jaw |
|
|
|
HEX |
HEX |
|
|
\ labels for some code addresses |
\ labels for some code addresses |
Line 1164 end-struct interpret/compile-struct
|
Line 1138 end-struct interpret/compile-struct
|
(cfa>int) ; |
(cfa>int) ; |
|
|
: name>comp ( nt -- w xt ) \ gforth |
: name>comp ( nt -- w xt ) \ gforth |
\G @var{w xt} is the compilation token wor the word @var{nt}. |
\G @var{w xt} is the compilation token for the word @var{nt}. |
(name>x) >r dup interpret/compile? |
(name>x) >r dup interpret/compile? |
if |
if |
interpret/compile-comp @ |
interpret/compile-comp @ |
Line 1359 Defer key ( -- c ) \ core
|
Line 1333 Defer key ( -- c ) \ core
|
1 loadline +! |
1 loadline +! |
swap #tib ! 0 >in ! ; |
swap #tib ! 0 >in ! ; |
|
|
: Query ( -- ) \ core-ext |
: query ( -- ) \ core-ext |
\G obsolescent |
\G obsolescent |
loadfile off blk off refill drop ; |
tib /line accept #tib ! 0 >in ! ; |
|
|
\ File specifiers 11jun93jaw |
\ File specifiers 11jun93jaw |
|
|
Line 1381 Defer key ( -- c ) \ core
|
Line 1355 Defer key ( -- c ) \ core
|
: bin ( fam1 -- fam2 ) \ file |
: bin ( fam1 -- fam2 ) \ file |
1 or ; |
1 or ; |
|
|
create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos |
|
\ or not unix environments if |
|
\ bin is not selected |
|
|
|
: write-line ( c-addr u fileid -- ior ) \ file |
: write-line ( c-addr u fileid -- ior ) \ file |
dup >r write-file |
dup >r write-file |
?dup IF |
?dup IF |
r> drop EXIT |
r> drop EXIT |
THEN |
THEN |
nl$ count r> write-file ; |
#lf r> emit-file ; |
|
|
\ include-file 07apr93py |
\ include-file 07apr93py |
|
|
Line 1615 create image-included-files 1 , A, ( po
|
Line 1585 create image-included-files 1 , A, ( po
|
Defer 'quit |
Defer 'quit |
Defer .status |
Defer .status |
: prompt state @ IF ." compiled" EXIT THEN ." ok" ; |
: prompt state @ IF ." compiled" EXIT THEN ." ok" ; |
: (quit) BEGIN .status cr query interpret prompt AGAIN ; |
: (Query) ( -- ) |
|
loadfile off blk off refill drop ; |
|
: (quit) BEGIN .status cr (query) interpret prompt AGAIN ; |
' (quit) IS 'quit |
' (quit) IS 'quit |
|
|
\ DOERROR (DOERROR) 13jun93jaw |
\ DOERROR (DOERROR) 13jun93jaw |
Line 1640 max-errors 6 * cells allot
|
Line 1612 max-errors 6 * cells allot
|
: typewhite ( addr u -- ) \ gforth |
: typewhite ( addr u -- ) \ gforth |
\ like type, but white space is printed instead of the characters |
\ like type, but white space is printed instead of the characters |
bounds ?do |
bounds ?do |
i c@ 9 = if \ check for tab |
i c@ #tab = if \ check for tab |
9 |
#tab |
else |
else |
bl |
bl |
then |
then |
Line 1729 Variable argc
|
Line 1701 Variable argc
|
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings |
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings |
align here >r |
align here >r |
BEGIN |
BEGIN |
over >r [char] : scan |
over >r 0 scan |
over r> tuck - ( rest-str this-str ) |
over r> tuck - ( rest-str this-str ) |
dup |
dup |
IF |
IF |
Line 1811 Defer 'cold ' noop IS 'cold
|
Line 1783 Defer 'cold ' noop IS 'cold
|
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
|
|
: boot ( path **argv argc -- ) |
: boot ( path **argv argc -- ) |
argc ! argv ! cstring>sstring save-mem pathstring 2! main-task up! |
argc ! argv ! pathstring 2! main-task up! |
sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off |
sp@ s0 ! |
rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; |
lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off |
|
rp@ r0 ! |
|
fp@ f0 ! |
|
['] cold catch DoError |
|
bye ; |
|
|
: bye ( -- ) \ tools-ext |
: bye ( -- ) \ tools-ext |
script? 0= IF cr THEN 0 (bye) ; |
script? 0= IF cr THEN 0 (bye) ; |