--- gforth/prim 2001/01/09 16:11:35 1.69 +++ gforth/prim 2001/06/16 22:53:36 1.83 @@ -72,9 +72,12 @@ \ df_.* DFloat * \ sf_.* SFloat * \ xt.* XT -\ wid.* WID \ f83name.* F83Name * +\E stack data-stack sp Cell +\E stack fp-stack fp Float +\E stack return-stack rp Cell +\E \E get-current prefixes set-current \E \E s" Bool" single data-stack type-prefix f @@ -91,8 +94,8 @@ \E s" DFloat *" single data-stack type-prefix df_ \E s" SFloat *" single data-stack type-prefix sf_ \E s" Xt" single data-stack type-prefix xt -\E s" WID" single data-stack type-prefix wid \E s" struct F83Name *" single data-stack type-prefix f83name +\E s" struct Longname *" single data-stack type-prefix longname \E \E return-stack stack-prefix R: \E inst-stream stack-prefix # @@ -127,6 +130,9 @@ \ these m4 macros would collide with identifiers undefine(`index') undefine(`shift') +undefine(`symbols') + +\g control noop ( -- ) gforth : @@ -140,6 +146,7 @@ execute ( xt -- ) core ""Perform the semantics represented by the execution token, @i{xt}."" ip=IP; IF_spTOS(spTOS = sp[0]); +SUPER_END; EXEC(xt); perform ( a_addr -- ) gforth @@ -147,6 +154,7 @@ perform ( a_addr -- ) gforth /* and pfe */ ip=IP; IF_spTOS(spTOS = sp[0]); +SUPER_END; EXEC(*(Xt *)a_addr); : @ execute ; @@ -403,6 +411,8 @@ k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 ) \ digit is high-level: 0/0% +\g strings + move ( c_from c_to ucount -- ) core ""Copy the contents of @i{ucount} aus at @i{c-from} to @i{c-to}. @code{move} works correctly even if the two areas overlap."" @@ -512,6 +522,8 @@ u2 = u1-n; : tuck - >r + r> dup 0< IF - 0 THEN ; +\g arith + + ( n1 n2 -- n ) core plus n = n1+n2; @@ -909,6 +921,8 @@ f = FLAG(u1-u2 < u3-u2); : over - >r - r> u< ; +\g internal + sp@ ( -- a_addr ) gforth sp_fetch a_addr = sp+1; @@ -936,6 +950,8 @@ fp = f_addr; ""The primitive compiled by @code{EXIT}."" SET_IP((Xt *)w); +\g stack + >r ( w -- R:w ) core to_r : (>r) ; @@ -1186,7 +1202,7 @@ f83name2=f83name1; r> @ REPEAT THEN nip nip ; : (find-samelen) ( u f83name1 -- u f83name2/0 ) - BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; + BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; \+hash @@ -1375,6 +1391,8 @@ n=1; \f[THEN] +\g hostos + key-file ( wfileid -- n ) gforth paren_key_file #ifdef HAS_FILE fflush(stdout); @@ -1423,6 +1441,7 @@ cache."" FLUSH_ICACHE(c_addr,u); (bye) ( n -- ) gforth paren_bye +SUPER_END; return (Label *)n; (system) ( c_addr u -- wretval wior ) gforth peren_system @@ -1665,6 +1684,8 @@ else { \+ \+floating +\g floating + comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) @@ -2136,7 +2157,7 @@ Variable UP wcall ( u -- ) gforth IF_fpTOS(fp[0]=fpTOS); FP=fp; -sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP); +sp=(Cell*)(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP); fp=FP; IF_spTOS(spTOS=sp[0];) IF_fpTOS(fpTOS=fp[0]); @@ -2157,8 +2178,10 @@ if(dent == NULL) { flag = 0; } else { u2 = strlen(dent->d_name); - if(u2 > u1) + if(u2 > u1) { u2 = u1; + wior = -512-ENAMETOOLONG; + } memmove(c_addr, dent->d_name, u2); } @@ -2277,3 +2300,99 @@ for(u2=0; u2next)) + 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 + >r 2dup r@ cell+ cell+ capscomp 0= + IF 2drop r> EXIT THEN + r> @ + REPEAT THEN nip nip ; +: (findl-samelen) ( u longname1 -- u longname2/0 ) + BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ; + +\+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; + } +} +: + BEGIN dup WHILE + 2@ >r >r dup r@ cell+ @ lcount-mask and = + IF 2dup r@ cell+ cell+ capscomp 0= + IF 2drop r> rdrop EXIT THEN THEN + rdrop r> + REPEAT nip nip ; + +(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; + } +} +: + BEGIN dup WHILE + 2@ >r >r dup r@ cell+ @ lcount-mask and = + IF 2dup r@ cell+ cell+ -text 0= + IF 2drop r> rdrop EXIT THEN THEN + rdrop r> + REPEAT nip nip ; + +\+ + +\+peephole + +\g peephole + +primtable ( -- wprimtable ) new +""wprimtable is a table containing the xts of the primitives indexed +by sequence-number in prim (for use in prepare-peephole-table)."" +wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1); + +prepare-peephole-table ( wprimtable -- wpeeptable ) new prepare_peephole_opt +""wpeeptable is a data structure used by @code{peephole-opt}; it is +constructed by combining a primitives table with a simple peephole +optimization table."" +wpeeptable = prepare_peephole_table((Xt *)wprimtable); + +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); + +call ( #a_callee -- R:a_retaddr ) +""Call callee (a variant of docol with inline argument)."" +a_retaddr = (Cell *)IP; +SET_IP((Xt *)a_callee); + +useraddr ( #u -- a_addr ) +a_addr = (Cell *)(up+u); + +include(peeprules.vmg) + +\+