[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.7 and 1.21

version 1.7, Wed May 18 17:29:58 1994 UTC version 1.21, Tue Oct 18 15:51:21 1994 UTC
Line 70 
Line 70 
   
 noop    --              fig  noop    --              fig
 ;  ;
   :
    ;
   
 lit     -- w            fig  lit     -- w            fig
 w = (Cell)*ip++;  w = (Cell)*ip++;
Line 79 
Line 81 
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 NEXT1;  NEXT1;
   
   branch-lp+!#    --      new     branch_lp_plus_store_number
   /* this will probably not be used */
   branch_adjust_lp:
   lp += (int)(ip[1]);
   goto branch;
   
 branch  --              fig  branch  --              fig
 branch:  branch:
 ip = (Xt *)(((int)ip)+(int)*ip);  ip = (Xt *)(((int)ip)+(int)*ip);
   :
    r> dup @ + >r ;
   
 ?branch         f --            f83     question_branch  \ condbranch(forthname,restline,code)
 ""also known as 0branch""  \ this is non-syntactical: code must open a brace that is close by the macro
 if (f==0) {  define(condbranch,
     IF_TOS(TOS = sp[0]);  $1      $2
     goto branch;  $3    goto branch;
     }      }
 else  else
     ip++;      ip++;
   
 (next)  --              cmFORTH paren_next  $1-lp+!#        $2_lp_plus_store_number
 if ((*rp)--) {  $3    goto branch_adjust_lp;
     goto branch;  
 } else {  
     ip++;  
 }  }
   else
       ip+=2;
   
   )
   
   condbranch(?branch,f --         f83     question_branch,
   if (f==0) {
       IF_TOS(TOS = sp[0]);
   )
   
 (loop)  --              fig     paren_loop  condbranch((next),--            cmFORTH paren_next,
   if ((*rp)--) {
   )
   
   condbranch((loop),--            fig     paren_loop,
 int index = *rp+1;  int index = *rp+1;
 int limit = rp[1];  int limit = rp[1];
 if (index != limit) {  if (index != limit) {
     *rp = index;      *rp = index;
     goto branch;  )
 } else {  
     ip++;  
 }  
   
 (+loop)         n --            fig     paren_plus_loop  condbranch((+loop),n --         fig     paren_plus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
 int index = *rp;  int index = *rp;
 int olddiff = index-rp[1];  
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 if ((olddiff^(olddiff+n))<0   /* the limit is crossed */  int olddiff = index-rp[1];
     && (olddiff^n)<0          /* it is not a wrap-around effect */) {  #ifdef undefined
     /* break */  if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     ip++;      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 } else {  #else
     /* continue */  #ifndef MAXINT
   #define MAXINT ((1<<(8*sizeof(Cell)-1))-1)
   #endif
   if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
   #endif
   #ifdef i386
       *rp += n;
   #else
     *rp = index+n;      *rp = index+n;
   #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
     goto branch;  )
 }  
   
 (s+loop)        n --            new     paren_symmetric_plus_loop  condbranch((s+loop),n --                new     paren_symmetric_plus_loop,
 ""The run-time procedure compiled by S+LOOP. It loops until the index  ""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  crosses the boundary between limit and limit-sign(n). I.e. a symmetric
 version of (+LOOP).""  version of (+LOOP).""
 /* !! check this thoroughly */  /* !! check this thoroughly */
 int oldindex = *rp;  int index = *rp;
 int diff = oldindex-rp[1];  int diff = index-rp[1];
 int newdiff = diff+n;  int newdiff = diff+n;
 if (n<0) {  if (n<0) {
     diff = -diff;      diff = -diff;
     newdiff = - newdiff;      newdiff = - newdiff;
 }  }
 if (diff>=0 || newdiff<0) {  if (diff>=0 || newdiff<0) {
     *rp = oldindex+n;  #ifdef i386
       *rp += n;
   #else
       *rp = index + n;
   #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
     goto branch;  )
 } else {  
     ip++;  
 }  
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
   :
    r> rdrop rdrop >r ;
   
 (for)   ncount --               cmFORTH         paren_for  (for)   ncount --               cmFORTH         paren_for
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 *--rp = 0;  *--rp = 0;
 *--rp = ncount;  *--rp = ncount;
   :
    r> swap 0 >r >r >r ;
   
 (do)    nlimit nstart --                fig             paren_do  (do)    nlimit nstart --                fig             paren_do
 /* or do it in high-level? 0.09/0.23% */  /* or do it in high-level? 0.09/0.23% */
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 :  :
  swap >r >r ;   r> -rot swap >r >r >r ;
   
 (?do)   nlimit nstart --        core-ext        paren_question_do  (?do)   nlimit nstart --        core-ext        paren_question_do
 *--rp = nlimit;  *--rp = nlimit;
Line 180 
Line 208 
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 emit    c --            fig  (emit)  c --            fig     paren_emit
 putchar(c);  putchar(c);
 emitcounter++;  emitcounter++;
   
 key     -- n            fig  (type)  c_addr n --     fig     paren_type
   fwrite(c_addr,sizeof(Char),n,stdout);
   emitcounter += n;
   
   (key)   -- n            fig     paren_key
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  /* !! noecho */
 n = key();  n = key();
Line 195 
Line 227 
   
 cr      --              fig  cr      --              fig
 puts("");  puts("");
   :
    $0A emit ;
   
 move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
 /* make an Ifdef for bsd and others? */  /* make an Ifdef for bsd and others? */
   :
    >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
   
 cmove   c_from c_to u --        string  cmove   c_from c_to u --        string
 while (u-- > 0)  while (u-- > 0)
   *c_to++ = *c_from++;    *c_to++ = *c_from++;
   :
    bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
 cmove>  c_from c_to u --        string  c_move_up  cmove>  c_from c_to u --        string  c_move_up
 while (u-- > 0)  while (u-- > 0)
   c_to[u] = c_from[u];    c_to[u] = c_from[u];
   :
    dup 0= IF  drop 2drop exit  THEN
    rot over + -rot bounds swap 1-
    DO  1- dup c@ I c!  -1 +LOOP  drop ;
   
 fill    c_addr u c --   core  fill    c_addr u c --   core
 memset(c_addr,c,u);  memset(c_addr,c,u);
   :
    -rot bounds
    ?DO  dup I c!  LOOP  drop ;
   
 compare         c_addr1 u1 c_addr2 u2 -- n      string  compare         c_addr1 u1 c_addr2 u2 -- n      string
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
Line 219 
Line 264 
   n = -1;    n = -1;
 else if (n>0)  else if (n>0)
   n = 1;    n = 1;
   :
    rot 2dup - >r min swap -text dup
    IF    rdrop
    ELSE  drop r@ 0>
          IF    rdrop -1
          ELSE  r> 1 and
          THEN
    THEN ;
   
 -text           c_addr1 u c_addr2 -- n  new     dash_text  -text           c_addr1 u c_addr2 -- n  new     dash_text
 n = memcmp(c_addr1, c_addr2, u);  n = memcmp(c_addr1, c_addr2, u);
Line 226 
Line 279 
   n = -1;    n = -1;
 else if (n>0)  else if (n>0)
   n = 1;    n = 1;
   :
    swap bounds
    ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
    ELSE  c@ I c@ - unloop  THEN  -text-flag ;
   : -text-flag ( n -- -1/0/1 )
    dup 0< IF  drop -1  ELSE  0>  IF  1  ELSE  0  THEN  THEN  ;
   
 capscomp        c_addr1 u c_addr2 -- n  new  capscomp        c_addr1 u c_addr2 -- n  new
 Char c1, c2;  Char c1, c2;
Line 244 
Line 303 
     break;      break;
   }    }
 }  }
   :
    swap bounds
    ?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0
    ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;
   
 -trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       c_addr u1 -- c_addr u2          string  dash_trailing
 u2 = u1;  u2 = u1;
 while (c_addr[u2-1] == ' ')  while (c_addr[u2-1] == ' ')
   u2--;    u2--;
   :
    BEGIN  1- 2dup + c@ bl =  WHILE
           dup  0= UNTIL  ELSE  1+  THEN ;
   
 /string         c_addr1 u1 n -- c_addr2 u2      string  slash_string  /string         c_addr1 u1 n -- c_addr2 u2      string  slash_string
 c_addr2 = c_addr1+n;  c_addr2 = c_addr1+n;
 u2 = u1-n;  u2 = u1-n;
   :
    tuck - >r + r> dup 0< IF  - 0  THEN ;
   
 +       n1 n2 -- n              core,fig        plus  +       n1 n2 -- n              core,fig        plus
 n = n1+n2;  n = n1+n2;
   
 -       n1 n2 -- n              core,fig        minus  -       n1 n2 -- n              core,fig        minus
 n = n1-n2;  n = n1-n2;
   :
    negate + ;
   
 negate  n1 -- n2                core,fig  negate  n1 -- n2                core,fig
 /* use minus as alias */  /* use minus as alias */
 n2 = -n1;  n2 = -n1;
   :
    invert 1+ ;
   
 1+      n1 -- n2                core            one_plus  1+      n1 -- n2                core            one_plus
 n2 = n1+1;  n2 = n1+1;
   :
    1 + ;
   
 1-      n1 -- n2                core            one_minus  1-      n1 -- n2                core            one_minus
 n2 = n1-1;  n2 = n1-1;
   :
    1 - ;
   
 max     n1 n2 -- n      core  max     n1 n2 -- n      core
 if (n1<n2)  if (n1<n2)
