[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.44 and 1.58

version 1.44, Thu Oct 26 22:48:41 1995 UTC version 1.58, Wed Aug 21 14:58:43 1996 UTC
Line 1 
Line 1 
 \ Copyright 1992 by the ANSI figForth Development Group  \ Gforth primitives
 \  
   \ Copyright (C) 1995,1996 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
 \ don't collide with m4's (e.g. by undefining them).  \ don't collide with m4's (e.g. by undefining them).
 \  \
 \  \
 \  \
 \ This file contains instructions in the following format:  \ This file contains primitive specifications in the following format:
 \  \
 \ forth name    stack effect    category        [pronunciation]  \ forth name    stack effect    category        [pronunciation]
 \ [""glossary entry""]  \ [""glossary entry""]
Line 13 
Line 32 
 \ [:  \ [:
 \ Forth code]  \ Forth code]
 \  \
 \ The pronunciation is also used for forming C names.  \ prims2x is pedantic about tabs vs. blanks. The fields of the first
   \ line of a primitive are separated by tabs, the stack items in a
   \ stack effect by blanks.
 \  \
   \ Both pronounciation and stack items (in the stack effect) must
   \ conform to the C name syntax or the C compiler will complain.
 \  \
 \  \
 \ These informations are automatically translated into C-code for the  \ These specifications are automatically translated into C-code for the
 \ interpreter and into some other files. I hope that your C compiler has  \ interpreter and into some other files. I hope that your C compiler has
 \ decent optimization, otherwise the automatically generated code will  \ decent optimization, otherwise the automatically generated code will
 \ be somewhat slow. The Forth version of the code is included for manual  \ be somewhat slow. The Forth version of the code is included for manual
Line 94 
Line 117 
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 EXEC(xt);  EXEC(xt);
   
   perform         a_addr --       gforth
   ""equivalent to @code{@ execute}""
   /* and pfe */
   ip=IP;
   IF_TOS(TOS = sp[0]);
   EXEC(*(Xt *)a_addr);
   :
    @ execute ;
   
 branch-lp+!#    --      gforth  branch_lp_plus_store_number  branch-lp+!#    --      gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  branch_adjust_lp:
Line 131 
Line 163 
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  )
   
   \ we don't need an lp_plus_store version of the ?dup-stuff, because it
   \ is only used in if's (yet)
   
   ?dup-?branch    f -- f  new     question_dupe_question_branch
   ""The run-time procedure compiled by @code{?DUP-IF}.""
   if (f==0) {
     sp++;
     IF_TOS(TOS = sp[0]);
     ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
     NEXT_P0;
     NEXT;
   }
   else
     INC_IP(1);
   
   ?dup-0=-?branch f --    new     question_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--;
     ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
     NEXT_P0;
     NEXT;
   }
   else
     INC_IP(1);
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
 )  )
