Diff for /gforth/prim between versions 1.100 and 1.110

version 1.100, 2002/10/04 19:17:05 version 1.110, 2002/12/28 17:18:27
Line 105 Line 105
 \E   \E 
 \E set-current  \E set-current
 \E store-optimization on  \E store-optimization on
   \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
   
 \   \ 
 \   \ 
Line 148  lit ( #w -- w )  gforth Line 149  lit ( #w -- w )  gforth
   
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
   #ifndef NO_IP
 ip=IP;  ip=IP;
   #endif
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 SUPER_END;  SUPER_END;
 EXEC(xt);  EXEC(xt);
Line 156  EXEC(xt); Line 159  EXEC(xt);
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
   #ifndef NO_IP
 ip=IP;  ip=IP;
   #endif
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
Line 813  lshift ( u1 n -- u2 )  core l_shift Line 818  lshift ( u1 n -- u2 )  core l_shift
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
   \g compare
   
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,  define(comparisons,
 $1=     ( $2 -- f )             $6      $3equals  $1=     ( $2 -- f )             $6      $3equals
Line 934  f = FLAG(u1-u2 < u3-u2); Line 941  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 961  fp = f_addr; Line 966  fp = f_addr;
   
 ;s      ( R:w -- )              gforth  semis  ;s      ( R:w -- )              gforth  semis
 ""The primitive compiled by @code{EXIT}.""  ""The primitive compiled by @code{EXIT}.""
   #ifdef NO_IP
   INST_TAIL;
   goto *(void *)w;
   #else
 SET_IP((Xt *)w);  SET_IP((Xt *)w);
   #endif
   
 \g stack  \g stack
   
Line 1081  w = sp[u+1]; Line 1091  w = sp[u+1];
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
   \g memory
   
 @       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
 ""@i{w} is the cell stored at @i{a_addr}.""  ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
Line 1202  c_addr2 = c_addr1+1; Line 1214  c_addr2 = c_addr1+1;
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
   \g compiler
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
Line 1279  while(u1--) Line 1293  while(u1--)
    ASCII strings (larger if ubits is large), and should share no     ASCII strings (larger if ubits is large), and should share no
    divisors with ubits.     divisors with ubits.
 */  */
 unsigned rot = ((char []){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})[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;  Char *cp = c_addr;
 for (ukey=0; cp<c_addr+u; cp++)  for (ukey=0; cp<c_addr+u; cp++)
     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))       ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) 