Line 276 
Line 352 
 else  else
   n = n1;    n = n1;
 :  :
  2dup < if   2dup < IF swap THEN drop ;
   swap drop  
  else  
   drop  
  endif ;  
   
 min     n1 n2 -- n      core  min     n1 n2 -- n      core
 if (n1<n2)  if (n1<n2)
   n = n1;    n = n1;
 else  else
   n = n2;    n = n2;
   :
    2dup > IF swap THEN drop ;
   
 abs     n1 -- n2        core  abs     n1 -- n2        core
 if (n1<0)  if (n1<0)
   n2 = -n1;    n2 = -n1;
 else  else
   n2 = n1;    n2 = n1;
   :
    dup 0< IF negate THEN ;
   
 *       n1 n2 -- n              core,fig        star  *       n1 n2 -- n              core,fig        star
 n = n1*n2;  n = n1*n2;
   :
    um* drop ;
   
 /       n1 n2 -- n              core,fig        slash  /       n1 n2 -- n              core,fig        slash
 n = n1/n2;  n = n1/n2;
   :
    /mod nip ;
   
 mod     n1 n2 -- n              core  mod     n1 n2 -- n              core
 n = n1%n2;  n = n1%n2;
   :
    /mod drop ;
   
 /mod    n1 n2 -- n3 n4          core            slash_mod  /mod    n1 n2 -- n3 n4          core            slash_mod
 n4 = n1/n2;  n4 = n1/n2;
 n3 = n1%n2; /* !! is this correct? look into C standard! */  n3 = n1%n2; /* !! is this correct? look into C standard! */
   :
    >r s>d r> fm/mod ;
   
 2*      n1 -- n2                core            two_star  2*      n1 -- n2                core            two_star
 n2 = 2*n1;  n2 = 2*n1;
   :
    dup + ;
   
 2/      n1 -- n2                core            two_slash  2/      n1 -- n2                core            two_slash
 /* !! is this still correct? */  /* !! is this still correct? */
