[BACK]Return to prim CVS log [TXT] [DIR] Up to [gforth] / gforth

Diff for /gforth/prim between versions 1.97 and 1.101

version 1.97, 2002/08/28 21:46:58 version 1.101, 2002/10/27 09:57:11
Line 1708  r = d; Line 1708  r = d;
 #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 1803  floor ( r1 -- r2 ) float Line 1799  floor ( r1 -- r2 ) float
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround  ( r1 -- r2 )    float   f_round  (fround)        ( r1 -- r2 )    gforth  paren_f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.  Primitive variant (unused)""
   /* !! eliminate this as primitive? */
 /* !! unclear wording */  /* !! unclear wording */
 #ifdef HAVE_RINT  #ifdef HAVE_RINT
 r2 = rint(r1);  r2 = rint(r1);
Line 2427  a_addr = (Cell *)(up+u); Line 2424  a_addr = (Cell *)(up+u);
 compile-prim ( xt1 -- xt2 )     new     compile_prim  compile-prim ( xt1 -- xt2 )     new     compile_prim
 xt2 = (Xt)compile_prim((Label)xt1);  xt2 = (Xt)compile_prim((Label)xt1);
   
 lit@ / lit_fetch = lit @  \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
 lit-perform     ( #a_addr -- )  new     lit_perform  lit-perform     ( #a_addr -- )  new     lit_perform
 ip=IP;  ip=IP;
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
   
 lit+ / lit_plus = lit +  \ 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  does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
 a_pfa = PFA(a_cfa);  a_pfa = PFA(a_cfa);
Line 2449  IF_spTOS(spTOS = sp[0]); Line 2452  IF_spTOS(spTOS = sp[0]);
 #endif  #endif
 SET_IP(DOES_CODE1(a_cfa));  SET_IP(DOES_CODE1(a_cfa));
   
   abranch-lp+!# ( #a_target #nlocals -- ) gforth  abranch_lp_plus_store_number
   /* this will probably not be used */
   lp += nlocals;
   SET_IP((Xt *)a_target);
   
   \+
   
   abranch ( #a_target -- )        gforth
   SET_IP((Xt *)a_target);
   :
    r> @ >r ;
   
   \ acondbranch(forthname,stackeffect,restline,code,forthcode)
   \ this is non-syntactical: code must open a brace that is closed by the macro
   define(acondbranch,
   $1 ( `#'a_target $2 ) $3
   $4      SET_IP((Xt *)a_target);
   INST_TAIL;
   }
   SUPER_CONTINUE;
   $5
   
   \+glocals
   
   $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
   $4    lp += nlocals;
   SET_IP((Xt *)a_target);
   INST_TAIL;
   }
   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]);
     SET_IP((Xt *)a_target);
     INST_TAIL;
   }
   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--;
     SET_IP((Xt *)a_target);
     NEXT;
   }
   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
   if (nstart == nlimit) {
       SET_IP((Xt *)a_target);
       INST_TAIL;
   }
   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
   if (nstart >= nlimit) {
       SET_IP((Xt *)a_target);
       INST_TAIL;
   }
   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
   if (ustart >= ulimit) {
       SET_IP((Xt *)a_target);
       INST_TAIL;
   }
   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
   if (nstart <= nlimit) {
       SET_IP((Xt *)a_target);
       INST_TAIL;
   }
   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
   if (ustart <= ulimit) {
       SET_IP((Xt *)a_target);
       INST_TAIL;
   }
   SUPER_CONTINUE;
   :
    swap 2dup
    r> swap >r swap >r
    u<=
    IF
        @
    ELSE
        cell+
    THEN  >r ;
   
   \+
   
 include(peeprules.vmg)  include(peeprules.vmg)
   
 \+  \+
Removed from v.1.97  
changed lines
  Added in v.1.101

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