--- gforth/prim 2001/01/27 20:14:55 1.71 +++ gforth/prim 2002/08/28 21:46:58 1.97 @@ -53,15 +53,18 @@ \ your code does not fall through, the results are not stored into the \ stack. Use different names on both sides of the '--', if you change a \ value (some stores to the stack are optimized away). -\ -\ +\ +\ For superinstructions the syntax is: +\ +\ forth-name [/ c-name] = forth-name forth-name ... +\ \ \ The stack variables have the following types: \ \ name matches type \ f.* Bool \ c.* Char -\ [nw].* Cell +\ [nw].* Cell \ u.* UCell \ d.* DCell \ ud.* UDCell @@ -72,9 +75,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,7 +97,6 @@ \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 @@ -99,6 +104,7 @@ \E inst-stream stack-prefix # \E \E set-current +\E store-optimization on \ \ @@ -128,6 +134,9 @@ \ these m4 macros would collide with identifiers undefine(`index') undefine(`shift') +undefine(`symbols') + +\g control noop ( -- ) gforth : @@ -141,6 +150,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 @@ -148,6 +158,7 @@ perform ( a_addr -- ) gforth /* and pfe */ ip=IP; IF_spTOS(spTOS = sp[0]); +SUPER_END; EXEC(*(Xt *)a_addr); : @ execute ; @@ -172,8 +183,9 @@ SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); define(condbranch, $1 ( `#'ndisp $2 ) $3 $4 SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); -TAIL; +INST_TAIL; } +SUPER_CONTINUE; $5 \+glocals @@ -181,8 +193,9 @@ $5 $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number $4 lp += nlocals; SET_IP((Xt *)(((Cell)(IP-2))+ndisp)); -TAIL; +INST_TAIL; } +SUPER_CONTINUE; \+ ) @@ -207,8 +220,9 @@ if (f==0) { sp++; IF_spTOS(spTOS = sp[0]); SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); - TAIL; + INST_TAIL; } +SUPER_CONTINUE; ?dup-0=-?branch ( #ndisp f -- ) new question_dupe_zero_equals_question_branch ""The run-time procedure compiled by @code{?DUP-0=-IF}."" @@ -221,6 +235,7 @@ if (f!=0) { SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); NEXT; } +SUPER_CONTINUE; \+ \f[THEN] @@ -300,8 +315,9 @@ nlimit=0; (?do) ( #ndisp nlimit nstart -- R:nlimit R:nstart ) gforth paren_question_do if (nstart == nlimit) { SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); - TAIL; + INST_TAIL; } +SUPER_CONTINUE; : 2dup = IF r> swap rot >r >r @@ -315,8 +331,9 @@ if (nstart == nlimit) { (+do) ( #ndisp nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do if (nstart >= nlimit) { SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); - TAIL; + INST_TAIL; } +SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -330,8 +347,9 @@ if (nstart >= nlimit) { (u+do) ( #ndisp ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do if (ustart >= ulimit) { SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); - TAIL; + INST_TAIL; } +SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -345,8 +363,9 @@ if (ustart >= ulimit) { (-do) ( #ndisp nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do if (nstart <= nlimit) { SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); - TAIL; + INST_TAIL; } +SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -360,8 +379,9 @@ if (nstart <= nlimit) { (u-do) ( #ndisp ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do if (ustart <= ulimit) { SET_IP((Xt *)(((Cell)(IP-1))+ndisp)); - TAIL; + INST_TAIL; } +SUPER_CONTINUE; : swap 2dup r> swap >r swap >r @@ -404,6 +424,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."" @@ -513,6 +535,8 @@ u2 = u1-n; : tuck - >r + r> dup 0< IF - 0 THEN ; +\g arith + + ( n1 n2 -- n ) core plus n = n1+n2; @@ -910,6 +934,8 @@ f = FLAG(u1-u2 < u3-u2); : over - >r - r> u< ; +\g internal + sp@ ( -- a_addr ) gforth sp_fetch a_addr = sp+1; @@ -937,6 +963,8 @@ fp = f_addr; ""The primitive compiled by @code{EXIT}."" SET_IP((Xt *)w); +\g stack + >r ( w -- R:w ) core to_r : (>r) ; @@ -1187,7 +1215,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 @@ -1332,7 +1360,6 @@ a_addr = (Cell *)DOES_CODE(xt); 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); -CACHE_FLUSH(xt,(size_t)PFA(0)); : ! ; @@ -1340,7 +1367,6 @@ does-code! ( a_addr xt -- ) gforth does ""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); -CACHE_FLUSH(xt,(size_t)PFA(0)); : dodoes: over ! cell+ ! ; @@ -1348,7 +1374,6 @@ does-handler! ( a_addr -- ) gforth does_ ""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); -CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE); : drop ; @@ -1376,6 +1401,8 @@ n=1; \f[THEN] +\g hostos + key-file ( wfileid -- n ) gforth paren_key_file #ifdef HAS_FILE fflush(stdout); @@ -1424,6 +1451,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 @@ -1448,7 +1476,7 @@ c_addr2 = getenv(cstr(c_addr1,u1,1)); u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe -wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */ +wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ close-pipe ( wfileid -- wretval wior ) gforth close_pipe @@ -1590,7 +1618,7 @@ if (wior) clearerr((FILE *)wfileid); read-line ( c_addr u1 wfileid -- u2 flag wior ) file read_line -""this is only for backward compatibility"" +/* this may one day be replaced with : read-line (read-line) nip ; */ Cell c; flag=-1; for(u2=0; u20. +If the attempt succeeds, store file name to the buffer at @i{c-addr} +and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name. +If the length of the file name is greater than @i{u1}, +store first @i{u1} characters from file name into the buffer and +indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}."" struct dirent * dent; dent = readdir((DIR *)wdirid); wior = 0; @@ -2166,6 +2209,7 @@ if(dent == NULL) { } close-dir ( wdirid -- wior ) gforth close_dir +""Close the directory specified by @i{dir-id}."" wior = IOR(closedir((DIR *)wdirid)); filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file @@ -2288,13 +2332,13 @@ for (; longname1 != NULL; longname1 = (s break; longname2=longname1; : - BEGIN dup WHILE (find-samelen) dup WHILE - >r 2dup r@ cell+ char+ capscomp 0= + BEGIN dup WHILE (findl-samelen) dup WHILE + >r 2dup r@ cell+ cell+ capscomp 0= IF 2drop r> EXIT THEN r> @ REPEAT THEN nip nip ; -: (find-samelen) ( u longname1 -- u longname2/0 ) - BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; +: (findl-samelen) ( u longname1 -- u longname2/0 ) + BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ; \+hash @@ -2314,8 +2358,8 @@ while(a_addr != NULL) } : BEGIN dup WHILE - 2@ >r >r dup r@ cell+ c@ $1F and = - IF 2dup r@ cell+ char+ capscomp 0= + 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 ; @@ -2337,10 +2381,74 @@ while(a_addr != NULL) } : BEGIN dup WHILE - 2@ >r >r dup r@ cell+ c@ $1F and = - IF 2dup r@ cell+ char+ -text 0= + 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 ) new +""Call callee (a variant of docol with inline argument)."" +#ifdef DEBUG + { + CFA_TO_NAME((((Cell *)a_callee)-2)); + fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee, + len,name); + } +#endif +a_retaddr = (Cell *)IP; +SET_IP((Xt *)a_callee); + +useraddr ( #u -- a_addr ) new +a_addr = (Cell *)(up+u); + +compile-prim ( xt1 -- xt2 ) new compile_prim +xt2 = (Xt)compile_prim((Label)xt1); + +lit@ / lit_fetch = lit @ + +lit-perform ( #a_addr -- ) new lit_perform +ip=IP; +SUPER_END; +EXEC(*(Xt *)a_addr); + +lit+ / lit_plus = lit + + +does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec +a_pfa = PFA(a_cfa); +nest = (Cell)ip; +IF_spTOS(spTOS = sp[0]); +#ifdef DEBUG + { + CFA_TO_NAME(a_cfa); + fprintf(stderr,"%08lx: does %08lx %.*s\n", + (Cell)ip,(Cell)a_cfa,len,name); + } +#endif +SET_IP(DOES_CODE1(a_cfa)); + +include(peeprules.vmg) + +\+