Line 335 
Line 421 
   n3++;    n3++;
   n2-=n1;    n2-=n1;
 }  }
   :
    over >r dup >r abs -rot
    dabs rot um/mod
    r> 0< IF       negate       THEN
    r> 0< IF  swap negate swap  THEN ;
   
 m*      n1 n2 -- d              core    m_star  m*      n1 n2 -- d              core    m_star
 d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
   :
    2dup      0< and >r
    2dup swap 0< and >r
    um* r> - r> - ;
   
 um*     u1 u2 -- ud             core    u_m_star  um*     u1 u2 -- ud             core    u_m_star
 /* use u* as alias */  /* use u* as alias */
Line 346 
Line 441 
 um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
 u3 = ud/u1;  u3 = ud/u1;
 u2 = ud%u1;  u2 = ud%u1;
   :
     dup IF  0 (um/mod)  THEN  nip ;
   : (um/mod)  ( ud ud--ud u)
     2dup >r >r  dup 0<
     IF    2drop 0
     ELSE  2dup d+  (um/mod)  2*  THEN
     -rot  r> r> 2over 2over  du<
     IF    2drop rot
     ELSE  dnegate  d+  rot 1+  THEN ;
   
 m+      d1 n -- d2              double          m_plus  m+      d1 n -- d2              double          m_plus
 d2 = d1+n;  d2 = d1+n;
   :
    s>d d+ ;
   
 d+      d1 d2 -- d              double,fig      d_plus  d+      d1 d2 -- d              double,fig      d_plus
 d = d1+d2;  d = d1+d2;
   :
    >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
    r> + >r + r> 0< r> r> + swap - ;
   
 d-      d1 d2 -- d              double          d_minus  d-      d1 d2 -- d              double          d_minus
 d = d1-d2;  d = d1-d2;
   :
    dnegate d+ ;
   
 dnegate d1 -- d2                double  dnegate d1 -- d2                double
 /* use dminus as alias */  /* use dminus as alias */
 d2 = -d1;  d2 = -d1;
   :
    invert swap negate tuck 0= - ;
   
 dmax    d1 d2 -- d      double  dmax    d1 d2 -- d      double
 if (d1<d2)  if (d1<d2)
   d = d2;    d = d2;
 else  else
   d = d1;    d = d1;
   :
    2over 2over d> IF  2swap  THEN 2drop ;
   
 dmin    d1 d2 -- d      double  dmin    d1 d2 -- d      double
 if (d1<d2)  if (d1<d2)
   d = d1;    d = d1;
 else  else
   d = d2;    d = d2;
   :
    2over 2over d< IF  2swap  THEN 2drop ;
   
 dabs    d1 -- d2        double  dabs    d1 -- d2        double
 if (d1<0)  if (d1<0)
   d2 = -d1;    d2 = -d1;
 else  else
   d2 = d1;    d2 = d1;
   :
    dup 0< IF dnegate THEN ;
   
 d2*     d1 -- d2                double          d_two_star  d2*     d1 -- d2                double          d_two_star
 d2 = 2*d1;  d2 = 2*d1;
   :
    2dup d+ ;
   
 d2/     d1 -- d2                double          d_two_slash  d2/     d1 -- d2                double          d_two_slash
 /* !! is this still correct? */  /* !! is this still correct? */
 d2 = d1/2;  d2 = d1>>1;
   :
    dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and
    r> IF  [ 1 8 cells 1- lshift ] Literal + THEN  swap ;
   
 d>s     d -- n                  double          d_to_s  d>s     d -- n                  double          d_to_s
 /* make this an alias for drop? */  /* make this an alias for drop? */
 n = d;  n = d;
   :
    drop ;
   
 and     w1 w2 -- w              core,fig  and     w1 w2 -- w              core,fig
 w = w1&w2;  w = w1&w2;