Line 168 
Line 230 
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
 Cell index = *rp;  Cell index = *rp;
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  
 /* dependent upon two's complement arithmetic */  
 UCell olddiff = index-rp[1];  UCell olddiff = index-rp[1];
 if (olddiff>u) {  if (olddiff>u) {
 #ifdef i386  #ifdef i386
Line 283 
Line 343 
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 (emit)  c --            gforth  paren_emit  
 putchar(c);  
 emitcounter++;  
   
 (type)  c_addr n --     gforth  paren_type  
 fwrite(c_addr,sizeof(Char),n,stdout);  
 emitcounter += n;  
   
 (key)   -- n            gforth  paren_key  (key)   -- n            gforth  paren_key
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  /* !! noecho */
Line 300 
Line 352 
 fflush(stdout);  fflush(stdout);
 n = key_query;  n = key_query;
   
 cr      --              core  form    -- urows ucols  gforth
 puts("");  ""The number of lines and columns in the terminal. These numbers may change
 :  with the window size.""
  $0A emit ;  /* we could block SIGWINCH here to get a consistent size, but I don't
    think this is necessary or always beneficial */
   urows=rows;
   ucols=cols;
   
 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);
Line 367 
Line 422 
  dup 0< IF  drop -1  ELSE  0>  IF  1  ELSE  0  THEN  THEN  ;   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;  n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
 for (;; u--, c_addr1++, c_addr2++) {  if (n<0)
   if (u == 0) {  
     n = 0;  
     break;  
   }  
   c1 = toupper(*c_addr1);  
   c2 = toupper(*c_addr2);  
   if (c1 != c2) {  
     if (c1 < c2)  
       n = -1;        n = -1;
     else  else if (n>0)
       n = 1;        n = 1;
     break;  
   }  
 }  
 :  :
  swap bounds   swap bounds
  ?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0   ?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0
Line 405 
Line 449 
 +       n1 n2 -- n              core    plus  +       n1 n2 -- n              core    plus
 n = n1+n2;  n = n1+n2;
   
   \ PFE has it differently, so let's better not define it
   \ under+        n1 n2 n3 -- n n2        gforth  under_plus
   \ ""add @var{n3} to @var{n1} (giving @var{n})""
   \ /* and pfe */
   \ n = n1+n3;
   \ :
   \  rot + swap ;
   
 -       n1 n2 -- n              core    minus  -       n1 n2 -- n              core    minus
 n = n1-n2;  n = n1-n2;
 :  :
Line 482 
Line 534 
   
 fm/mod  d1 n1 -- n2 n3          core            f_m_slash_mod  fm/mod  d1 n1 -- n2 n3          core            f_m_slash_mod
 ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""  ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
   #ifdef BUGGY_LONG_LONG
   DCell r = fmdiv(d1,n1);
   n2=r.hi;
   n3=r.lo;
   #else
 /* assumes that the processor uses either floored or symmetric division */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
Line 490 
Line 547 
   n3--;    n3--;
   n2+=n1;    n2+=n1;
 }  }
   #endif
   :
    dup >r dup 0< IF  negate >r dnegate r>  THEN
    over       0< IF  tuck + swap  THEN
    um/mod
    r> 0< IF  swap negate swap  THEN ;
   
 sm/rem  d1 n1 -- n2 n3          core            s_m_slash_rem  sm/rem  d1 n1 -- n2 n3          core            s_m_slash_rem
 ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""  ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0""
   #ifdef BUGGY_LONG_LONG
   DCell r = smdiv(d1,n1);
   n2=r.hi;
   n3=r.lo;
   #else
 /* assumes that the processor uses either floored or symmetric division */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  n3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
Line 501 
Line 569 
   n3++;    n3++;
   n2-=n1;    n2-=n1;
 }  }
   #endif
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
  dabs rot um/mod   dabs rot um/mod
  r> 0< IF       negate       THEN   r> r@ xor 0< IF       negate       THEN
  r> 0< IF  swap negate swap  THEN ;   r> 0< IF  swap negate swap  THEN ;
   
 m*      n1 n2 -- d              core    m_star  m*      n1 n2 -- d              core    m_star
   #ifdef BUGGY_LONG_LONG
   d = mmul(n1,n2);
   #else
 d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
   #endif
 :  :
  2dup      0< and >r   2dup      0< and >r
  2dup swap 0< and >r   2dup swap 0< and >r
Line 516 
Line 589 
   
 um*     u1 u2 -- ud             core    u_m_star  um*     u1 u2 -- ud             core    u_m_star
 /* use u* as alias */  /* use u* as alias */
   #ifdef BUGGY_LONG_LONG
   ud = ummul(u1,u2);
   #else
 ud = (UDCell)u1 * (UDCell)u2;  ud = (UDCell)u1 * (UDCell)u2;
   #endif
   
 um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
   #ifdef BUGGY_LONG_LONG
   UDCell r = umdiv(ud,u1);
   u2=r.hi;
   u3=r.lo;
   #else
 u3 = ud/u1;  u3 = ud/u1;
 u2 = ud%u1;  u2 = ud%u1;
   #endif
 :  :
   dup IF  0 (um/mod)  THEN  nip ;    dup IF  0 (um/mod)  THEN  nip ;
 : (um/mod)  ( ud ud--ud u)  : (um/mod)  ( ud ud--ud u)
