[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.83 and 1.107

version 1.83, Sat Jun 16 22:53:36 2001 UTC version 1.107, Thu Dec 19 23:23:49 2002 UTC
Line 54 
Line 54 
 \ stack. Use different names on both sides of the '--', if you change a  \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).  \ 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:  \ The stack variables have the following types:
Line 101 
Line 104 
 \E inst-stream  stack-prefix #  \E inst-stream  stack-prefix #
 \E  \E
 \E set-current  \E set-current
   \E store-optimization on
   
 \  \
 \  \
Line 144 
Line 148 
   
 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 152 
Line 158 
 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 179 
Line 187 
 define(condbranch,  define(condbranch,
 $1 ( `#'ndisp $2 ) $3  $1 ( `#'ndisp $2 ) $3
 $4      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));  $4      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
 TAIL;  INST_TAIL;
 }  }
   SUPER_CONTINUE;
 $5  $5
   
 \+glocals  \+glocals
Line 188 
Line 197 
 $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number  $1-lp+!`#' ( `#'ndisp `#'nlocals $2 ) $3_lp_plus_store_number
 $4    lp += nlocals;  $4    lp += nlocals;
 SET_IP((Xt *)(((Cell)(IP-2))+ndisp));  SET_IP((Xt *)(((Cell)(IP-2))+ndisp));
 TAIL;  INST_TAIL;
 }  }
   SUPER_CONTINUE;
   
 \+  \+
 )  )
Line 214 
Line 224 
   sp++;    sp++;
   IF_spTOS(spTOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   TAIL;    INST_TAIL;
 }  }
   SUPER_CONTINUE;
   
 ?dup-0=-?branch ( #ndisp f -- ) new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #ndisp f -- ) new     question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
Line 228 
Line 239 
   SET_IP((Xt *)(((Cell)(IP-1))+ndisp));    SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
   NEXT;    NEXT;
 }  }
   SUPER_CONTINUE;
   
 \+  \+
 \f[THEN]  \f[THEN]
