| \ Gforth primitives |
\ Gforth primitives |
| |
|
| \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| \E set-current |
\E set-current |
| \E store-optimization on |
\E store-optimization on |
| \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump |
\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump |
| |
\E |
| |
\E include-skipped-insts on \ static superinsts include cells for components |
| |
\E \ useful for dynamic programming and |
| |
\E \ superinsts across entry points |
| |
|
| \ |
\ |
| \ |
\ |
| @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
| from low address to high address; i.e., for overlapping areas it is |
from low address to high address; i.e., for overlapping areas it is |
| safe if @i{c-to}=<@i{c-from}."" |
safe if @i{c-to}=<@i{c-from}."" |
| while (u-- > 0) |
cmove(c_from,c_to,u); |
| *c_to++ = *c_from++; |
|
| : |
: |
| bounds ?DO dup c@ I c! 1+ LOOP drop ; |
bounds ?DO dup c@ I c! 1+ LOOP drop ; |
| |
|
| @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
| from high address to low address; i.e., for overlapping areas it is |
from high address to low address; i.e., for overlapping areas it is |
| safe if @i{c-to}>=@i{c-from}."" |
safe if @i{c-to}>=@i{c-from}."" |
| while (u-- > 0) |
cmove_up(c_from,c_to,u); |
| c_to[u] = c_from[u]; |
|
| : |
: |
| dup 0= IF drop 2drop exit THEN |
dup 0= IF drop 2drop exit THEN |
| rot over + -rot bounds swap 1- |
rot over + -rot bounds swap 1- |
| comparison. In the future, this may change to consider the current |
comparison. In the future, this may change to consider the current |
| locale and its collation order."" |
locale and its collation order."" |
| /* close ' to keep fontify happy */ |
/* close ' to keep fontify happy */ |
| n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
n = compare(c_addr1, u1, c_addr2, u2); |
| if (n==0) |
|
| n = u1-u2; |
|
| if (n<0) |
|
| n = -1; |
|
| else if (n>0) |
|
| n = 1; |
|
| : |
: |
| rot 2dup swap - >r min swap -text dup |
rot 2dup swap - >r min swap -text dup |
| IF rdrop ELSE drop r> sgn THEN ; |
IF rdrop ELSE drop r> sgn THEN ; |
| : sgn ( n -- -1/0/1 ) |
: sgn ( n -- -1/0/1 ) |
| dup 0= IF EXIT THEN 0< 2* 1+ ; |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| -text ( c_addr1 u c_addr2 -- n ) new dash_text |
\ -text is only used by replaced primitives now; move it elsewhere |
| n = memcmp(c_addr1, c_addr2, u); |
\ -text ( c_addr1 u c_addr2 -- n ) new dash_text |
| if (n<0) |
\ n = memcmp(c_addr1, c_addr2, u); |
| n = -1; |
\ if (n<0) |
| else if (n>0) |
\ n = -1; |
| n = 1; |
\ else if (n>0) |
| : |
\ n = 1; |
| swap bounds |
\ : |
| ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
\ swap bounds |
| ELSE c@ I c@ - unloop THEN sgn ; |
\ ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
| : sgn ( n -- -1/0/1 ) |
\ ELSE c@ I c@ - unloop THEN sgn ; |
| dup 0= IF EXIT THEN 0< 2* 1+ ; |
\ : sgn ( n -- -1/0/1 ) |
| |
\ dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| toupper ( c1 -- c2 ) gforth |
toupper ( c1 -- c2 ) gforth |
| ""If @i{c1} is a lower-case character (in the current locale), @i{c2} |
""If @i{c1} is a lower-case character (in the current locale), @i{c2} |
| : |
: |
| dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
| |
|
| capscomp ( c_addr1 u c_addr2 -- n ) new |
|
| n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */ |
|
| if (n<0) |
|
| n = -1; |
|
| else if (n>0) |
|
| n = 1; |
|
| : |
|
| 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 ; |
|
| |
|
| -trailing ( c_addr u1 -- c_addr u2 ) string dash_trailing |
|
| ""Adjust the string specified by @i{c-addr, u1} to remove all trailing |
|
| spaces. @i{u2} is the length of the modified string."" |
|
| u2 = u1; |
|
| while (u2>0 && c_addr[u2-1] == ' ') |
|
| u2--; |
|
| : |
|
| BEGIN 1- 2dup + c@ bl = WHILE |
|
| dup 0= UNTIL ELSE 1+ THEN ; |
|
| |
|
| /string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string |
/string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string |
| ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} |
""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} |
| characters from the start of the string."" |
characters from the start of the string."" |
| \g compiler |
\g compiler |
| |
|
| (listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind |
(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind |
| for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next)) |
longname2=listlfind(c_addr, u, longname1); |
| if ((UCell)LONGNAME_COUNT(longname1)==u && |
|
| memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) |
|
| break; |
|
| longname2=longname1; |
|
| : |
: |
| BEGIN dup WHILE (findl-samelen) dup WHILE |
BEGIN dup WHILE (findl-samelen) dup WHILE |
| >r 2dup r@ cell+ cell+ capscomp 0= |
>r 2dup r@ cell+ cell+ capscomp 0= |
| \+hash |
\+hash |
| |
|
| (hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind |
(hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind |
| struct Longname *longname1; |
longname2 = hashlfind(c_addr, u, a_addr); |
| longname2=NULL; |
|
| while(a_addr != NULL) |
|
| { |
|
| longname1=(struct Longname *)(a_addr[1]); |
|
| a_addr=(Cell *)(a_addr[0]); |
|
| if ((UCell)LONGNAME_COUNT(longname1)==u && |
|
| memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) |
|
| { |
|
| longname2=longname1; |
|
| break; |
|
| } |
|
| } |
|
| : |
: |
| BEGIN dup WHILE |
BEGIN dup WHILE |
| 2@ >r >r dup r@ cell+ @ lcount-mask and = |
2@ >r >r dup r@ cell+ @ lcount-mask and = |
| |
|
| (tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind |
(tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind |
| ""A case-sensitive variant of @code{(hashfind)}"" |
""A case-sensitive variant of @code{(hashfind)}"" |
| struct Longname *longname1; |
longname2 = tablelfind(c_addr, u, a_addr); |
| longname2=NULL; |
|
| while(a_addr != NULL) |
|
| { |
|
| longname1=(struct Longname *)(a_addr[1]); |
|
| a_addr=(Cell *)(a_addr[0]); |
|
| if ((UCell)LONGNAME_COUNT(longname1)==u && |
|
| memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) |
|
| { |
|
| longname2=longname1; |
|
| break; |
|
| } |
|
| } |
|
| : |
: |
| BEGIN dup WHILE |
BEGIN dup WHILE |
| 2@ >r >r dup r@ cell+ @ lcount-mask and = |
2@ >r >r dup r@ cell+ @ lcount-mask and = |
| rdrop r> |
rdrop r> |
| REPEAT nip nip ; |
REPEAT nip nip ; |
| |
|
| (hashkey) ( c_addr u1 -- u2 ) gforth paren_hashkey |
|
| u2=0; |
|
| while(u1--) |
|
| u2+=(Cell)toupper(*c_addr++); |
|
| : |
|
| 0 -rot bounds ?DO I c@ toupper + LOOP ; |
|
| |
|
| (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"" |
| /* this hash function rotates the key at every step by rot bits within |
ukey = hashkey1(c_addr, u, ubits); |
| ubits bits and xors it with the character. This function does ok in |
|
| the chi-sqare-test. Rot should be <=7 (preferably <=5) for |
|
| ASCII strings (larger if ubits is large), and should share no |
|
| divisors with ubits. |
|
| */ |
|
| static char rot_values[] = {5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5}; |
|
| unsigned rot = rot_values[ubits]; |
|
| Char *cp = c_addr; |
|
| for (ukey=0; cp<c_addr+u; cp++) |
|
| ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) |
|
| ^ toupper(*cp)) |
|
| & ((1<<ubits)-1)); |
|
| : |
: |
| dup rot-values + c@ over 1 swap lshift 1- >r |
dup rot-values + c@ over 1 swap lshift 1- >r |
| tuck - 2swap r> 0 2swap bounds |
tuck - 2swap r> 0 2swap bounds |
| \+ |
\+ |
| |
|
| (parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white |
(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white |
| /* use !isgraph instead of isspace? */ |
struct Cellpair r=parse_white(c_addr1, u1); |
| Char *endp = c_addr1+u1; |
c_addr2 = (Char *)(r.n1); |
| while (c_addr1<endp && isspace(*c_addr1)) |
u2 = r.n2; |
| c_addr1++; |
|
| if (c_addr1<endp) { |
|
| for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++) |
|
| ; |
|
| u2 = c_addr1-c_addr2; |
|
| } |
|
| else { |
|
| c_addr2 = c_addr1; |
|
| u2 = 0; |
|
| } |
|
| : |
: |
| BEGIN dup WHILE over c@ bl <= WHILE 1 /string |
BEGIN dup WHILE over c@ bl <= WHILE 1 /string |
| REPEAT THEN 2dup |
REPEAT THEN 2dup |
| |
|
| \ threading stuff is currently only interesting if we have a compiler |
\ threading stuff is currently only interesting if we have a compiler |
| \fhas? standardthreading has? compiler and [IF] |
\fhas? standardthreading has? compiler and [IF] |
| code-address! ( c_addr xt -- ) gforth code_address_store |
|
| ""Create a code field with code address @i{c-addr} at @i{xt}."" |
|
| MAKE_CF(xt, c_addr); |
|
| : |
|
| ! ; |
|
| |
|
| does-code! ( a_addr xt -- ) gforth does_code_store |
|
| ""Create a code field at @i{xt} for a child of a @code{DOES>}-word; |
|
| @i{a-addr} is the start of the Forth code after @code{DOES>}."" |
|
| MAKE_DOES_CF(xt, a_addr); |
|
| : |
|
| dodoes: over ! cell+ ! ; |
|
| |
|
| does-handler! ( a_addr -- ) gforth does_handler_store |
|
| ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally, |
|
| @i{a-addr} points just behind a @code{DOES>}."" |
|
| MAKE_DOES_HANDLER(a_addr); |
|
| : |
|
| drop ; |
|
| |
|
| /does-handler ( -- n ) gforth slash_does_handler |
|
| ""The size of a @code{DOES>}-handler (includes possible padding)."" |
|
| /* !! a constant or environmental query might be better */ |
|
| n = DOES_HANDLER_SIZE; |
|
| : |
|
| 2 cells ; |
|
| |
|
| threading-method ( -- n ) gforth threading_method |
threading-method ( -- n ) gforth threading_method |
| ""0 if the engine is direct threaded. Note that this may change during |
""0 if the engine is direct threaded. Note that this may change during |
| the lifetime of an image."" |
the lifetime of an image."" |
| SUPER_END; |
SUPER_END; |
| return (Label *)n; |
return (Label *)n; |
| |
|
| (system) ( c_addr u -- wretval wior ) gforth peren_system |
(system) ( c_addr u -- wretval wior ) gforth paren_system |
| #ifndef MSDOS |
#ifndef MSDOS |
| int old_tp=terminal_prepped; |
int old_tp=terminal_prepped; |
| deprep_terminal(); |
deprep_terminal(); |
| time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date |
time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date |
| ""Report the current time of day. Seconds, minutes and hours are numbered from 0. |
""Report the current time of day. Seconds, minutes and hours are numbered from 0. |
| Months are numbered from 1."" |
Months are numbered from 1."" |
| |
#if 1 |
| |
time_t now; |
| |
struct tm *ltime; |
| |
time(&now); |
| |
ltime=localtime(&now); |
| |
#else |
| struct timeval time1; |
struct timeval time1; |
| struct timezone zone1; |
struct timezone zone1; |
| struct tm *ltime; |
struct tm *ltime; |
| /* !! Single Unix specification: |
/* !! Single Unix specification: |
| If tzp is not a null pointer, the behaviour is unspecified. */ |
If tzp is not a null pointer, the behaviour is unspecified. */ |
| ltime=localtime((time_t *)&time1.tv_sec); |
ltime=localtime((time_t *)&time1.tv_sec); |
| |
#endif |
| nyear =ltime->tm_year+1900; |
nyear =ltime->tm_year+1900; |
| nmonth=ltime->tm_mon+1; |
nmonth=ltime->tm_mon+1; |
| nday =ltime->tm_mday; |
nday =ltime->tm_mday; |
| |
|
| rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file |
rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file |
| ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" |
""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" |
| char *s1=tilde_cstr(c_addr2, u2, 1); |
wior = rename_file(c_addr1, u1, c_addr2, u2); |
| wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); |
|
| |
|
| file-position ( wfileid -- ud wior ) file file_position |
file-position ( wfileid -- ud wior ) file file_position |
| /* !! use tell and lseek? */ |
/* !! use tell and lseek? */ |
| clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
| |
|
| (read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line |
(read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line |
| Cell c; |
struct Cellquad r = read_line(c_addr, u1, wfileid); |
| flag=-1; |
u2 = r.n1; |
| u3=0; |
flag = r.n2; |
| for(u2=0; u2<u1; u2++) |
u3 = r.n3; |
| { |
wior = r.n4; |
| c = getc((FILE *)wfileid); |
|
| u3++; |
|
| if (c=='\n') break; |
|
| if (c=='\r') { |
|
| if ((c = getc((FILE *)wfileid))!='\n') |
|
| ungetc(c,(FILE *)wfileid); |
|
| else |
|
| u3++; |
|
| break; |
|
| } |
|
| if (c==EOF) { |
|
| flag=FLAG(u2!=0); |
|
| break; |
|
| } |
|
| c_addr[u2] = (Char)c; |
|
| } |
|
| wior=FILEIO(ferror((FILE *)wfileid)); |
|
| |
|
| \+ |
\+ |
| |
|
| wior = IOR(fflush((FILE *) wfileid)==EOF); |
wior = IOR(fflush((FILE *) wfileid)==EOF); |
| |
|
| file-status ( c_addr u -- wfam wior ) file-ext file_status |
file-status ( c_addr u -- wfam wior ) file-ext file_status |
| char *filename=tilde_cstr(c_addr, u, 1); |
struct Cellpair r = file_status(c_addr, u); |
| if (access (filename, F_OK) != 0) { |
wfam = r.n1; |
| wfam=0; |
wior = r.n2; |
| wior=IOR(1); |
|
| } |
|
| else if (access (filename, R_OK | W_OK) == 0) { |
|
| wfam=2; /* r/w */ |
|
| wior=0; |
|
| } |
|
| else if (access (filename, R_OK) == 0) { |
|
| wfam=0; /* r/o */ |
|
| wior=0; |
|
| } |
|
| else if (access (filename, W_OK) == 0) { |
|
| wfam=4; /* w/o */ |
|
| wior=0; |
|
| } |
|
| else { |
|
| wfam=1; /* well, we cannot access the file, but better deliver a legal |
|
| access mode (r/o bin), so we get a decent error later upon open. */ |
|
| wior=0; |
|
| } |
|
| |
|
| file-eof? ( wfileid -- flag ) gforth file_eof_query |
file-eof? ( wfileid -- flag ) gforth file_eof_query |
| flag = FLAG(feof((FILE *) wfileid)); |
flag = FLAG(feof((FILE *) wfileid)); |
| |
|
| represent ( r c_addr u -- n f1 f2 ) float |
represent ( r c_addr u -- n f1 f2 ) float |
| char *sig; |
char *sig; |
| |
size_t siglen; |
| int flag; |
int flag; |
| int decpt; |
int decpt; |
| sig=ecvt(r, u, &decpt, &flag); |
sig=ecvt(r, u, &decpt, &flag); |
| n=(r==0 ? 1 : decpt); |
n=(r==0. ? 1 : decpt); |
| f1=FLAG(flag!=0); |
f1=FLAG(flag!=0); |
| f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
| memmove(c_addr,sig,u); |
siglen=strlen(sig); |
| |
if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */ |
| |
siglen=u; |
| |
memcpy(c_addr,sig,siglen); |
| |
memset(c_addr+siglen,f2?'0':' ',u-siglen); |
| |
|
| >float ( c_addr u -- flag ) float to_float |
>float ( c_addr u -- flag ) float to_float |
| ""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the |
""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the |
| @i{r} is placed on the floating-point stack and @i{flag} is |
@i{r} is placed on the floating-point stack and @i{flag} is |
| true. Otherwise, @i{flag} is false. A string of blanks is a special |
true. Otherwise, @i{flag} is false. A string of blanks is a special |
| case and represents the floating-point number 0."" |
case and represents the floating-point number 0."" |
| /* real signature: c_addr u -- r t / f */ |
|
| Float r; |
Float r; |
| char *number=cstr(c_addr, u, 1); |
flag = to_float(c_addr, u, &r); |
| char *endconv; |
if (flag) { |
| int sign = 0; |
|
| if(number[0]=='-') { |
|
| sign = 1; |
|
| number++; |
|
| u--; |
|
| } |
|
| while(isspace((unsigned)(number[--u])) && u>0); |
|
| switch(number[u]) |
|
| { |
|
| case 'd': |
|
| case 'D': |
|
| case 'e': |
|
| case 'E': break; |
|
| default : u++; break; |
|
| } |
|
| number[u]='\0'; |
|
| r=strtod(number,&endconv); |
|
| if((flag=FLAG(!(Cell)*endconv))) |
|
| { |
|
| IF_fpTOS(fp[0] = fpTOS); |
IF_fpTOS(fp[0] = fpTOS); |
| fp += -1; |
fp += -1; |
| fpTOS = sign ? -r : r; |
fpTOS = r; |
| } |
|
| else if(*endconv=='d' || *endconv=='D') |
|
| { |
|
| *endconv='E'; |
|
| r=strtod(number,&endconv); |
|
| if((flag=FLAG(!(Cell)*endconv))) |
|
| { |
|
| IF_fpTOS(fp[0] = fpTOS); |
|
| fp += -1; |
|
| fpTOS = sign ? -r : r; |
|
| } |
|
| } |
} |
| |
|
| fabs ( r1 -- r2 ) float-ext f_abs |
fabs ( r1 -- r2 ) float-ext f_abs |
| ""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the |
""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the |
| next at f_addr1+nstride1 and so on (similar for v2). Both vectors have |
next at f_addr1+nstride1 and so on (similar for v2). Both vectors have |
| ucount elements."" |
ucount elements."" |
| for (r=0.; ucount>0; ucount--) { |
r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount); |
| r += *f_addr1 * *f_addr2; |
|
| f_addr1 = (Float *)(((Address)f_addr1)+nstride1); |
|
| f_addr2 = (Float *)(((Address)f_addr2)+nstride2); |
|
| } |
|
| : |
: |
| >r swap 2swap swap 0e r> 0 ?DO |
>r swap 2swap swap 0e r> 0 ?DO |
| dup f@ over + 2swap dup f@ f* f+ over + 2swap |
dup f@ over + 2swap dup f@ f* f+ over + 2swap |
| |
|
| faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth |
faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth |
| ""vy=ra*vx+vy"" |
""vy=ra*vx+vy"" |
| for (; ucount>0; ucount--) { |
faxpy(ra, f_x, nstridex, f_y, nstridey, ucount); |
| *f_y += ra * *f_x; |
|
| f_x = (Float *)(((Address)f_x)+nstridex); |
|
| f_y = (Float *)(((Address)f_y)+nstridey); |
|
| } |
|
| : |
: |
| >r swap 2swap swap r> 0 ?DO |
>r swap 2swap swap r> 0 ?DO |
| fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap |
fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap |
| |
|
| \g peephole |
\g peephole |
| |
|
| primtable ( -- wprimtable ) new |
compile-prim1 ( a_prim -- ) gforth compile_prim1 |
| ""wprimtable is a table containing the xts of the primitives indexed |
""compile prim (incl. immargs) at @var{a_prim}"" |
| by sequence-number in prim (for use in prepare-peephole-table)."" |
compile_prim1(a_prim); |
| wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1); |
|
| |
finish-code ( -- ) gforth finish_code |
| prepare-peephole-table ( wprimtable -- wpeeptable ) new prepare_peephole_opt |
""Perform delayed steps in code generation (branch resolution, I-cache |
| ""wpeeptable is a data structure used by @code{peephole-opt}; it is |
flushing)."" |
| constructed by combining a primitives table with a simple peephole |
finish_code(); |
| optimization table."" |
|
| wpeeptable = prepare_peephole_table((Xt *)wprimtable); |
forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode |
| |
f = forget_dyncode(c_code); |
| peephole-opt ( xt1 xt2 wpeeptable -- xt ) new peephole_opt |
|
| ""xt is the combination of xt1 and xt2 (according to wpeeptable); if |
|
| they cannot be combined, xt is 0."" |
|
| xt = peephole_opt(xt1, xt2, wpeeptable); |
|
| |
|
| compile-prim ( xt1 -- xt2 ) obsolete compile_prim |
decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim |
| xt2 = (Xt)compile_prim((Label)xt1); |
""a_prim is the code address of the primitive that has been |
| |
compile_prim1ed to a_code"" |
| |
a_prim = (Cell *)decompile_code((Label)a_code); |
| |
|
| \ set-next-code and call2 do not appear in images and can be |
\ set-next-code and call2 do not appear in images and can be |
| \ renumbered arbitrarily |
\ renumbered arbitrarily |
| assert(0); |
assert(0); |
| #endif |
#endif |
| |
|
| compile-prim1 ( a_prim -- ) gforth compile_prim1 |
\+ |
| ""compile prim (incl. immargs) at @var{a_prim}"" |
|
| compile_prim1(a_prim); |
|
| |
|
| finish-code ( -- ) gforth finish_code |
|
| ""Perform delayed steps in code generation (branch resolution, I-cache |
|
| flushing)."" |
|
| finish_code(); |
|
| |
|
| forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode |
|
| f = forget_dyncode(c_code); |
|
| |
|
| decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim |
\g static_super |
| ""a_prim is the code address of the primitive that has been |
|
| compile_prim1ed to a_code"" |
|
| a_prim = (Label)decompile_code((Label)a_code); |
|
| |
|
| \+ |
\C #if !defined(GFORTH_DEBUGGING) && !defined(INDIRECT_THREADED) && !defined(DOUBLY_INDIRECT) && !defined(VM_PROFILING) |
| |
|
| include(peeprules.vmg) |
include(peeprules.vmg) |
| |
|
| |
\C #endif |
| |
|
| \g end |
\g end |