Line 532 
Line 615 
   ELSE  dnegate  d+  rot 1+  THEN ;    ELSE  dnegate  d+  rot 1+  THEN ;
   
 m+      d1 n -- d2              double          m_plus  m+      d1 n -- d2              double          m_plus
   #ifdef BUGGY_LONG_LONG
   d2.lo = d1.lo+n;
   d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);
   #else
 d2 = d1+n;  d2 = d1+n;
   #endif
 :  :
  s>d d+ ;   s>d d+ ;
   
 d+      d1 d2 -- d              double  d_plus  d+      d1 d2 -- d              double  d_plus
   #ifdef BUGGY_LONG_LONG
   d.lo = d1.lo+d2.lo;
   d.hi = d1.hi + d2.hi + (d.lo<d1.lo);
   #else
 d = d1+d2;  d = d1+d2;
   #endif
 :  :
  >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/   rot + >r tuck + swap over u> r> swap - ;
  r> + >r + r> 0< r> r> + swap - ;  
   
 d-      d1 d2 -- d              double          d_minus  d-      d1 d2 -- d              double          d_minus
   #ifdef BUGGY_LONG_LONG
   d.lo = d1.lo - d2.lo;
   d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);
   #else
 d = d1-d2;  d = d1-d2;
   #endif
 :  :
  dnegate d+ ;   dnegate d+ ;
   
 dnegate d1 -- d2                double  dnegate d1 -- d2                double
 /* use dminus as alias */  /* use dminus as alias */
   #ifdef BUGGY_LONG_LONG
   d2 = dnegate(d1);
   #else
 d2 = -d1;  d2 = -d1;
   #endif
 :  :
  invert swap negate tuck 0= - ;   invert swap negate tuck 0= - ;
   
 dmax    d1 d2 -- d      double  
 if (d1<d2)  
   d = d2;  
 else  
   d = d1;  
 :  
  2over 2over d> IF  2swap  THEN 2drop ;  
   
 dmin    d1 d2 -- d      double  
 if (d1<d2)  
   d = d1;  
 else  
   d = d2;  
 :  
  2over 2over d< IF  2swap  THEN 2drop ;  
   
 dabs    d1 -- d2        double  
 if (d1<0)  
   d2 = -d1;  
 else  
   d2 = d1;  
 :  
  dup 0< IF dnegate THEN ;  
   
 d2*     d1 -- d2                double          d_two_star  d2*     d1 -- d2                double          d_two_star
   #ifdef BUGGY_LONG_LONG
   d2.lo = d1.lo<<1;
   d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));
   #else
 d2 = 2*d1;  d2 = 2*d1;
   #endif
 :  :
  2dup d+ ;   2dup d+ ;
   
 d2/     d1 -- d2                double          d_two_slash  d2/     d1 -- d2                double          d_two_slash
 /* !! is this still correct? */  #ifdef BUGGY_LONG_LONG
   d2.hi = d1.hi>>1;
   d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));
   #else
 d2 = d1>>1;  d2 = d1>>1;
   #endif
 :  :
  dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and   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 ;   r> IF  [ 1 8 cells 1- lshift ] Literal + THEN  swap ;
   
 d>s     d -- n                  double          d_to_s  
 /* make this an alias for drop? */  
 n = d;  
 :  
  drop ;  
   
 and     w1 w2 -- w              core  and     w1 w2 -- w              core
 w = w1&w2;  w = w1&w2;
   
Line 621 
Line 701 
 f = FLAG($4==$5);  f = FLAG($4==$5);
   
 $1<>    $2 -- f         $7      $3different  $1<>    $2 -- f         $7      $3different
 /* use != as alias ? */  
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
   
 $1<     $2 -- f         $8      $3less  $1<     $2 -- f         $8      $3less