Line 307 
Line 319 
 (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do  (?do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_question_do
 if (nstart == nlimit) {  if (nstart == nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;      INST_TAIL;
 }  }
   SUPER_CONTINUE;
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
Line 322 
Line 335 
 (+do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_plus_do  (+do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_plus_do
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;      INST_TAIL;
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 337 
Line 351 
 (u+do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_plus_do  (u+do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_plus_do
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;      INST_TAIL;
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 352 
Line 367 
 (-do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_minus_do  (-do)   ( #ndisp nlimit nstart -- R:nlimit R:nstart )   gforth  paren_minus_do
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;      INST_TAIL;
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 367 
Line 383 
 (u-do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_minus_do  (u-do)  ( #ndisp ulimit ustart -- R:ulimit R:ustart )   gforth  paren_u_minus_do
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
     SET_IP((Xt *)(((Cell)(IP-1))+ndisp));      SET_IP((Xt *)(((Cell)(IP-1))+ndisp));
     TAIL;      INST_TAIL;
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 948 
Line 965 
   
 ;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 1266 
Line 1288 
    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 1347 
Line 1370 
 code-address!   ( c_addr xt -- )                gforth  code_address_store  code-address!   ( c_addr xt -- )                gforth  code_address_store
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  ""Create a code field with code address @i{c-addr} at @i{xt}.""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  :
     ! ;      ! ;
   
Line 1355 
Line 1377 
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;  ""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>}.""  @i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
Line 1363 
Line 1384 
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 @i{a-addr} points just behind a @code{DOES>}.""  @i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  
 :  :
     drop ;      drop ;
   
Line 1466 
Line 1486 
 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 1608 
Line 1628 
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 read-line       ( c_addr u1 wfileid -- u2 flag wior )   file    read_line  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;  Cell c;
 flag=-1;  flag=-1;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
Line 1698 
Line 1718 
 #endif  #endif
   
 f>d     ( r -- d )              float   f_to_d  f>d     ( r -- d )              float   f_to_d
 #ifdef BUGGY_LONG_LONG  extern DCell double2ll(Float r);
 d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);  d = double2ll(r);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  
 #else  
 d = r;  
 #endif  
   
 f!      ( r f_addr -- ) float   f_store  f!      ( r f_addr -- ) float   f_store
 ""Store @i{r} into the float at address @i{f-addr}.""  ""Store @i{r} into the float at address @i{f-addr}.""
Line 1793 
Line 1809 
 /* !! 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 2157 
Line 2167 
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_fpTOS(fp[0]=fpTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 sp=(Cell*)(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 2165 
Line 2175 
 \+file  \+file
   
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
   ""Open the directory specified by @i{c-addr, u}
   and return @i{dir-id} for futher access to it.""
 wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));  wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
 wior =  IOR(wdirid == 0);  wior =  IOR(wdirid == 0);
   
 read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir  read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
   ""Attempt to read the next entry from the directory specified
   by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}.
   If the attempt fails because there is no more entries,
   @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
   If the attempt to read the next entry fails because of any other reason,
   return @i{ior}<>0.
   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;  struct dirent * dent;
 dent = readdir((DIR *)wdirid);  dent = readdir((DIR *)wdirid);
 wior = 0;  wior = 0;
Line 2186 
Line 2209 
 }  }
   
 close-dir       ( wdirid -- wior )      gforth  close_dir  close-dir       ( wdirid -- wior )      gforth  close_dir
   ""Close the directory specified by @i{dir-id}.""
 wior = IOR(closedir((DIR *)wdirid));  wior = IOR(closedir((DIR *)wdirid));
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file
Line 2385 
Line 2409 
 they cannot be combined, xt is 0.""  they cannot be combined, xt is 0.""
 xt = peephole_opt(xt1, xt2, wpeeptable);  xt = peephole_opt(xt1, xt2, wpeeptable);
   
 call    ( #a_callee -- R:a_retaddr )  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
       {
         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;  a_retaddr = (Cell *)IP;
 SET_IP((Xt *)a_callee);  SET_IP((Xt *)a_callee);
   #endif
   
 useraddr        ( #u -- a_addr )  useraddr        ( #u -- a_addr )        new
 a_addr = (Cell *)(up+u);  a_addr = (Cell *)(up+u);
   
   compile-prim ( xt1 -- xt2 )     obsolete        compile_prim
   xt2 = (Xt)compile_prim((Label)xt1);
   
   \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
   lit-perform     ( #a_addr -- )  new     lit_perform
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   EXEC(*(Xt *)a_addr);
   
   \ lit+ / lit_plus = lit +
   
   lit+    ( n1 #n2 -- n )         new     lit_plus
   n=n1+n2;
   
   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);
   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));
   #endif
   
   abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number
   /* this will probably not be used */
   lp += nlocals;
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   
   \+
   
   abranch ( #a_target -- )        gforth
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   :
    r> @ >r ;
   
   \ acondbranch(forthname,stackeffect,restline,code1,code2,forthcode)
   \ this is non-syntactical: code must open a brace that is closed by the macro
   define(acondbranch,
   $1 ( `#'a_target $2 ) $3
   $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   $6
   
   \+glocals
   
   $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
   $4      #ifdef NO_IP
   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;
   
   \+
   )
   
   acondbranch(a?branch,f --,f83   aquestion_branch,
   ,if (f==0) {
   ,:
    0= dup     \ !f !f \ !! still uses relative addresses
    r> dup @   \ !f !f IP branchoffset
    rot and +  \ !f IP|IP+branchoffset
    swap 0= cell and + \ IP''
    >r ;)
   
   \ we don't need an lp_plus_store version of the ?dup-stuff, because it
   \ is only used in if's (yet)
   
   \+xconds
   
   a?dup-?branch   ( #a_target f -- f )    new     aquestion_dupe_question_branch
   ""The run-time procedure compiled by @code{?DUP-IF}.""
   if (f==0) {
     sp++;
     IF_spTOS(spTOS = sp[0]);
   #ifdef NO_IP
   INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
   }
   SUPER_CONTINUE;
   
   a?dup-0=-?branch ( #a_target f -- ) new aquestion_dupe_zero_equals_question_branch
   ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
   /* the approach taken here of declaring the word as having the stack
   effect ( f -- ) and correcting for it in the branch-taken case costs a
   few cycles in that case, but is easy to convert to a CONDBRANCH
   invocation */
   if (f!=0) {
     sp--;
   #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
     NEXT;
   #endif
   }
   SUPER_CONTINUE;
   
   \+
   \f[THEN]
   \fhas? skiploopprims 0= [IF]
   
   acondbranch(a(next),R:n1 -- R:n2,cmFORTH        aparen_next,
   n2=n1-1;
   ,if (n1) {
   ,:
    r> r> dup 1- >r
    IF @ >r ELSE cell+ >r THEN ;)
   
   acondbranch(a(loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth       aparen_loop,
   n2=n1+1;
   ,if (n2 != nlimit) {
   ,:
    r> r> 1+ r> 2dup =
    IF >r 1- >r cell+ >r
    ELSE >r >r @ >r THEN ;)
   
   acondbranch(a(+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_plus_loop,
   /* !! check this thoroughly */
   /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
   /* dependent upon two's complement arithmetic */
   Cell olddiff = n1-nlimit;
   n2=n1+n;
   ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
       || (olddiff^n)>=0          /* it is a wrap-around effect */) {
   ,:
    r> swap
    r> r> 2dup - >r
    2 pick r@ + r@ xor 0< 0=
    3 pick r> xor 0< 0= or
    IF    >r + >r @ >r
    ELSE  >r >r drop cell+ >r THEN ;)
   
   \+xconds
   
   acondbranch(a(-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth aparen_minus_loop,
   UCell olddiff = n1-nlimit;
   n2=n1-u;
   ,if (olddiff>u) {
   ,)
   
   acondbranch(a(s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth   aparen_symmetric_plus_loop,
   ""The run-time procedure compiled by S+LOOP. It loops until the index
   crosses the boundary between limit and limit-sign(n). I.e. a symmetric
   version of (+LOOP).""
   /* !! check this thoroughly */
   Cell diff = n1-nlimit;
   Cell newdiff = diff+n;
   if (n<0) {
       diff = -diff;
       newdiff = -newdiff;
   }
   n2=n1+n;
   ,if (diff>=0 || newdiff<0) {
   ,)
   
   a(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth  aparen_question_do
   #ifdef NO_IP
       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;
   :
     2dup =
     IF   r> swap rot >r >r
          @ >r
     ELSE r> swap rot >r >r
          cell+ >r
     THEN ;                                \ --> CORE-EXT
   
   \+xconds
   
   a(+do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_plus_do
   #ifdef NO_IP
       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;
   :
    swap 2dup
    r> swap >r swap >r
    >=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   a(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_plus_do
   #ifdef NO_IP
       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;
   :
    swap 2dup
    r> swap >r swap >r
    u>=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   a(-do)  ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth aparen_minus_do
   #ifdef NO_IP
       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;
   :
    swap 2dup
    r> swap >r swap >r
    <=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   a(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth aparen_u_minus_do
   #ifdef NO_IP
       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;
   :
    swap 2dup
    r> swap >r swap >r
    u<=
    IF
        @
    ELSE
        cell+
    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)
   
 \+  \+

Generate output suitable for use with a patch program
Legend:
Removed from v.1.83  
changed lines
  Added in v.1.107
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help