Line 400 
Line 526 
   
 invert  w1 -- w2                core  invert  w1 -- w2                core
 w2 = ~w1;  w2 = ~w1;
   :
    -1 xor ;
   
 rshift  u1 n -- u2              core  rshift  u1 n -- u2              core
   u2 = u1>>n;    u2 = u1>>n;
Line 439 
Line 567 
   
 within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
   :
    over - >r - r> u< ;
   
 sp@     -- a_addr               fig             spat  sp@     -- a_addr               fig             spat
 a_addr = sp;  a_addr = sp+1;
   
 sp!     a_addr --               fig             spstore  sp!     a_addr --               fig             spstore
 sp = a_addr+1;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without TOS caching */
   
 rp@     -- a_addr               fig             rpat  rp@     -- a_addr               fig             rpat
Line 460 
Line 590 
 fp = f_addr;  fp = f_addr;
   
 ;s      --              core    exit  ;s      --              core    exit
 /* use ;s as alias */  
 ip = (Xt *)(*rp++);  
   
 ?exit   w --            core            question_exit  
 /* use ;s as alias */  
 if(w)  
         ip = (Xt *)(*rp++);          ip = (Xt *)(*rp++);
   
 >r      w --            core,fig        to_r  >r      w --            core,fig        to_r
Line 485 
Line 609 
 i'      -- w            fig             i_tick  i'      -- w            fig             i_tick
 w=rp[1];  w=rp[1];
   
   2>r     w1 w2 --        core-ext        two_to_r
   *--rp = w1;
   *--rp = w2;
   
   2r>     -- w1 w2        core-ext        two_r_from
   w2 = *rp++;
   w1 = *rp++;
   
   2r@     -- w1 w2        core-ext        two_r_fetch
   w2 = rp[0];
   w1 = rp[1];
   
   2rdrop  --              new     two_r_drop
   rp+=2;
   
 over    w1 w2 -- w1 w2 w1               core,fig  over    w1 w2 -- w1 w2 w1               core,fig
   
 drop    w --            core,fig  drop    w --            core,fig
