Diff for /gforth/prim between versions 1.70 and 1.82

version 1.70, 2001/01/14 22:53:19 version 1.82, 2001/05/01 13:35:42
Line 72 Line 72
 \ df_.*         DFloat *  \ df_.*         DFloat *
 \ sf_.*         SFloat *  \ sf_.*         SFloat *
 \ xt.*          XT  \ xt.*          XT
 \ wid.*         WID  
 \ f83name.*     F83Name *  \ 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 get-current prefixes set-current
 \E   \E 
 \E s" Bool"             single data-stack type-prefix f  \E s" Bool"             single data-stack type-prefix f
Line 91 Line 94
 \E s" DFloat *"         single data-stack type-prefix df_  \E s" DFloat *"         single data-stack type-prefix df_
 \E s" SFloat *"         single data-stack type-prefix sf_  \E s" SFloat *"         single data-stack type-prefix sf_
 \E s" Xt"               single data-stack type-prefix xt  \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 F83Name *" single data-stack type-prefix f83name
   \E s" struct Longname *" single data-stack type-prefix longname
 \E   \E 
 \E return-stack stack-prefix R:  \E return-stack stack-prefix R:
 \E inst-stream  stack-prefix #  \E inst-stream  stack-prefix #
Line 127 Line 130
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   undefine(`symbols')
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
 :  :
Line 140  execute ( xt -- )  core Line 144  execute ( xt -- )  core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
 ip=IP;  ip=IP;
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
Line 147  perform ( a_addr -- ) gforth Line 152  perform ( a_addr -- ) gforth
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
   SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
Line 1186  f83name2=f83name1; Line 1192  f83name2=f83name1;
         r> @          r> @
     REPEAT  THEN  nip nip ;      REPEAT  THEN  nip nip ;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (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  \+hash
   
Line 1423  cache."" Line 1429  cache.""
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE(c_addr,u);
   
 (bye)   ( n -- )        gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
   SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  peren_system
Line 2136  Variable UP Line 2143  Variable UP
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_fpTOS(fp[0]=fpTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);  sp=(Cell*)(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;  fp=FP;
 IF_spTOS(spTOS=sp[0];)  IF_spTOS(spTOS=sp[0];)
 IF_fpTOS(fpTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
Line 2279  for(u2=0; u2<u1; u2++) Line 2286  for(u2=0; u2<u1; u2++)
 wior=FILEIO(ferror((FILE *)wfileid));  wior=FILEIO(ferror((FILE *)wfileid));
   
 \+  \+
   
   (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? */)
       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
   
   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)
   
   \+

Removed from v.1.70  
changed lines
  Added in v.1.82


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>