Diff for /gforth/prim between versions 1.68 and 1.84

version 1.68, 2000/12/24 15:54:18 version 1.84, 2001/12/01 20:33:14
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')
   
   \g control
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
 :  :
Line 140  execute ( xt -- )  core Line 146  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 154  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 403  k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 ) Line 411  k ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
   \g strings
   
 move    ( c_from c_to ucount -- )               core  move    ( c_from c_to ucount -- )               core
 ""Copy the contents of @i{ucount} aus at @i{c-from} to  ""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.""  @i{c-to}. @code{move} works correctly even if the two areas overlap.""
Line 512  u2 = u1-n; Line 522  u2 = u1-n;
 :  :
  tuck - >r + r> dup 0< IF  - 0  THEN ;   tuck - >r + r> dup 0< IF  - 0  THEN ;
   
   \g arith
   
 +       ( n1 n2 -- n )          core    plus  +       ( n1 n2 -- n )          core    plus
 n = n1+n2;  n = n1+n2;
   
Line 909  f = FLAG(u1-u2 < u3-u2); Line 921  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
   \g internal
   
 sp@     ( -- a_addr )           gforth          sp_fetch  sp@     ( -- a_addr )           gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp+1;
   
Line 936  fp = f_addr; Line 950  fp = f_addr;
 ""The primitive compiled by @code{EXIT}.""  ""The primitive compiled by @code{EXIT}.""
 SET_IP((Xt *)w);  SET_IP((Xt *)w);
   
   \g stack
   
 >r      ( w -- R:w )            core    to_r  >r      ( w -- R:w )            core    to_r
 :  :
  (>r) ;   (>r) ;
Line 1186  f83name2=f83name1; Line 1202  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 1375  n=1; Line 1391  n=1;
   
 \f[THEN]  \f[THEN]
   
   \g hostos
   
 key-file        ( wfileid -- n )                gforth  paren_key_file  key-file        ( wfileid -- n )                gforth  paren_key_file
 #ifdef HAS_FILE  #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
Line 1423  cache."" Line 1441  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 1447  c_addr2 = getenv(cstr(c_addr1,u1,1)); Line 1466  c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe  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 */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
Line 1665  else { Line 1684  else {
 \+  \+
 \+floating  \+floating
   
   \g floating
   
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)  comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)  comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
   
Line 2136  Variable UP Line 2157  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 2157  if(dent == NULL) { Line 2178  if(dent == NULL) {
   flag = 0;    flag = 0;
 } else {  } else {
   u2 = strlen(dent->d_name);    u2 = strlen(dent->d_name);
   if(u2 > u1)    if(u2 > u1) {
     u2 = u1;      u2 = u1;
       wior = -512-ENAMETOOLONG;
     }
   memmove(c_addr, dent->d_name, u2);    memmove(c_addr, dent->d_name, u2);
 }  }
   
Line 2175  flag = FLAG(!fnmatch(pattern, string, 0) Line 2198  flag = FLAG(!fnmatch(pattern, string, 0)
 newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
 ""String containing the newline sequence of the host OS""  ""String containing the newline sequence of the host OS""
 char newline[] = {  char newline[] = {
 #ifdef unix  #if defined(unix) || defined(__MACH__)
   /* Darwin/MacOS X sets __MACH__, but not unix. */
 '\n'  '\n'
 #else  #else
 '\r','\n'  '\r','\n'
Line 2276  for(u2=0; u2<u1; u2++) Line 2300  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
   
   \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)
   
   \+

Removed from v.1.68  
changed lines
  Added in v.1.84


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