Line 496 
Line 635 
 rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     w1 w2 w3 -- w2 w3 w1    core    rote
   
 -rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote  -rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote
   :
    rot rot ;
   
 nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
   :
    swap drop ;
   
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
   :
    swap over ;
   
 ?dup    w -- w                  core    question_dupe  ?dup    w -- w                  core    question_dupe
 if (w!=0) {  if (w!=0) {
Line 508 
Line 653 
   *--sp = w;    *--sp = w;
 #endif  #endif
 }  }
   :
    dup IF dup THEN ;
   
 pick    u -- w                  core-ext  pick    u -- w                  core-ext
 w = sp[u+1];  w = sp[u+1];
   :
    1+ cells sp@ + @ ;
   
 2drop   w1 w2 --                core    two_drop  2drop   w1 w2 --                core    two_drop
   :
    drop drop ;
   
 2dup    w1 w2 -- w1 w2 w1 w2    core    two_dupe  2dup    w1 w2 -- w1 w2 w1 w2    core    two_dupe
   :
    over over ;
   
 2over   w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2        core    two_over  2over   w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2        core    two_over
   :
    3 pick 3 pick ;
   
 2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap  2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap
   :
    >r -rot r> -rot ;
   
 2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote  2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote
   :
    >r >r 2swap r> r> 2swap ;
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
Line 542 
Line 701 
 2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
 a_addr[0] = w2;  a_addr[0] = w2;
 a_addr[1] = w1;  a_addr[1] = w1;
   :
    tuck ! cell+ ! ;
   
 2@      a_addr -- w1 w2         core    two_fetch  2@      a_addr -- w1 w2         core    two_fetch
 w2 = a_addr[0];  w2 = a_addr[0];
 w1 = a_addr[1];  w1 = a_addr[1];
   :
    dup cell+ @ swap @ ;
   
 d!      d a_addr --             double  d_store  d!      d a_addr --             double  d_store
 /* !! alignment problems on some machines */  /* !! alignment problems on some machines */