Line 1595  wior = IOR(rename(tilde_cstr(c_addr1, u1 Line 1610  wior = IOR(rename(tilde_cstr(c_addr1, u1
   
 file-position   ( wfileid -- ud wior )  file    file_position  file-position   ( wfileid -- ud wior )  file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
 ud = LONG2UD(ftell((FILE *)wfileid));  ud = OFF2UD(ftello((FILE *)wfileid));
 wior = IOR(UD2LONG(ud)==-1);  wior = IOR(UD2OFF(ud)==-1);
   
 reposition-file ( ud wfileid -- wior )  file    reposition_file  reposition-file ( ud wfileid -- wior )  file    reposition_file
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);  wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1);
   
 file-size       ( wfileid -- ud wior )  file    file_size  file-size       ( wfileid -- ud wior )  file    file_size
 struct stat buf;  struct stat buf;
 wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);  wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 ud = LONG2UD(buf.st_size);  ud = OFF2UD(buf.st_size);
   
 resize-file     ( ud wfileid -- wior )  file    resize_file  resize-file     ( ud wfileid -- wior )  file    resize_file
 wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1);  wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1);
   
 read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file  read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
Line 1799  floor ( r1 -- r2 ) float Line 1814  floor ( r1 -- r2 ) float
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround  ( r1 -- r2 )    float   f_round  fround  ( r1 -- r2 )    gforth  f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
 /* !! unclear wording */  
 #ifdef HAVE_RINT  
 r2 = rint(r1);  r2 = rint(r1);
 #else  
 r2 = floor(r1+0.5);  
 /* !! This is not quite true to the rounding rules given in the standard */  
 #endif  
   
 fmax    ( r1 r2 -- r3 ) float   f_max  fmax    ( r1 r2 -- r3 ) float   f_max
 if (r1<r2)  if (r1<r2)
Line 2018  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 2027  df_addr = (DFloat *)((((Cell)c_addr)+(si
 \+  \+
 \+glocals  \+glocals
   
   \g locals
   
 @local# ( #noffset -- w )       gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
 w = *(Cell *)(lp+noffset);  w = *(Cell *)(lp+noffset);
   
Line 2089  r = fp[u+1]; /* +1, because update of fp Line 2100  r = fp[u+1]; /* +1, because update of fp
   
 \+OS  \+OS
   
   \g syslib
   
 define(`uploop',  define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')         `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
 define(`_uploop',  define(`_uploop',
Line 2407  xt = peephole_opt(xt1, xt2, wpeeptable); Line 2420  xt = peephole_opt(xt1, xt2, wpeeptable);
   
 call    ( #a_callee -- R:a_retaddr )    new  call    ( #a_callee -- R:a_retaddr )    new
 ""Call callee (a variant of docol with inline argument).""  ""Call callee (a variant of docol with inline argument).""
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_callee);
   #else
 #ifdef DEBUG  #ifdef DEBUG
     {      {
       CFA_TO_NAME((((Cell *)a_callee)-2));        CFA_TO_NAME((((Cell *)a_callee)-2));
Line 2416  call ( #a_callee -- R:a_retaddr ) new Line 2433  call ( #a_callee -- R:a_retaddr ) new
 #endif  #endif
 a_retaddr = (Cell *)IP;  a_retaddr = (Cell *)IP;
 SET_IP((Xt *)a_callee);  SET_IP((Xt *)a_callee);
   #endif
   
 useraddr        ( #u -- a_addr )        new  useraddr        ( #u -- a_addr )        new
 a_addr = (Cell *)(up+u);  a_addr = (Cell *)(up+u);
   
 compile-prim ( xt1 -- xt2 )     new     compile_prim  compile-prim ( xt1 -- xt2 )     obsolete        compile_prim
 xt2 = (Xt)compile_prim((Label)xt1);  xt2 = (Xt)compile_prim((Label)xt1);
   
 \ lit@ / lit_fetch = lit @  \ lit@ / lit_fetch = lit @
Line 2429  lit@  ( #a_addr -- w ) new lit_fetch Line 2447  lit@  ( #a_addr -- w ) new lit_fetch
 w = *a_addr;  w = *a_addr;
   
 lit-perform     ( #a_addr -- )  new     lit_perform  lit-perform     ( #a_addr -- )  new     lit_perform
   #ifndef NO_IP
 ip=IP;  ip=IP;
   #endif
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
   
Line 2439  lit+ ( n1 #n2 -- n )  new lit_plus Line 2459  lit+ ( n1 #n2 -- n )  new lit_plus
 n=n1+n2;  n=n1+n2;
   
 does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec  does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
   #ifdef NO_IP
   /* compiled to LIT CALL by compile_prim */
   assert(0);
   #else
 a_pfa = PFA(a_cfa);  a_pfa = PFA(a_cfa);
 nest = (Cell)ip;  nest = (Cell)IP;
 IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 #ifdef DEBUG  #ifdef DEBUG
     {      {
Line 2450  IF_spTOS(spTOS = sp[0]); Line 2474  IF_spTOS(spTOS = sp[0]);
     }      }
 #endif  #endif
 SET_IP(DOES_CODE1(a_cfa));  SET_IP(DOES_CODE1(a_cfa));
   #endif
   
 abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number  abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 lp += nlocals;  lp += nlocals;
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   #endif
   
 \+  \+
   
 abranch ( #a_target -- )        gforth  abranch ( #a_target -- )        gforth
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   #endif
 :  :
  r> @ >r ;   r> @ >r ;
   
 \ acondbranch(forthname,stackeffect,restline,code,forthcode)  \ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(acondbranch,  define(acondbranch,
 $1 ( `#'a_target $2 ) $3  $1 ( `#'a_target $2 ) $3
 $4      SET_IP((Xt *)a_target);  $4      #ifdef NO_IP
 INST_TAIL;  INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 $5  $6
   
 \+glocals  \+glocals
   
 $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number  $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
 $4    lp += nlocals;  $4      #ifdef NO_IP
 SET_IP((Xt *)a_target);  
 INST_TAIL;  INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
Line 2486  SUPER_CONTINUE; Line 2535  SUPER_CONTINUE;
 )  )
   
 acondbranch(a?branch,f --,f83   aquestion_branch,  acondbranch(a?branch,f --,f83   aquestion_branch,
 if (f==0) {  ,if (f==0) {
 ,:  ,:
  0= dup     \ !f !f \ !! still uses relative addresses   0= dup     \ !f !f \ !! still uses relative addresses
  r> dup @   \ !f !f IP branchoffset   r> dup @   \ !f !f IP branchoffset
Line 2504  a?dup-?branch ( #a_target f -- f ) new a Line 2553  a?dup-?branch ( #a_target f -- f ) new a
 if (f==0) {  if (f==0) {
   sp++;    sp++;
   IF_spTOS(spTOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)a_target);  #ifdef NO_IP
   INST_TAIL;  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
Line 2517  few cycles in that case, but is easy to Line 2571  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   #ifdef NO_IP
     JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);    SET_IP((Xt *)a_target);
   NEXT;    NEXT;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
   
Line 2528  SUPER_CONTINUE; Line 2586  SUPER_CONTINUE;
   
 acondbranch(a(next),R:n1 -- R:n2,cmFORTH        aparen_next,  acondbranch(a(next),R:n1 -- R:n2,cmFORTH        aparen_next,
 n2=n1-1;  n2=n1-1;
 if (n1) {  ,if (n1) {
 ,:  ,:
  r> r> dup 1- >r   r> r> dup 1- >r
  IF @ >r ELSE cell+ >r THEN ;)   IF @ >r ELSE cell+ >r THEN ;)
   
 acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth       aparen_loop,  acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth       aparen_loop,
 n2=n1+1;  n2=n1+1;
 if (n2 != nlimit) {  ,if (n2 != nlimit) {
 ,:  ,:
  r> r> 1+ r> 2dup =   r> r> 1+ r> 2dup =
  IF >r 1- >r cell+ >r   IF >r 1- >r cell+ >r
Line 2547  acondbranch(a(+loop),n R:nlimit R:n1 -- Line 2605  acondbranch(a(+loop),n R:nlimit R:n1 --
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = n1-nlimit;  Cell olddiff = n1-nlimit;
 n2=n1+n;          n2=n1+n;        
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 ,:  ,:
  r> swap   r> swap
Line 2562  if ((olddiff^(olddiff+n))>=0   /* the li Line 2620  if ((olddiff^(olddiff+n))>=0   /* the li
 acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,  acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,
 UCell olddiff = n1-nlimit;  UCell olddiff = n1-nlimit;
 n2=n1-u;  n2=n1-u;
 if (olddiff>u) {  ,if (olddiff>u) {
 ,)  ,)
   
 acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth   aparen_symmetric_plus_loop,  acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth   aparen_symmetric_plus_loop,
Line 2577  if (n<0) { Line 2635  if (n<0) {
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 n2=n1+n;  n2=n1+n;
 if (diff>=0 || newdiff<0) {  ,if (diff>=0 || newdiff<0) {
 ,)  ,)
   
 a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth  aparen_question_do  a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth  aparen_question_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (nstart == nlimit) {  if (nstart == nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);      SET_IP((Xt *)a_target);
     INST_TAIL;      INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 2597  SUPER_CONTINUE; Line 2662  SUPER_CONTINUE;
 \+xconds  \+xconds
   
 a(+do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do  a(+do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do
   #ifdef NO_IP
       INST_TAIL;
   #endif
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
   #ifdef NO_IP
       JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);      SET_IP((Xt *)a_target);
     INST_TAIL;      INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 2613  SUPER_CONTINUE; Line 2685  SUPER_CONTINUE;
  THEN  >r ;   THEN  >r ;
   
 a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do  a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do
 if (ustart >= ulimit) {  #ifdef NO_IP
     SET_IP((Xt *)a_target);  
     INST_TAIL;      INST_TAIL;
   #endif
   if (ustart >= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 2629  SUPER_CONTINUE; Line 2708  SUPER_CONTINUE;
  THEN  >r ;   THEN  >r ;
   
 a(-do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do  a(-do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do
 if (nstart <= nlimit) {  #ifdef NO_IP
     SET_IP((Xt *)a_target);  
     INST_TAIL;      INST_TAIL;
   #endif
   if (nstart <= nlimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 2645  SUPER_CONTINUE; Line 2731  SUPER_CONTINUE;
  THEN  >r ;   THEN  >r ;
   
 a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do  a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do
 if (ustart <= ulimit) {  #ifdef NO_IP
     SET_IP((Xt *)a_target);  
     INST_TAIL;      INST_TAIL;
   #endif
   if (ustart <= ulimit) {
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 SUPER_CONTINUE;  SUPER_CONTINUE;
 :  :
Line 2660  SUPER_CONTINUE; Line 2753  SUPER_CONTINUE;
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
   \ set-next-code and call2 do not appear in images and can be
   \ renumbered arbitrarily
   
   set-next-code ( #w -- ) gforth set_next_code
   #ifdef NO_IP
   next_code = (Label)w;
   #endif
   
   call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
   /* call with explicit return address */
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_callee);
   #else
   assert(0);
   #endif
   
   compile-prim1 ( a_prim -- ) gforth compile_prim1
   ""compile prim (incl. immargs) at @var{a_prim}""
   compile_prim1(a_prim);
   
   finish-code ( -- ) gforth finish_code
   ""Perform delayed steps in code generation (branch resolution, I-cache
   flushing).""
   finish_code();
   
   forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
   f = forget_dyncode(c_code);
   
   decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
   ""a_prim is the code address of the primitive that has been
   compile_prim1ed to a_code""
   a_prim = decompile_code(a_code);
   
 \+  \+
   
 include(peeprules.vmg)  include(peeprules.vmg)
   
   \g end
   
 \+  \+

Removed from v.1.100  
changed lines
  Added in v.1.110


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