version 1.135, 2003/08/16 19:46:11
|
version 1.140, 2003/08/20 13:29:19
|
Line 141 undefine(`index')
|
Line 141 undefine(`index')
|
undefine(`shift') |
undefine(`shift') |
undefine(`symbols') |
undefine(`symbols') |
|
|
|
\F 0 [if] |
|
|
|
\ run-time routines for non-primitives. They are defined as |
|
\ primitives, because that simplifies things. |
|
|
|
(docol) ( -- R:a_retaddr ) gforth-internal paren_docol |
|
""run-time routine for colon definitions"" |
|
a_retaddr = (Cell *)ip; |
|
SET_IP((Xt *)PFA(CFA)); |
|
|
|
(docon) ( -- w ) gforth-internal paren_docon |
|
""run-time routine for constants"" |
|
w = *(Cell *)PFA(CFA); |
|
|
|
(dovar) ( -- a_body ) gforth-internal paren_dovar |
|
""run-time routine for variables and CREATEd words"" |
|
a_body = PFA(CFA); |
|
|
|
(douser) ( -- a_user ) gforth-internal paren_douser |
|
""run-time routine for constants"" |
|
a_user = (Cell *)(up+*(Cell *)PFA(CFA)); |
|
|
|
(dodefer) ( -- ) gforth-internal paren_dodefer |
|
""run-time routine for deferred words"" |
|
SUPER_END; |
|
EXEC(*(Xt *)PFA(CFA)); |
|
|
|
(dofield) ( n1 -- n2 ) gforth-internal paren_field |
|
""run-time routine for fields"" |
|
n2 = n1 + *(Cell *)PFA(CFA); |
|
|
|
(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes |
|
""run-time routine for @code{does>}-defined words"" |
|
a_retaddr = (Cell *)ip; |
|
a_body = PFA(CFA); |
|
SET_IP(DOES_CODE1(CFA)); |
|
|
|
(does-handler) ( -- ) gforth-internal paren_does_handler |
|
""just a slot to have an encoding for the DOESJUMP, |
|
which is no longer used anyway (!! eliminate this)"" |
|
|
|
\F [endif] |
|
|
\g control |
\g control |
|
|
noop ( -- ) gforth |
noop ( -- ) gforth |
Line 793 ud = ummul(u1,u2);
|
Line 836 ud = ummul(u1,u2);
|
ud = (UDCell)u1 * (UDCell)u2; |
ud = (UDCell)u1 * (UDCell)u2; |
#endif |
#endif |
: |
: |
>r >r 0 0 r> r> [ 8 cells ] literal 0 |
0 -rot dup [ 8 cells ] literal - |
DO |
DO |
over >r dup >r 0< and d2*+ drop |
dup 0< I' and d2*+ drop |
r> 2* r> swap |
LOOP ; |
LOOP 2drop ; |
|
: d2*+ ( ud n -- ud+n c ) |
: d2*+ ( ud n -- ud+n c ) |
over MINI |
over MINI |
and >r >r 2dup d+ swap r> + swap r> ; |
and >r >r 2dup d+ swap r> + swap r> ; |
Line 1084 rdrop ( R:w -- ) gforth
|
Line 1126 rdrop ( R:w -- ) gforth
|
: |
: |
r> r> drop >r ; |
r> r> drop >r ; |
|
|
2>r ( w1 w2 -- R:w1 R:w2 ) core-ext two_to_r |
2>r ( d -- R:d ) core-ext two_to_r |
: |
: |
swap r> swap >r swap >r >r ; |
swap r> swap >r swap >r >r ; |
|
|
2r> ( R:w1 R:w2 -- w1 w2 ) core-ext two_r_from |
2r> ( R:d -- d ) core-ext two_r_from |
: |
: |
r> r> swap r> swap >r swap ; |
r> r> swap r> swap >r swap ; |
|
|
2r@ ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 ) core-ext two_r_fetch |
2r@ ( R:d -- R:d d ) core-ext two_r_fetch |
: |
: |
i' j ; |
i' j ; |
|
|
2rdrop ( R:w1 R:w2 -- ) gforth two_r_drop |
2rdrop ( R:d -- ) gforth two_r_drop |
: |
: |
r> r> drop r> drop >r ; |
r> r> drop r> drop >r ; |
|
|
Line 1316 c_addr2 = c_addr1+1;
|
Line 1358 c_addr2 = c_addr1+1;
|
|
|
\g compiler |
\g compiler |
|
|
|
\+f83headerstring |
|
|
|
(f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find |
|
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) |
|
if ((UCell)F83NAME_COUNT(f83name1)==u && |
|
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
|
break; |
|
f83name2=f83name1; |
|
: |
|
BEGIN dup WHILE (find-samelen) dup WHILE |
|
>r 2dup r@ cell+ char+ capscomp 0= |
|
IF 2drop r> EXIT THEN |
|
r> @ |
|
REPEAT THEN nip nip ; |
|
: (find-samelen) ( u f83name1 -- u f83name2/0 ) |
|
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
|
: capscomp ( c_addr1 u c_addr2 -- n ) |
|
swap bounds |
|
?DO dup c@ I c@ <> |
|
IF dup c@ toupper I c@ toupper = |
|
ELSE true THEN WHILE 1+ LOOP drop 0 |
|
ELSE c@ toupper I c@ toupper - unloop THEN sgn ; |
|
: sgn ( n -- -1/0/1 ) |
|
dup 0= IF EXIT THEN 0< 2* 1+ ; |
|
|
|
\- |
|
|
(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind |
(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind |
longname2=listlfind(c_addr, u, longname1); |
longname2=listlfind(c_addr, u, longname1); |
: |
: |
Line 1349 longname2 = tablelfind(c_addr, u, a_addr
|
Line 1418 longname2 = tablelfind(c_addr, u, a_addr
|
IF 2drop r> rdrop EXIT THEN THEN |
IF 2drop r> rdrop EXIT THEN THEN |
rdrop r> |
rdrop r> |
REPEAT nip nip ; |
REPEAT nip nip ; |
|
: -text ( c_addr1 u c_addr2 -- n ) |
|
swap bounds |
|
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
|
ELSE c@ I c@ - unloop THEN sgn ; |
|
: sgn ( n -- -1/0/1 ) |
|
dup 0= IF EXIT THEN 0< 2* 1+ ; |
|
|
(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 |
(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 |
""ukey is the hash key for the string c_addr u fitting in ubits bits"" |
""ukey is the hash key for the string c_addr u fitting in ubits bits"" |
Line 1368 Create rot-values
|
Line 1443 Create rot-values
|
|
|
\+ |
\+ |
|
|
|
\+ |
|
|
(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white |
(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white |
struct Cellpair r=parse_white(c_addr1, u1); |
struct Cellpair r=parse_white(c_addr1, u1); |
c_addr2 = (Char *)(r.n1); |
c_addr2 = (Char *)(r.n1); |
Line 2191 u3 = 0;
|
Line 2268 u3 = 0;
|
|
|
\+FFCALL |
\+FFCALL |
|
|
av-start-void ( c_addr -- ) gforth av_start_void |
av-start-void ( c_addr -- ) gforth av_start_void |
av_start_void(alist, c_addr); |
av_start_void(alist, c_addr); |
|
|
av-start-int ( c_addr -- ) gforth av_start_int |
av-start-int ( c_addr -- ) gforth av_start_int |
av_start_int(alist, c_addr, &irv); |
av_start_int(alist, c_addr, &irv); |
|
|
av-start-float ( c_addr -- ) gforth av_start_float |
av-start-float ( c_addr -- ) gforth av_start_float |
av_start_float(alist, c_addr, &frv); |
av_start_float(alist, c_addr, &frv); |
|
|
av-start-double ( c_addr -- ) gforth av_start_double |
av-start-double ( c_addr -- ) gforth av_start_double |
av_start_double(alist, c_addr, &drv); |
av_start_double(alist, c_addr, &drv); |
|
|
av-start-longlong ( c_addr -- ) gforth av_start_longlong |
av-start-longlong ( c_addr -- ) gforth av_start_longlong |
av_start_longlong(alist, c_addr, &llrv); |
av_start_longlong(alist, c_addr, &llrv); |
|
|
av-start-ptr ( c_addr -- ) gforth av_start_ptr |
av-start-ptr ( c_addr -- ) gforth av_start_ptr |
av_start_ptr(alist, c_addr, void*, &prv); |
av_start_ptr(alist, c_addr, void*, &prv); |
|
|
av-int ( w -- ) gforth av_int |
av-int ( w -- ) gforth av_int |
av_int(alist, w); |
av_int(alist, w); |
|
|
av-float ( r -- ) gforth av_float |
av-float ( r -- ) gforth av_float |
|
av_float(alist, r); |
|
|
|
av-double ( r -- ) gforth av_double |
|
av_double(alist, r); |
|
|
|
av-longlong ( d -- ) gforth av_longlong |
|
av_longlong(alist, d); |
|
|
|
av-ptr ( c_addr -- ) gforth av_ptr |
|
av_ptr(alist, void*, c_addr); |
|
|
|
av-int-r ( R:w -- ) gforth av_int_r |
|
av_int(alist, w); |
|
|
|
av-float-r ( -- ) gforth av_float_r |
|
float r = *(Float*)lp; |
|
lp += sizeof(Float); |
av_float(alist, r); |
av_float(alist, r); |
|
|
av-double ( r -- ) gforth av_double |
av-double-r ( -- ) gforth av_double_r |
|
double r = *(Float*)lp; |
|
lp += sizeof(Float); |
av_double(alist, r); |
av_double(alist, r); |
|
|
av-longlong ( d -- ) gforth av_longlong |
av-longlong-r ( R:d -- ) gforth av_longlong_r |
av_longlong(alist, d); |
av_longlong(alist, d); |
|
|
av-ptr ( c_addr -- ) gforth av_ptr |
av-ptr-r ( R:c_addr -- ) gforth av_ptr_r |
av_ptr(alist, void*, c_addr); |
av_ptr(alist, void*, c_addr); |
|
|
av-call-void ( -- ) gforth av_call_void |
av-call-void ( -- ) gforth av_call_void |
SAVE_REGS |
SAVE_REGS |
av_call(alist); |
av_call(alist); |
REST_REGS |
REST_REGS |
|
|
av-call-int ( -- w ) gforth av_call_int |
av-call-int ( -- w ) gforth av_call_int |
SAVE_REGS |
SAVE_REGS |
av_call(alist); |
av_call(alist); |
REST_REGS |
REST_REGS |
w = irv; |
w = irv; |
|
|
av-call-float ( -- r ) gforth av_call_float |
av-call-float ( -- r ) gforth av_call_float |
SAVE_REGS |
SAVE_REGS |
av_call(alist); |
av_call(alist); |
REST_REGS |
REST_REGS |
r = frv; |
r = frv; |
|
|
av-call-double ( -- r ) gforth av_call_double |
av-call-double ( -- r ) gforth av_call_double |
SAVE_REGS |
SAVE_REGS |
av_call(alist); |
av_call(alist); |
REST_REGS |
REST_REGS |
r = drv; |
r = drv; |
|
|
av-call-longlong ( -- d ) gforth av_call_longlong |
av-call-longlong ( -- d ) gforth av_call_longlong |
SAVE_REGS |
SAVE_REGS |
av_call(alist); |
av_call(alist); |
REST_REGS |
REST_REGS |
d = llrv; |
d = llrv; |
|
|
av-call-ptr ( -- c_addr ) gforth av_call_ptr |
av-call-ptr ( -- c_addr ) gforth av_call_ptr |
SAVE_REGS |
SAVE_REGS |
av_call(alist); |
av_call(alist); |
REST_REGS |
REST_REGS |