Line 641 
Line 720 
 comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)  comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
 comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)  comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
 comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)  comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
 comparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)  
 comparisons(d0, d, d_zero_, d, 0, double, gforth, double, gforth)  \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 comparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)  define(dcomparisons,
   $1=     $2 -- f         $6      $3equals
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
   #else
   f = FLAG($4==$5);
   #endif
   
   $1<>    $2 -- f         $7      $3different
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
   #else
   f = FLAG($4!=$5);
   #endif
   
   $1<     $2 -- f         $8      $3less
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
   #else
   f = FLAG($4<$5);
   #endif
   
   $1>     $2 -- f         $9      $3greater
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
   #else
   f = FLAG($4>$5);
   #endif
   
   $1<=    $2 -- f         gforth  $3less_or_equal
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
   #else
   f = FLAG($4<=$5);
   #endif
   
   $1>=    $2 -- f         gforth  $3greater_or_equal
   #ifdef BUGGY_LONG_LONG
   f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
   #else
   f = FLAG($4>=$5);
   #endif
   
   )
   
   dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
   dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
   dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
   
 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);
Line 799 
Line 925 
 :  :
  dup cell+ @ swap @ ;   dup cell+ @ swap @ ;
   
 d!      d a_addr --             double  d_store  
 /* !! alignment problems on some machines */  
 *(DCell *)a_addr = d;  
   
 d@      a_addr -- d             double  d_fetch  
 d = *(DCell *)a_addr;  
   
 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;
 :  :
Line 840 
Line 959 
 (bye)   n --    gforth  paren_bye  (bye)   n --    gforth  paren_bye
 return (Label *)n;  return (Label *)n;
   
 system  c_addr u -- n   gforth  (system)        c_addr u -- wretval wior        gforth  peren_system
 n=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  int old_tp=terminal_prepped;
   deprep_terminal();
   wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
   wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
   if (old_tp)
     prep_terminal();
   
 getenv  c_addr1 u1 -- c_addr2 u2        gforth  getenv  c_addr1 u1 -- c_addr2 u2        gforth
 c_addr2 = getenv(cstr(c_addr1,u1,1));  c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 popen   c_addr u n -- wfileid   own  open-pipe       c_addr u ntype -- wfileid wior  gforth  open_pipe
 static char* mode[2]={"r","w"}; /* !! should we use FAM here? */  wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
 wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]); /* ~ expansion of 1st arg? */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 pclose  wfileid -- wior         own  close-pipe      wfileid -- wretval wior         gforth  close_pipe
 wior=pclose((FILE *)wfileid); /* !! what to do with the result */  wretval = pclose((FILE *)wfileid);
   wior = IOR(wretval==-1);
   
 time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
 struct timeval time1;  struct timeval time1;
Line 874 
Line 999 
 (void)select(0,0,0,0,&timeout);  (void)select(0,0,0,0,&timeout);
   
 allocate        u -- a_addr wior        memory  allocate        u -- a_addr wior        memory
 a_addr = (Cell *)malloc(u);  a_addr = (Cell *)malloc(u?u:1);
 wior = IOR(a_addr==NULL);  wior = IOR(a_addr==NULL);
   
 free            a_addr -- wior          memory  free            a_addr -- wior          memory
Line 885 
Line 1010 
 ""Change the size of the allocated area at @i{a_addr1} to @i{u}  ""Change the size of the allocated area at @i{a_addr1} to @i{u}
 address units, possibly moving the contents to a different  address units, possibly moving the contents to a different
 area. @i{a_addr2} is the address of the resulting area. If  area. @i{a_addr2} is the address of the resulting area. If
 @code{a_addr2} is 0, gforth's (but not the standard) @code{resize}  @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}
 @code{allocate}s @i{u} address units.""  @code{allocate}s @i{u} address units.""
 /* the following check is not necessary on most OSs, but it is needed  /* the following check is not necessary on most OSs, but it is needed
    on SunOS 4.1.2. */     on SunOS 4.1.2. */
