--- gforth/prim 2003/01/23 21:45:59 1.122 +++ gforth/prim 2003/11/06 09:47:49 1.148 @@ -1,6 +1,6 @@ \ 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. @@ -106,6 +106,10 @@ \E set-current \E store-optimization on \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 \ \ @@ -132,11 +136,90 @@ \ throw execute, cfa and NEXT1 out? \ macroize *ip, ip++, *ip++ (pipelining)? +\ Stack caching setup + +ifdef(`M4_ENGINE_FAST', `include(cache1.vmg)', `include(cache0.vmg)') + \ these m4 macros would collide with identifiers undefine(`index') undefine(`shift') 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"" +#ifdef NO_IP +a_retaddr = next_code; +INST_TAIL; +goto **(Label *)PFA(CFA); +#else /* !defined(NO_IP) */ +a_retaddr = (Cell *)IP; +SET_IP((Xt *)PFA(CFA)); +#endif /* !defined(NO_IP) */ + +(docon) ( -- w ) gforth-internal paren_docon +""run-time routine for constants"" +w = *(Cell *)PFA(CFA); +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + +(dovar) ( -- a_body ) gforth-internal paren_dovar +""run-time routine for variables and CREATEd words"" +a_body = PFA(CFA); +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + +(douser) ( -- a_user ) gforth-internal paren_douser +""run-time routine for constants"" +a_user = (Cell *)(up+*(Cell *)PFA(CFA)); +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + +(dodefer) ( -- ) gforth-internal paren_dodefer +""run-time routine for deferred words"" +#ifndef NO_IP +ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */ +#endif /* !defined(NO_IP) */ +SUPER_END; /* !! probably unnecessary and may lead to measurement errors */ +EXEC(*(Xt *)PFA(CFA)); + +(dofield) ( n1 -- n2 ) gforth-internal paren_field +""run-time routine for fields"" +n2 = n1 + *(Cell *)PFA(CFA); +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + +(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes +""run-time routine for @code{does>}-defined words"" +#ifdef NO_IP +a_retaddr = next_code; +a_body = PFA(CFA); +INST_TAIL; +goto **(Label *)DOES_CODE1(CFA); +#else /* !defined(NO_IP) */ +a_retaddr = (Cell *)IP; +a_body = PFA(CFA); +SET_IP(DOES_CODE1(CFA)); +#endif /* !defined(NO_IP) */ + +(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 noop ( -- ) gforth @@ -146,6 +229,7 @@ noop ( -- ) gforth call ( #a_callee -- R:a_retaddr ) new ""Call callee (a variant of docol with inline argument)."" #ifdef NO_IP +assert(0); INST_TAIL; JUMP(a_callee); #else @@ -557,8 +641,7 @@ cmove ( c_from c_to u -- ) string c_move @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 safe if @i{c-to}=<@i{c-from}."" -while (u-- > 0) - *c_to++ = *c_from++; +cmove(c_from,c_to,u); : bounds ?DO dup c@ I c! 1+ LOOP drop ; @@ -567,8 +650,7 @@ cmove> ( c_from c_to u -- ) string c_mov @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 safe if @i{c-to}>=@i{c-from}."" -while (u-- > 0) - c_to[u] = c_from[u]; +cmove_up(c_from,c_to,u); : dup 0= IF drop 2drop exit THEN rot over + -rot bounds swap 1- @@ -588,32 +670,31 @@ is 1. Currently this is based on the mac comparison. In the future, this may change to consider the current locale and its collation order."" /* close ' to keep fontify happy */ -n = memcmp(c_addr1, c_addr2, u10) - n = 1; +n = compare(c_addr1, u1, c_addr2, u2); : rot 2dup swap - >r min swap -text dup IF rdrop ELSE drop r> sgn THEN ; -: sgn ( n -- -1/0/1 ) - dup 0= IF EXIT THEN 0< 2* 1+ ; - --text ( c_addr1 u c_addr2 -- n ) new dash_text -n = memcmp(c_addr1, c_addr2, u); -if (n<0) - n = -1; -else if (n>0) - n = 1; -: +: -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+ ; +\ -text is only used by replaced primitives now; move it elsewhere +\ -text ( c_addr1 u c_addr2 -- n ) new dash_text +\ n = memcmp(c_addr1, c_addr2, u); +\ if (n<0) +\ n = -1; +\ else if (n>0) +\ n = 1; +\ : +\ 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+ ; + toupper ( c1 -- c2 ) gforth ""If @i{c1} is a lower-case character (in the current locale), @i{c2} is the equivalent upper-case character. All other characters are unchanged."" @@ -621,29 +702,6 @@ c2 = toupper(c1); : 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 ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} characters from the start of the string."" @@ -819,11 +877,10 @@ ud = ummul(u1,u2); ud = (UDCell)u1 * (UDCell)u2; #endif : - >r >r 0 0 r> r> [ 8 cells ] literal 0 + 0 -rot dup [ 8 cells ] literal - DO - over >r dup >r 0< and d2*+ drop - r> 2* r> swap - LOOP 2drop ; + dup 0< I' and d2*+ drop + LOOP ; : d2*+ ( ud n -- ud+n c ) over MINI and >r >r 2dup d+ swap r> + swap r> ; @@ -1110,19 +1167,19 @@ rdrop ( R:w -- ) gforth : 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 ; -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 ; -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 ; -2rdrop ( R:w1 R:w2 -- ) gforth two_r_drop +2rdrop ( R:d -- ) gforth two_r_drop : r> r> drop r> drop >r ; @@ -1342,12 +1399,35 @@ c_addr2 = c_addr1+1; \g compiler -(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind -for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next)) - if ((UCell)LONGNAME_COUNT(longname1)==u && - memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) +\+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; -longname2=longname1; +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 +longname2=listlfind(c_addr, u, longname1); : BEGIN dup WHILE (findl-samelen) dup WHILE >r 2dup r@ cell+ cell+ capscomp 0= @@ -1356,23 +1436,19 @@ longname2=longname1; REPEAT THEN nip nip ; : (findl-samelen) ( u longname1 -- u longname2/0 ) BEGIN 2dup cell+ @ lcount-mask 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+ ; \+hash (hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind -struct Longname *longname1; -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; - } -} +longname2 = hashlfind(c_addr, u, a_addr); : BEGIN dup WHILE 2@ >r >r dup r@ cell+ @ lcount-mask and = @@ -1383,19 +1459,7 @@ while(a_addr != NULL) (tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind ""A case-sensitive variant of @code{(hashfind)}"" -struct Longname *longname1; -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; - } -} +longname2 = tablelfind(c_addr, u, a_addr); : BEGIN dup WHILE 2@ >r >r dup r@ cell+ @ lcount-mask and = @@ -1403,22 +1467,16 @@ while(a_addr != NULL) IF 2drop r> rdrop EXIT THEN THEN rdrop r> 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 ""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 - 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>(ubits-rot))) - ^ toupper(*cp)) - & ((1<r tuck - 2swap r> 0 2swap bounds @@ -1434,20 +1492,12 @@ Create rot-values \+ +\+ + (parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white -/* use !isgraph instead of isspace? */ -Char *endp = c_addr1+u1; -while (c_addr1tm_year+1900; nmonth=ltime->tm_mon+1; nday =ltime->tm_mday; @@ -1630,7 +1687,7 @@ c_addr = strerror(n); u = strlen(c_addr); strsignal ( n -- c_addr u ) gforth -c_addr = strsignal(n); +c_addr = (Address)strsignal(n); u = strlen(c_addr); call-c ( w -- ) gforth call_c @@ -1674,8 +1731,7 @@ wior = IOR(unlink(tilde_cstr(c_addr, u, 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}"" -char *s1=tilde_cstr(c_addr2, u2, 1); -wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); +wior = rename_file(c_addr1, u1, c_addr2, u2); file-position ( wfileid -- ud wior ) file file_position /* !! use tell and lseek? */ @@ -1701,29 +1757,12 @@ wior = FILEIO(u2u) /* happens in glibc-2.1.3 if 999.. is rounded up */ + siglen=u; memcpy(c_addr,sig,siglen); -memset(c_addr+siglen,'0',u-siglen); +memset(c_addr+siglen,f2?'0':' ',u-siglen); >float ( c_addr u -- flag ) float to_float ""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the @@ -2022,43 +2044,12 @@ representation. If the string represents @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 case and represents the floating-point number 0."" -/* real signature: c_addr u -- r t / f */ Float r; -char *number=cstr(c_addr, u, 1); -char *endconv; -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); - fp += -1; - fpTOS = sign ? -r : 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; - } +flag = to_float(c_addr, u, &r); +if (flag) { + IF_fpTOS(fp[0] = fpTOS); + fp += -1; + fpTOS = r; } fabs ( r1 -- r2 ) float-ext f_abs @@ -2197,11 +2188,7 @@ v* ( f_addr1 nstride1 f_addr2 nstride2 u ""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 ucount elements."" -for (r=0.; ucount>0; ucount--) { - r += *f_addr1 * *f_addr2; - f_addr1 = (Float *)(((Address)f_addr1)+nstride1); - f_addr2 = (Float *)(((Address)f_addr2)+nstride2); -} +r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount); : >r swap 2swap swap 0e r> 0 ?DO dup f@ over + 2swap dup f@ f* f+ over + 2swap @@ -2209,11 +2196,7 @@ for (r=0.; ucount>0; ucount--) { faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth ""vy=ra*vx+vy"" -for (; ucount>0; ucount--) { - *f_y += ra * *f_x; - f_x = (Float *)(((Address)f_x)+nstridex); - f_y = (Float *)(((Address)f_y)+nstridey); -} +faxpy(ra, f_x, nstridex, f_y, nstridey, ucount); : >r swap 2swap swap r> 0 ?DO fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap @@ -2305,6 +2288,194 @@ r = fp[u+1]; /* +1, because update of fp \g syslib +open-lib ( c_addr1 u1 -- u2 ) gforth open_lib +#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) +#ifndef RTLD_GLOBAL +#define RTLD_GLOBAL 0 +#endif +u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); +#else +# ifdef _WIN32 +u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); +# else +#warning Define open-lib! +u2 = 0; +# endif +#endif + +lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym +#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) +u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); +#else +# ifdef _WIN32 +u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); +# else +#warning Define lib-sym! +u3 = 0; +# endif +#endif + +wcall ( u -- ) gforth +IF_fpTOS(fp[0]=fpTOS); +FP=fp; +sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP); +fp=FP; +IF_spTOS(spTOS=sp[0];) +IF_fpTOS(fpTOS=fp[0]); + +\+FFCALL + +av-start-void ( c_addr -- ) gforth av_start_void +av_start_void(alist, c_addr); + +av-start-int ( c_addr -- ) gforth av_start_int +av_start_int(alist, c_addr, &irv); + +av-start-float ( c_addr -- ) gforth av_start_float +av_start_float(alist, c_addr, &frv); + +av-start-double ( c_addr -- ) gforth av_start_double +av_start_double(alist, c_addr, &drv); + +av-start-longlong ( c_addr -- ) gforth av_start_longlong +av_start_longlong(alist, c_addr, &llrv); + +av-start-ptr ( c_addr -- ) gforth av_start_ptr +av_start_ptr(alist, c_addr, void*, &prv); + +av-int ( w -- ) gforth av_int +av_int(alist, w); + +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-double-r ( -- ) gforth av_double_r +double r = *(Float*)lp; +lp += sizeof(Float); +av_double(alist, r); + +av-longlong-r ( R:d -- ) gforth av_longlong_r +av_longlong(alist, d); + +av-ptr-r ( R:c_addr -- ) gforth av_ptr_r +av_ptr(alist, void*, c_addr); + +av-call-void ( -- ) gforth av_call_void +SAVE_REGS +av_call(alist); +REST_REGS + +av-call-int ( -- w ) gforth av_call_int +SAVE_REGS +av_call(alist); +REST_REGS +w = irv; + +av-call-float ( -- r ) gforth av_call_float +SAVE_REGS +av_call(alist); +REST_REGS +r = frv; + +av-call-double ( -- r ) gforth av_call_double +SAVE_REGS +av_call(alist); +REST_REGS +r = drv; + +av-call-longlong ( -- d ) gforth av_call_longlong +SAVE_REGS +av_call(alist); +REST_REGS +d = llrv; + +av-call-ptr ( -- c_addr ) gforth av_call_ptr +SAVE_REGS +av_call(alist); +REST_REGS +c_addr = prv; + +alloc-callback ( a_ip -- c_addr ) gforth alloc_callback +c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip); + +va-start-void ( -- ) gforth va_start_void +va_start_void(clist); + +va-start-int ( -- ) gforth va_start_int +va_start_int(clist); + +va-start-longlong ( -- ) gforth va_start_longlong +va_start_longlong(clist); + +va-start-ptr ( -- ) gforth va_start_ptr +va_start_ptr(clist, (char *)); + +va-start-float ( -- ) gforth va_start_float +va_start_float(clist); + +va-start-double ( -- ) gforth va_start_double +va_start_double(clist); + +va-arg-int ( -- w ) gforth va_arg_int +w = va_arg_int(clist); + +va-arg-longlong ( -- d ) gforth va_arg_longlong +d = va_arg_longlong(clist); + +va-arg-ptr ( -- c_addr ) gforth va_arg_ptr +c_addr = (char *)va_arg_ptr(clist,char*); + +va-arg-float ( -- r ) gforth va_arg_float +r = va_arg_float(clist); + +va-arg-double ( -- r ) gforth va_arg_double +r = va_arg_double(clist); + +va-return-void ( -- ) gforth va_return_void +va_return_void(clist); +return 0; + +va-return-int ( w -- ) gforth va_return_int +va_return_int(clist, w); +return 0; + +va-return-ptr ( c_addr -- ) gforth va_return_ptr +va_return_ptr(clist, void *, c_addr); +return 0; + +va-return-longlong ( d -- ) gforth va_return_longlong +va_return_longlong(clist, d); +return 0; + +va-return-float ( r -- ) gforth va_return_float +va_return_float(clist, r); +return 0; + +va-return-double ( r -- ) gforth va_return_double +va_return_double(clist, r); +return 0; + +\+ + +\+OLDCALL + define(`uploop', `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') define(`_uploop', @@ -2336,52 +2507,18 @@ rret = (SYSCALL(Float(*)(argdlist($1)))u \ close ' to keep fontify happy -open-lib ( c_addr1 u1 -- u2 ) gforth open_lib -#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) -#ifndef RTLD_GLOBAL -#define RTLD_GLOBAL 0 -#endif -u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY); -#else -# ifdef _WIN32 -u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); -# else -#warning Define open-lib! -u2 = 0; -# endif -#endif - -lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym -#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) -u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); -#else -# ifdef _WIN32 -u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); -# else -#warning Define lib-sym! -u3 = 0; -# endif -#endif - uploop(i, 0, 7, `icall(i)') icall(20) uploop(i, 0, 7, `fcall(i)') fcall(20) \+ +\+ -wcall ( u -- ) gforth -IF_fpTOS(fp[0]=fpTOS); -FP=fp; -sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP); -fp=FP; -IF_spTOS(spTOS=sp[0];) -IF_fpTOS(fpTOS=fp[0]); +\g peephole \+peephole -\g peephole - compile-prim1 ( a_prim -- ) gforth compile_prim1 ""compile prim (incl. immargs) at @var{a_prim}"" compile_prim1(a_prim); @@ -2416,8 +2553,15 @@ JUMP(a_callee); assert(0); #endif +tag-offsets ( -- a_addr ) gforth tag_offsets +extern Cell groups[32]; +a_addr = groups; + \+ -include(peeprules.vmg) +\g static_super + +ifdef(`M4_ENGINE_FAST', +`include(peeprules.vmg)') \g end