gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.37 and 1.50

-version 1.37, Fri Apr 14 18:56:58 1995 UTC
+version 1.50, Thu Jan 25 16:45:55 1996 UTC
  Line 1
  Line 1
  Line 1
- \ Copyright 1992 by the ANSI figForth Development Group
+ \ Gforth primitives
- \
+ \ Copyright (C) 1995 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
  \ 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]
  \ [""glossary entry""]
- Line 13
+ Line 32
  Line 13
  Line 32
  \ [:
  \ 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
  \ decent optimization, otherwise the automatically generated code will
  \ be somewhat slow. The Forth version of the code is included for manual
- Line 80
+ Line 103
  Line 80
  Line 103
  undefine(`index')
  undefine(`shift')
- noop    --              fig
+ noop    --              gforth
  ;
  :
   ;
- lit     -- w            fig
+ lit     -- w            gforth
  w = (Cell)NEXT_INST;
  INC_IP(1);
- execute         xt --           core,fig
+ execute         xt --           core
  ip=IP;
- cfa = xt;
  IF_TOS(TOS = sp[0]);
- NEXT1;
+ EXEC(xt);
- branch-lp+!#    --      new     branch_lp_plus_store_number
+ branch-lp+!#    --      gforth  branch_lp_plus_store_number
  /* this will probably not be used */
  branch_adjust_lp:
  lp += (Cell)(IP[1]);
  goto branch;
- branch  --              fig
+ branch  --              gforth
  branch:
  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
  NEXT_P0;
- Line 136
+ Line 158
  Line 136
  Line 158
  if ((*rp)--) {
  )
- condbranch((loop),--            fig     paren_loop,
+ condbranch((loop),--            gforth  paren_loop,
  Cell index = *rp+1;
  Cell limit = rp[1];
  if (index != limit) {
      *rp = index;
  )
- condbranch((+loop),n --         fig     paren_plus_loop,
+ condbranch((+loop),n --         gforth  paren_plus_loop,
  /* !! check this thoroughly */
  Cell index = *rp;
  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
- Line 166
+ Line 188
  Line 166
  Line 188
      IF_TOS(TOS = sp[0]);
  )
- condbranch((s+loop),n --                new     paren_symmetric_plus_loop,
+ condbranch((-loop),u --         gforth  paren_minus_loop,
+ /* !! check this thoroughly */
+ 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];
+ if (olddiff>u) {
+ #ifdef i386
+     *rp -= u;
+ #else
+     *rp = index - u;
+ #endif
+     IF_TOS(TOS = sp[0]);
+ )
+ condbranch((s+loop),n --                gforth  paren_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).""
- Line 199
+ Line 236
  Line 199
  Line 236
  :
   r> swap 0 >r >r >r ;
- (do)    nlimit nstart --                fig             paren_do
+ (do)    nlimit nstart --                gforth          paren_do
  /* or do it in high-level? 0.09/0.23% */
  *--rp = nlimit;
  *--rp = nstart;
  :
   r> -rot swap >r >r >r ;
- (?do)   nlimit nstart --        core-ext        paren_question_do
+ (?do)   nlimit nstart --        gforth  paren_question_do
  *--rp = nlimit;
  *--rp = nstart;
  if (nstart == nlimit) {
- Line 217
+ Line 254
  Line 217
  Line 254
      INC_IP(1);
  }
- i       -- n            core,fig
+ (+do)   nlimit nstart --        gforth  paren_plus_do
+ *--rp = nlimit;
+ *--rp = nstart;
+ if (nstart >= nlimit) {
+     IF_TOS(TOS = sp[0]);
+     goto branch;
+     }
+ else {
+     INC_IP(1);
+ }
+ (u+do)  ulimit ustart --        gforth  paren_u_plus_do
+ *--rp = ulimit;
+ *--rp = ustart;
+ if (ustart >= ulimit) {
+     IF_TOS(TOS = sp[0]);
+     goto branch;
+     }
+ else {
+     INC_IP(1);
+ }
+ (-do)   nlimit nstart --        gforth  paren_minus_do
+ *--rp = nlimit;
+ *--rp = nstart;
+ if (nstart <= nlimit) {
+     IF_TOS(TOS = sp[0]);
+     goto branch;
+     }
+ else {
+     INC_IP(1);
+ }
+ (u-do)  ulimit ustart --        gforth  paren_u_minus_do
+ *--rp = ulimit;
+ *--rp = ustart;
+ if (ustart <= ulimit) {
+     IF_TOS(TOS = sp[0]);
+     goto branch;
+     }
+ else {
+     INC_IP(1);
+ }
+ i       -- n            core
  n = *rp;
  j       -- n            core
- Line 225
+ Line 306
  Line 225
  Line 306
  \ digit is high-level: 0/0%
- (emit)  c --            fig     paren_emit
+ (emit)  c --            gforth  paren_emit
  putchar(c);
+ #if 0
  emitcounter++;
+ #endif
- (type)  c_addr n --     fig     paren_type
+ (type)  c_addr n --     gforth  paren_type
  fwrite(c_addr,sizeof(Char),n,stdout);
+ #if 0
  emitcounter += n;
+ #endif
- (key)   -- n            fig     paren_key
+ (key)   -- n            gforth  paren_key
  fflush(stdout);
  /* !! noecho */
  n = key();
- key?    -- n            fig     key_q
+ key?    -- n            facility        key_q
  fflush(stdout);
  n = key_query;
- cr      --              fig
+ 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
  memmove(c_to,c_from,ucount);
- Line 344
+ Line 432
  Line 344
  Line 432
  :
   tuck - >r + r> dup 0< IF  - 0  THEN ;
- +       n1 n2 -- n              core,fig        plus
+ +       n1 n2 -- n              core    plus
  n = n1+n2;
- -       n1 n2 -- n              core,fig        minus
+ -       n1 n2 -- n              core    minus
  n = n1-n2;
  :
   negate + ;
- negate  n1 -- n2                core,fig
+ negate  n1 -- n2                core
  /* use minus as alias */
  n2 = -n1;
  :
- Line 392
+ Line 480
  Line 392
  Line 480
  :
   dup 0< IF negate THEN ;
- *       n1 n2 -- n              core,fig        star
+ *       n1 n2 -- n              core    star
  n = n1*n2;
  :
   um* drop ;
- /       n1 n2 -- n              core,fig        slash
+ /       n1 n2 -- n              core    slash
  n = n1/n2;
  :
   /mod nip ;
- Line 478
+ Line 566
  Line 478
  Line 566
  :
   s>d d+ ;
- d+      d1 d2 -- d              double,fig      d_plus
+ d+      d1 d2 -- d              double  d_plus
  d = d1+d2;
  :
   >r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
- Line 537
+ Line 625
  Line 537
  Line 625
  :
   drop ;
- and     w1 w2 -- w              core,fig
+ and     w1 w2 -- w              core
  w = w1&w2;
- or      w1 w2 -- w              core,fig
+ or      w1 w2 -- w              core
  w = w1|w2;
- xor     w1 w2 -- w              core,fig
+ xor     w1 w2 -- w              core
  w = w1^w2;
  invert  w1 -- w2                core
- Line 572
+ Line 660
  Line 572
  Line 660
  $1>     $2 -- f         $9      $3greater
  f = FLAG($4>$5);
- $1<=    $2 -- f         new     $3less_or_equal
+ $1<=    $2 -- f         gforth  $3less_or_equal
  f = FLAG($4<=$5);
- $1>=    $2 -- f         new     $3greater_or_equal
+ $1>=    $2 -- f         gforth  $3greater_or_equal
  f = FLAG($4>=$5);
  )
  comparisons(0, n, zero_, n, 0, core, core-ext, core, core-ext)
  comparisons(, n1 n2, , n1, n2, core, core-ext, core, core)
- comparisons(u, u1 u2, u_, u1, u2, new, new, core, core-ext)
+ comparisons(u, u1 u2, u_, u1, u2, gforth, gforth, core, core-ext)
- comparisons(d, d1 d2, d_, d1, d2, double, new, double, new)
+ comparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
- comparisons(d0, d, d_zero_, d, 0, double, new, double, new)
+ comparisons(d0, d, d_zero_, d, 0, double, gforth, double, gforth)
- comparisons(du, ud1 ud2, d_u_, ud1, ud2, new, new, double-ext, new)
+ comparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
  within  u1 u2 u3 -- f           core-ext
  f = FLAG(u1-u2 < u3-u2);
  :
   over - >r - r> u< ;
- sp@     -- a_addr               fig             spat
+ sp@     -- a_addr               gforth          spat
  a_addr = sp+1;
- sp!     a_addr --               fig             spstore
+ sp!     a_addr --               gforth          spstore
  sp = a_addr;
  /* works with and without TOS caching */
- rp@     -- a_addr               fig             rpat
+ rp@     -- a_addr               gforth          rpat
  a_addr = rp;
- rp!     a_addr --               fig             rpstore
+ rp!     a_addr --               gforth          rpstore
  rp = a_addr;
- fp@     -- f_addr       new     fp_fetch
+ fp@     -- f_addr       gforth  fp_fetch
  f_addr = fp;
- fp!     f_addr --       new     fp_store
+ fp!     f_addr --       gforth  fp_store
  fp = f_addr;
- ;s      --              fig     semis
+ ;s      --              gforth  semis
  ip = (Xt *)(*rp++);
  NEXT_P0;
- >r      w --            core,fig        to_r
+ >r      w --            core    to_r
  *--rp = w;
- r>      -- w            core,fig        r_from
+ r>      -- w            core    r_from
  w = *rp++;
- r@      -- w            core,fig        r_fetch
+ r@      -- w            core    r_fetch
  /* use r as alias */
  /* make r@ an alias for i */
  w = *rp;
- rdrop   --              fig
+ rdrop   --              gforth
  rp++;
- i'      -- w            fig             i_tick
+ i'      -- w            gforth          i_tick
  w=rp[1];
 >r     w1 w2 --        core-ext        two_to_r
- Line 644
+ Line 732
  Line 644
  Line 732
  w2 = rp[0];
  w1 = rp[1];
-rdrop  --              new     two_r_drop
+rdrop  --              gforth  two_r_drop
  rp+=2;
- over    w1 w2 -- w1 w2 w1               core,fig
+ over    w1 w2 -- w1 w2 w1               core
- drop    w --            core,fig
+ drop    w --            core
- swap    w1 w2 -- w2 w1          core,fig
+ swap    w1 w2 -- w2 w1          core
- dup     w -- w w                core,fig
+ dup     w -- w w                core
  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    gforth  not_rote
  :
   rot rot ;
- Line 700
+ Line 788
  Line 700
  Line 788
  :
   >r -rot r> -rot ;
-rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote
+rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double-ext      two_rote
  :
   >r >r 2swap r> r> 2swap ;
+nip    w1 w2 w3 w4 -- w3 w4    gforth  two_nip
+ :
+swap 2drop ;
+tuck   w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4        gforth  two_tuck
+ :
+swap 2over ;
  \ toggle is high-level: 0.11/0.42%
- @       a_addr -- w             fig     fetch
+ @       a_addr -- w             core    fetch
  w = *a_addr;
- !       w a_addr --             core,fig        store
+ !       w a_addr --             core    store
  *a_addr = w;
- +!      n a_addr --             core,fig        plus_store
+ +!      n a_addr --             core    plus_store
  *a_addr += n;
- c@      c_addr -- c             fig     cfetch
+ c@      c_addr -- c             core    cfetch
  c = *c_addr;
- c!      c c_addr --             fig     cstore
+ c!      c c_addr --             core    cstore
  *c_addr = c;
 !      w1 w2 a_addr --         core    two_store
- Line 771
+ Line 867
  Line 771
  Line 867
  :
   dup 1+ swap c@ ;
- (bye)   n --    toolkit-ext     paren_bye
+ (bye)   n --    gforth  paren_bye
  return (Label *)n;
- system  c_addr u -- n   own
+ system  c_addr u -- n   gforth
- n=system(cstr(c_addr,u,1));
+ int old_tp=terminal_prepped;
+ deprep_terminal();
+ n=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
+ if (old_tp)
+   prep_terminal();
- getenv  c_addr1 u1 -- c_addr2 u2        new
+ getenv  c_addr1 u1 -- c_addr2 u2        gforth
  c_addr2 = getenv(cstr(c_addr1,u1,1));
- u2=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"};
+ wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
- wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
+ wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
- pclose  wfileid -- wior own
+ close-pipe      wfileid -- wior         gforth  close_pipe
- wior=pclose((FILE *)wfileid); /* !! what to do with the result */
+ wior = IOR(pclose((FILE *)wfileid)==-1);
  time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
  struct timeval time1;
  struct timezone zone1;
  struct tm *ltime;
  gettimeofday(&time1,&zone1);
- ltime=localtime(&time1.tv_sec);
+ ltime=localtime((time_t *)&time1.tv_sec);
  nyear =ltime->tm_year+1900;
  nmonth=ltime->tm_mon+1;
  nday  =ltime->tm_mday;
- Line 808
+ Line 908
  Line 808
  Line 908
  (void)select(0,0,0,0,&timeout);
  allocate        u -- a_addr wior        memory
- a_addr = (Cell *)malloc(u);
+ a_addr = (Cell *)malloc(u?u:1);
  wior = IOR(a_addr==NULL);
  free            a_addr -- wior          memory
- Line 819
+ Line 919
  Line 819
  Line 919
  ""Change the size of the allocated area at @i{a_addr1} to @i{u}
  address units, possibly moving the contents to a different
  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_addr2} is 0, Gforth's (but not the standard) @code{resize}
  @code{allocate}s @i{u} address units.""
  /* the following check is not necessary on most OSs, but it is needed
     on SunOS 4.1.2. */
- Line 865
+ Line 965
  Line 865
  Line 965
          rdrop r>
   REPEAT nip nip ;
- (hashkey)       c_addr u1 -- u2         new     paren_hashkey
+ (hashkey)       c_addr u1 -- u2         gforth  paren_hashkey
  u2=0;
  while(u1--)
     u2+=(Cell)toupper(*c_addr++);
  :
 -rot bounds ?DO  I c@ toupper +  LOOP ;
- (hashkey1)      c_addr u ubits -- ukey          new     paren_hashkey1
+ (hashkey1)      c_addr u ubits -- ukey          gforth  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
- Line 899
+ Line 999
  Line 899
  Line 999
 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
 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        gforth  paren_parse_white
  /* use !isgraph instead of isspace? */
  Char *endp = c_addr1+u1;
  while (c_addr1<endp && isspace(*c_addr1))
- Line 923
+ Line 1023
  Line 923
  Line 1023
  wior = IOR(fclose((FILE *)wfileid)==EOF);
  open-file       c_addr u ntype -- w2 wior       file    open_file
- w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
+ w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
- wior =  IOR(w2 == NULL);
+ wior =  IOR(w2 == 0);
  create-file     c_addr u ntype -- w2 wior       file    create_file
  Cell    fd;
- fd = open(cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
+ fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);
  if (fd != -1) {
    w2 = (Cell)fdopen(fd, fileattr[ntype]);
-   wior = IOR(w2==NULL);
+   wior = IOR(w2 == 0);
  } else {
    w2 = 0;
    wior = IOR(1);
  }
  delete-file     c_addr u -- wior                file    delete_file
- wior = IOR(unlink(cstr(c_addr, u, 1))==-1);
+ wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
- char *s1=cstr(c_addr2, u2, 1);
+ char *s1=tilde_cstr(c_addr2, u2, 1);
- wior = IOR(rename(cstr(c_addr1, u1, 0), s1)==-1);
+ wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
  file-position   wfileid -- ud wior      file    file_position
  /* !! use tell and lseek? */
- Line 1009
+ Line 1109
  Line 1009
  Line 1109
  flush-file      wfileid -- wior         file-ext        flush_file
  wior = IOR(fflush((FILE *) wfileid)==EOF);
- comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
+ file-status     c_addr u -- ntype wior  file-ext        file_status
- comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
+ char *filename=tilde_cstr(c_addr, u, 1);
+ if (access (filename, F_OK) != 0) {
+   ntype=0;
+   wior=IOR(1);
+ }
+ else if (access (filename, R_OK | W_OK) == 0) {
+   ntype=2; /* r/w */
+   wior=0;
+ }
+ else if (access (filename, R_OK) == 0) {
+   ntype=0; /* r/o */
+   wior=0;
+ }
+ else if (access (filename, W_OK) == 0) {
+   ntype=4; /* w/o */
+   wior=0;
+ }
+ else {
+   ntype=1; /* well, we cannot access the file, but better deliver a legal
+             access mode (r/o bin), so we get a decent error later upon open. */
+   wior=0;
+ }
+ comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
+ comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
  d>f             d -- r          float   d_to_f
  r = d;
- Line 1082
+ Line 1206
  Line 1082
  Line 1206
  frot            r1 r2 r3 -- r2 r3 r1    float
+ fnip            r1 r2 -- r2     gforth
+ ftuck           r1 r2 -- r2 r1 r2       gforth
  float+          f_addr1 -- f_addr2      float   float_plus
  f_addr2 = f_addr1+1;
- Line 1119
+ Line 1247
  Line 1119
  Line 1247
  char *sig;
  Cell flag;
  Cell decpt;
- sig=ecvt(r, u, &decpt, &flag);
+ sig=ecvt(r, u, (int *)&decpt, (int *)&flag);
  n=(r==0 ? 1 : decpt);
  f1=FLAG(flag!=0);
  f2=FLAG(isdigit(sig[0])!=0);
- Line 1259
+ Line 1387
  Line 1259
  Line 1387
   fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
   r> IF  fnegate  THEN ;
- \ The following words access machine/OS/installation-dependent ANSI
+ sfloats         n1 -- n2        float-ext       s_floats
- \   figForth internals
+ n2 = n1*sizeof(SFloat);
+ dfloats         n1 -- n2        float-ext       d_floats
+ n2 = n1*sizeof(DFloat);
+ aligned         c_addr -- a_addr        core
+ 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
+ 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
+ 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
+ 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
+ \   Gforth internals
  \ !! how about environmental queries DIRECT-THREADED,
  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
  >body           xt -- a_addr    core    to_body
  a_addr = PFA(xt);
- >code-address           xt -- c_addr            new     to_code_address
+ >code-address           xt -- c_addr            gforth  to_code_address
  ""c_addr is the code address of the word xt""
  /* !! This behaves installation-dependently for DOES-words */
  c_addr = CODE_ADDRESS(xt);
- >does-code      xt -- a_addr            new     to_does_code
+ >does-code      xt -- a_addr            gforth  to_does_code
  ""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
  behaviour is undefined""
- Line 1280
+ Line 1434
  Line 1280
  Line 1434
  defining-word-defined */
  a_addr = (Cell *)DOES_CODE(xt);
- code-address!           n xt -- new     code_address_store
+ code-address!           c_addr xt --            gforth  code_address_store
  ""Creates a code field with code address c_addr at xt""
- MAKE_CF(xt, symbols[CF(n)]);
+ MAKE_CF(xt, c_addr);
  CACHE_FLUSH(xt,PFA(0));
- does-code!      a_addr xt --            new     does_code_store
+ does-code!      a_addr xt --            gforth  does_code_store
  ""creates a code field at xt for a defining-word-defined word; a_addr
  is the start of the Forth code after DOES>""
  MAKE_DOES_CF(xt, a_addr);
  CACHE_FLUSH(xt,PFA(0));
- does-handler!   a_addr --       new     does_jump_store
+ does-handler!   a_addr --       gforth  does_handler_store
  ""creates a DOES>-handler at address a_addr. a_addr usually points
  just behind a DOES>.""
  MAKE_DOES_HANDLER(a_addr);
  CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
- /does-handler   -- n    new     slash_does_handler
+ /does-handler   -- n    gforth  slash_does_handler
  ""the size of a does-handler (includes possible padding)""
  /* !! a constant or environmental query might be better */
  n = DOES_HANDLER_SIZE;
- toupper c1 -- c2        new
+ flush-icache    c_addr u --     gforth  flush_icache
+ ""Make sure that the instruction cache of the processor (if there is
+ one) does not contain stale data at @var{c_addr} and @var{u} bytes
+ afterwards. @code{END-CODE} performs a @code{flush-icache}
+ automatically. Caveat: @code{flush-icache} might not work on your
+ installation; this is usually the case if direct threading is not
+ supported on your machine (take a look at your @file{machine.h}) and
+ your machine has a separate instruction cache. In such cases,
+ @code{flush-icache} does nothing instead of flushing the instruction
+ cache.""
+ FLUSH_ICACHE(c_addr,u);
+ toupper c1 -- c2        gforth
  c2 = toupper(c1);
  \ local variable implementation primitives
- @local#         -- w    new     fetch_local_number
+ @local#         -- w    gforth  fetch_local_number
  w = *(Cell *)(lp+(Cell)NEXT_INST);
  INC_IP(1);
- Line 1322
+ Line 1488
  Line 1322
  Line 1488
  @local3 -- w    new     fetch_local_twelve
  w = *(Cell *)(lp+3*sizeof(Cell));
- f@local#        -- r    new     f_fetch_local_number
+ f@local#        -- r    gforth  f_fetch_local_number
  r = *(Float *)(lp+(Cell)NEXT_INST);
  INC_IP(1);
- Line 1332
+ Line 1498
  Line 1332
  Line 1498
  f@local1        -- r    new     f_fetch_local_eight
  r = *(Float *)(lp+1*sizeof(Float));
- laddr#          -- c_addr       new     laddr_number
+ laddr#          -- c_addr       gforth  laddr_number
  /* this can also be used to implement lp@ */
  c_addr = (Char *)(lp+(Cell)NEXT_INST);
  INC_IP(1);
- lp+!#   --      new     lp_plus_store_number
+ lp+!#   --      gforth  lp_plus_store_number
  ""used with negative immediate values it allocates memory on the
  local stack, a positive immediate argument drops memory from the local
  stack""
- Line 1353
+ Line 1519
  Line 1353
  Line 1519
  lp+2    --      new     sixteen_lp_plus_store
  lp += 2*sizeof(Float);
- lp!     c_addr --       new     lp_store
+ lp!     c_addr --       gforth  lp_store
  lp = (Address)c_addr;
- >l      w --    new     to_l
+ >l      w --    gforth  to_l
  lp -= sizeof(Cell);
  *(Cell *)lp = w;
- f>l     r --    new     f_to_l
+ f>l     r --    gforth  f_to_l
  lp -= sizeof(Float);
  *(Float *)lp = r;
- up!     a_addr --       new     up_store
+ up!     a_addr --       gforth  up_store
  up0=up=(char *)a_addr;
- call-c  w --    new     call_c
+ call-c  w --    gforth  call_c
  ""Call the C function pointed to by @i{w}. The C function has to
  access the stack itself. The stack pointers are exported in the gloabl
  variables @code{SP} and @code{FP}.""
- Line 1382
+ Line 1548
  Line 1382
  Line 1548
  IF_TOS(TOS=sp[0]);
  IF_FTOS(FTOS=fp[0]);
- strerror        n -- c_addr u   new
+ strerror        n -- c_addr u   gforth
  c_addr = strerror(n);
  u = strlen(c_addr);
+ strsignal       n -- c_addr u   gforth
+ c_addr = strsignal(n);
+ u = strlen(c_addr);

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.37
 


changed lines


 
Added in v.1.50
 Legend:



Removed from v.1.37
 


changed lines


 
Added in v.1.50
-Removed from v.1.37
+Added in v.1.50

CVS Admin

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.37 and 1.50

ViewCVS and CVS Help