Line 556 
Line 719 
   
 cell+   a_addr1 -- a_addr2      core    cell_plus  cell+   a_addr1 -- a_addr2      core    cell_plus
 a_addr2 = a_addr1+1;  a_addr2 = a_addr1+1;
   :
    [ cell ] Literal + ;
   
 cells   n1 -- n2                core  cells   n1 -- n2                core
 n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
   :
    [ cell ]
    [ 2/ dup ] [IF] 2* [THEN]
    [ 2/ dup ] [IF] 2* [THEN]
    [ 2/ dup ] [IF] 2* [THEN]
    [ 2/ dup ] [IF] 2* [THEN]
    [ drop ] ;
   
 char+   c_addr1 -- c_addr2      core    care_plus  char+   c_addr1 -- c_addr2      core    care_plus
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
   :
    1+ ;
   
 chars   n1 -- n2                core    cares  chars   n1 -- n2                core    cares
 n2 = n1 * sizeof(Char);  n2 = n1 * sizeof(Char);
   :
    ;
   
 count   c_addr1 -- c_addr2 u    core  count   c_addr1 -- c_addr2 u    core
 u = *c_addr1;  u = *c_addr1;
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
   :
    dup 1+ swap c@ ;
   
 (bye)   n --    toolkit-ext     paren_bye  (bye)   n --    toolkit-ext     paren_bye
 deprep_terminal();  return (Label *)n;
 exit(n);  
   
 system  c_addr u -- n   own  system  c_addr u -- n   own
 char pname[u+1];  n=system(cstr(c_addr,u,1));
 cstr(pname,c_addr,u);  
 n=system(pname);  getenv  c_addr1 u1 -- c_addr2 u2        new
   c_addr2 = getenv(cstr(c_addr1,u1,1));
   u2=strlen(c_addr2);
   
 popen   c_addr u n -- wfileid   own  popen   c_addr u n -- wfileid   own
 char pname[u+1];  
 static char* mode[2]={"r","w"};  static char* mode[2]={"r","w"};
 cstr(pname,c_addr,u);  wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
 wfileid=(Cell)popen(pname,mode[n]);  
   
 pclose  wfileid -- wior own  pclose  wfileid -- wior own
 wior=pclose((FILE *)wfileid);  wior=pclose((FILE *)wfileid);
   
 time&date       -- nyear nmonth nday nhour nmin nsec    ansi    time_and_date  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
 struct timeval time1;  struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
 gettimeofday(&time1,&zone1);  gettimeofday(&time1,&zone1);
 ltime=localtime(&time1.tv_sec);  ltime=localtime(&time1.tv_sec);
 nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
 nmonth=ltime->tm_mon;  nmonth=ltime->tm_mon+1;
 nday  =ltime->tm_mday;  nday  =ltime->tm_mday;
 nhour =ltime->tm_hour;  nhour =ltime->tm_hour;
 nmin  =ltime->tm_min;  nmin  =ltime->tm_min;
 nsec  =ltime->tm_sec;  nsec  =ltime->tm_sec;
   
 ms      n --    ansi  ms      n --    facility-ext
 struct timeval timeout;  struct timeval timeout;
 timeout.tv_sec=n/1000;  timeout.tv_sec=n/1000;
 timeout.tv_usec=1000*(n%1000);  timeout.tv_usec=1000*(n%1000);