Line 898 
Line 1023 
 (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 &&    if (F83NAME_COUNT(f83name1)==u &&
       strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
 f83name2=f83name1;  f83name2=f83name1;
 :  :
Line 917 
Line 1042 
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if (F83NAME_COUNT(f83name1)==u &&     if (F83NAME_COUNT(f83name1)==u &&
        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
      {       {
         f83name2=f83name1;          f83name2=f83name1;
         break;          break;
Line 931 
Line 1056 
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
   (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind
   ""A case-sensitive variant of @code{(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 &&
          memcmp(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+ -text 0=
               IF  2drop r> rdrop  EXIT  THEN  THEN
           rdrop r>
    REPEAT nip nip ;
   
 (hashkey)       c_addr u1 -- u2         gforth  paren_hashkey  (hashkey)       c_addr u1 -- u2         gforth  paren_hashkey
 u2=0;  u2=0;
 while(u1--)  while(u1--)
Line 1012 
Line 1160 
   
 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 = ftell((FILE *)wfileid);  ud = LONG2UD(ftell((FILE *)wfileid));
 wior = IOR(ud==-1);  wior = IOR(UD2LONG(ud)==-1);
   
 reposition-file ud wfileid -- wior      file    reposition_file  reposition-file ud wfileid -- wior      file    reposition_file
 wior = IOR(fseek((FILE *)wfileid, (long)ud, SEEK_SET)==-1);  wior = IOR(fseek((FILE *)wfileid, UD2LONG(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 = buf.st_size;  ud = LONG2UD(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), (Cell)ud)==-1);  wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(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 1072 
Line 1220 
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
 }  }
   
   emit-file       c wfileid -- wior       gforth  emit_file
   wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
   if (wior)
     clearerr((FILE *)wfileid);
   
 flush-file      wfileid -- wior         file-ext        flush_file  flush-file      wfileid -- wior         file-ext        flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
Line 1099 
Line 1252 
   wior=0;    wior=0;
 }  }
   
   stdout  -- wfileid      gforth
   wfileid = (Cell)stdout;
   
   stderr  -- wfileid      gforth
   wfileid = (Cell)stderr;
   
 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)
   
 d>f             d -- r          float   d_to_f  d>f             d -- r          float   d_to_f
   #ifdef BUGGY_LONG_LONG
   extern double ldexp(double x, int exp);
   r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
   #else
 r = d;  r = d;
   #endif
   
 f>d             r -- d          float   f_to_d  f>d             r -- d          float   f_to_d
 /* !! basis 15 is not very specific */  #ifdef BUGGY_LONG_LONG
   d.hi = ldexp(r,-CELL_BITS) - (r<0);
   d.lo = r-ldexp((Float)d.hi,CELL_BITS);
   #else
 d = r;  d = r;
   #endif
   
 f!              r f_addr --     float   f_store  f!              r f_addr --     float   f_store
 *f_addr = r;  *f_addr = r;
Line 1360 
Line 1528 
 n2 = n1*sizeof(DFloat);  n2 = n1*sizeof(DFloat);
   
 aligned         c_addr -- a_addr        core  aligned         c_addr -- a_addr        core
 a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&~sizeof(Cell));  a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
   :
    [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   
 faligned        c_addr -- f_addr        float   f_aligned  faligned        c_addr -- f_addr        float   f_aligned
 f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&~sizeof(Float));  f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
   :
    [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned  sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned
 sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&~sizeof(SFloat));  sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
   :
    [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ;
   
 dfaligned       c_addr -- df_addr       float-ext       d_f_aligned  dfaligned       c_addr -- df_addr       float-ext       d_f_aligned
 df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&~sizeof(DFloat));  df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat)));
   :
    [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
 \ The following words access machine/OS/installation-dependent  \ The following words access machine/OS/installation-dependent
 \   Gforth internals  \   Gforth internals
Line 1386 
Line 1562 
   
 >does-code      xt -- a_addr            gforth  to_does_code  >does-code      xt -- a_addr            gforth  to_does_code
 ""If xt ist the execution token of a defining-word-defined word,  ""If xt ist the execution token of a defining-word-defined word,
 a_addr is the start of the Forth code after the DOES>; Otherwise the  a_addr is the start of the Forth code after the DOES>;
 behaviour is undefined""  Otherwise a_addr is 0.""
 /* !! there is currently no way to determine whether a word is  
 defining-word-defined */  
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
   
 code-address!           c_addr xt --            gforth  code_address_store  code-address!           c_addr xt --            gforth  code_address_store

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help