Line 621 
Line 798 
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = f83name1->next)
   if (F83NAME_COUNT(f83name1)==u && !F83NAME_SMUDGE(f83name1) &&    if (F83NAME_COUNT(f83name1)==u &&
       strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
 f83name2=f83name1;  f83name2=f83name1;
   :
    BEGIN  dup  WHILE
           >r dup r@ cell+ c@ $1F and =
           IF  2dup r@ cell+ char+ capscomp  0=
               IF  2drop r>  EXIT  THEN  THEN
           r> @
    REPEAT  nip nip ;
   
   (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
   F83Name *f83name1;
   f83name2=NULL;
   while(a_addr != NULL)
   {
      f83name1=(F83Name *)(a_addr[1]);
      a_addr=(Cell *)(a_addr[0]);
      if (F83NAME_COUNT(f83name1)==u &&
          strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
        {
           f83name2=f83name1;
           break;
        }
   }
   :
    BEGIN  dup  WHILE
           2@ >r >r dup r@ cell+ c@ $1F and =
           IF  2dup r@ cell+ char+ capscomp 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
   (hashkey)       c_addr u1 -- u2         new     paren_hashkey
   u2=0;
   while(u1--)
      u2+=(int)toupper(*c_addr++);
   :
    0 -rot bounds ?DO  I c@ toupper +  LOOP ;
   
   (hashkey1)      c_addr u ubits -- ukey          new     paren_hashkey1
   ""ukey is the hash key for the string c_addr u fitting in ubits bits""
   /* this hash function rotates the key at every step by rot bits within
      ubits bits and xors it with the character. This function does ok in
      the chi-sqare-test.  Rot should be <=7 (preferably <=5) for
      ASCII strings (larger if ubits is large), and should share no
      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];
   Char *cp = c_addr;
   for (ukey=0; cp<c_addr+u; cp++)
       ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
                ^ toupper(*cp))
               & ((1<<ubits)-1));
   :
    dup rot-values + c@ over 1 swap lshift 1- >r
    tuck - 2swap r> 0 2swap bounds
    ?DO  dup 4 pick lshift swap 3 pick rshift or
         I c@ toupper xor
         over and  LOOP
    nip nip nip ;
   Create rot-values
     5 c, 0 c, 1 c, 2 c, 3 c,  4 c, 5 c, 5 c, 5 c, 5 c,
     3 c, 5 c, 5 c, 5 c, 5 c,  7 c, 5 c, 5 c, 5 c, 5 c,
     7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
     7 c, 5 c, 5 c,
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        new     paren_parse_white  (parse-white)   c_addr1 u1 -- c_addr2 u2        new     paren_parse_white
 /* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
Line 640 
Line 880 
   c_addr2 = c_addr1;    c_addr2 = c_addr1;
   u2 = 0;    u2 = 0;
 }  }
   :
    BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string
    REPEAT  THEN  2dup
    BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string
    REPEAT  THEN  nip - ;
   
 close-file      wfileid -- wior file    close_file  close-file      wfileid -- wior file    close_file
 wior = FILEIO(fclose((FILE *)wfileid)==EOF);  wior = FILEIO(fclose((FILE *)wfileid)==EOF);
   
 open-file       c_addr u ntype -- w2 wior       file    open_file  open-file       c_addr u ntype -- w2 wior       file    open_file
 char fname[u+1];  w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
 cstr(fname, c_addr, u);  
 w2 = (Cell)fopen(fname, fileattr[ntype]);  
 wior =  FILEEXIST(w2 == NULL);  wior =  FILEEXIST(w2 == NULL);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
 int     fd;  int     fd;
 char fname[u+1];  fd = creat(cstr(c_addr, u, 1), 0644);
 cstr(fname, c_addr, u);  
 fd = creat(fname, 0666);  
 if (fd > -1) {  if (fd > -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
   assert(w2 != NULL);    assert(w2 != NULL);
Line 666 
Line 907 
 }  }
   
 delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file
 char fname[u+1];  wior = FILEEXIST(unlink(cstr(c_addr, u, 1)));
 cstr(fname, c_addr, u);  
 wior = FILEEXIST(unlink(fname));  
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
 char fname1[u1+1];  char *s1=cstr(c_addr2, u2, 1);
 char fname2[u2+1];  wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));
 cstr(fname1, c_addr1, u1);  
 cstr(fname2, c_addr2, u2);  
 wior = FILEEXIST(rename(fname1, fname2));  
   
 file-position   wfileid -- ud wior      file    file_position  file-position   wfileid -- ud wior      file    file_position
 /* !! use tell and lseek? */  /* !! use tell and lseek? */
Line 700 
Line 936 
 /* !! who performs clearerr((FILE *)wfileid); ? */  /* !! who performs 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
 wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid);  /*
 flag=FLAG(!feof((FILE *)wfileid) && wior);  Cell c;
 wior=FILEIO(ferror((FILE *)wfileid)) & flag;  flag=-1;
 u2=(flag & strlen(c_addr));  for(u2=0; u2<u1; u2++)
   {
      *c_addr++ = (Char)(c = getc((FILE *)wfileid));
      if(c=='\n') break;
      if(c==EOF)
        {
           flag=FLAG(u2!=0);
           break;
        }
   }
   wior=FILEIO(ferror((FILE *)wfileid));
   */
   if ((flag=FLAG(!feof((FILE *)wfileid) &&
                  fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {
     wior=FILEIO(ferror((FILE *)wfileid));
     u2 = strlen(c_addr);
 u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));  u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
   }
   else {
     wior=0;
     u2=0;
   }
   
 write-file      c_addr u1 wfileid -- wior       file    write_file  write-file      c_addr u1 wfileid -- wior       file    write_file
 /* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
Line 817 
Line 1073 
 represent               r c_addr u -- n f1 f2   float  represent               r c_addr u -- n f1 f2   float
 char *sig;  char *sig;
 int flag;  int flag;
 sig=ecvt(r, u, &n, &flag);  int decpt;
   sig=ecvt(r, u, &decpt, &flag);
   n=decpt;
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);  f2=FLAG(isdigit(sig[0])!=0);
 memmove(c_addr,sig,u);  memmove(c_addr,sig,u);
Line 825 
Line 1083 
 >float  c_addr u -- flag        float   to_float  >float  c_addr u -- flag        float   to_float
 /* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
 Float r;  Float r;
 char number[u+1];  char *number=cstr(c_addr, u, 1);
 char *endconv;  char *endconv;
 cstr(number, c_addr, u);  
 r=strtod(number,&endconv);  r=strtod(number,&endconv);
 if(flag=FLAG(!(int)*endconv))  if((flag=FLAG(!(int)*endconv)))
 {  {
         IF_FTOS(fp[0] = FTOS);          IF_FTOS(fp[0] = FTOS);
         fp += -1;          fp += -1;
Line 839 
Line 1096 
 {  {
         *endconv='E';          *endconv='E';
         r=strtod(number,&endconv);          r=strtod(number,&endconv);
         if(flag=FLAG(!(int)*endconv))          if((flag=FLAG(!(int)*endconv)))
         {          {
                 IF_FTOS(fp[0] = FTOS);                  IF_FTOS(fp[0] = FTOS);
                 fp += -1;                  fp += -1;
Line 870 
Line 1127 
   
 fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
 r2 =  r2 =
 #ifdef expm1  #ifdef HAS_EXPM1
         expm1(r1);          expm1(r1);
 #else  #else
         exp(r1)-1;          exp(r1)-1;
Line 881 
Line 1138 
   
 flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
 r2 =  r2 =
 #ifdef log1p  #ifdef HAS_LOG1P
         log1p(r1);          log1p(r1);
 #else  #else
         log(r1+1);          log(r1+1);
Line 922 
Line 1179 
 behaviour is uundefined""  behaviour is uundefined""
 /* !! there is currently no way to determine whether a word is  /* !! there is currently no way to determine whether a word is
 defining-word-defined */  defining-word-defined */
 a_addr = DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
   
 code-address!           n xt -- new     code_address_store  code-address!           n xt -- new     code_address_store
 ""Creates a code field with code address c_addr at xt""  ""Creates a code field with code address c_addr at xt""
Line 953 
Line 1210 
 @local#         -- w    new     fetch_local_number  @local#         -- w    new     fetch_local_number
 w = *(Cell *)(lp+(int)(*ip++));  w = *(Cell *)(lp+(int)(*ip++));
   
   @local0 -- w    new     fetch_local_zero
   w = *(Cell *)(lp+0*sizeof(Cell));
   
   @local1 -- w    new     fetch_local_four
   w = *(Cell *)(lp+1*sizeof(Cell));
   
   @local2 -- w    new     fetch_local_eight
   w = *(Cell *)(lp+2*sizeof(Cell));
   
   @local3 -- w    new     fetch_local_twelve
   w = *(Cell *)(lp+3*sizeof(Cell));
   
 f@local#        -- r    new     f_fetch_local_number  f@local#        -- r    new     f_fetch_local_number
 r = *(Float *)(lp+(int)(*ip++));  r = *(Float *)(lp+(int)(*ip++));
   
   f@local0        -- r    new     f_fetch_local_zero
   r = *(Float *)(lp+0*sizeof(Float));
   
   f@local1        -- r    new     f_fetch_local_eight
   r = *(Float *)(lp+1*sizeof(Float));
   
 laddr#          -- c_addr       new     laddr_number  laddr#          -- c_addr       new     laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(int)(*ip++));  c_addr = (Char *)(lp+(int)(*ip++));
Line 966 
Line 1241 
 stack""  stack""
 lp += (int)(*ip++);  lp += (int)(*ip++);
   
   lp-     --      new     minus_four_lp_plus_store
   lp += -sizeof(Cell);
   
   lp+     --      new     eight_lp_plus_store
   lp += sizeof(Float);
   
   lp+2    --      new     sixteen_lp_plus_store
   lp += 2*sizeof(Float);
   
 lp!     c_addr --       new     lp_store  lp!     c_addr --       new     lp_store
 lp = (Address)c_addr;  lp = (Address)c_addr;
   
Line 978 
Line 1262 
 *(Float *)lp = r;  *(Float *)lp = r;
   
 up!     a_addr --       new     up_store  up!     a_addr --       new     up_store
 up=a_addr;  up0=up=(char *)a_addr;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help