[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.42 and 1.43

version 1.42, Wed Oct 11 19:39:35 1995 UTC version 1.43, Mon Oct 16 18:33:11 1995 UTC
Line 80 
Line 80 
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   
 noop    --              fig  noop    --              gforth
 ;  ;
 :  :
  ;   ;
   
 lit     -- w            fig  lit     -- w            gforth
 w = (Cell)NEXT_INST;  w = (Cell)NEXT_INST;
 INC_IP(1);  INC_IP(1);
   
Line 95 
Line 95 
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 NEXT1;  NEXT1;
   
 branch-lp+!#    --      new     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:
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 branch  --              fig  branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
 NEXT_P0;  NEXT_P0;
Line 136 
Line 136 
 if ((*rp)--) {  if ((*rp)--) {
 )  )
   
 condbranch((loop),--            fig     paren_loop,  condbranch((loop),--            gforth  paren_loop,
 Cell index = *rp+1;  Cell index = *rp+1;
 Cell limit = rp[1];  Cell limit = rp[1];
 if (index != limit) {  if (index != limit) {
Line 210 
Line 210 
 :  :
  r> swap 0 >r >r >r ;   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% */  /* or do it in high-level? 0.09/0.23% */
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 :  :
  r> -rot swap >r >r >r ;   r> -rot swap >r >r >r ;
   
 (?do)   nlimit nstart --        new     paren_question_do  (?do)   nlimit nstart --        gforth  paren_question_do
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 if (nstart == nlimit) {  if (nstart == nlimit) {
Line 228 
Line 228 
     INC_IP(1);      INC_IP(1);
 }  }
   
 (+do)   nlimit nstart --        new     paren_plus_do  (+do)   nlimit nstart --        gforth  paren_plus_do
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
Line 239 
Line 239 
     INC_IP(1);      INC_IP(1);
 }  }
   
 (u+do)  ulimit ustart --        new     paren_u_plus_do  (u+do)  ulimit ustart --        gforth  paren_u_plus_do
 *--rp = ulimit;  *--rp = ulimit;
 *--rp = ustart;  *--rp = ustart;
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
Line 250 
Line 250 
     INC_IP(1);      INC_IP(1);
 }  }
   
 (-do)   nlimit nstart --        new     paren_minus_do  (-do)   nlimit nstart --        gforth  paren_minus_do
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
Line 261 
Line 261 
     INC_IP(1);      INC_IP(1);
 }  }
   
 (u-do)  ulimit ustart --        new     paren_u_minus_do  (u-do)  ulimit ustart --        gforth  paren_u_minus_do
 *--rp = ulimit;  *--rp = ulimit;
 *--rp = ustart;  *--rp = ustart;
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
Line 280 
Line 280 
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 (emit)  c --            fig     paren_emit  (emit)  c --            gforth  paren_emit
 putchar(c);  putchar(c);
 emitcounter++;  emitcounter++;
   
Line 288 
Line 288 
 fwrite(c_addr,sizeof(Char),n,stdout);  fwrite(c_addr,sizeof(Char),n,stdout);
 emitcounter += n;  emitcounter += n;
   
 (key)   -- n            fig     paren_key  (key)   -- n            gforth  paren_key
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  /* !! noecho */
 n = key();  n = key();
Line 627 
Line 627 
 $1>     $2 -- f         $9      $3greater  $1>     $2 -- f         $9      $3greater
 f = FLAG($4>$5);  f = FLAG($4>$5);
   
 $1<=    $2 -- f         new     $3less_or_equal  $1<=    $2 -- f         gforth  $3less_or_equal
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
   
 $1>=    $2 -- f         new     $3greater_or_equal  $1>=    $2 -- f         gforth  $3greater_or_equal
 f = FLAG($4>=$5);  f = FLAG($4>=$5);
   
 )  )
   
 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, 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  within  u1 u2 u3 -- f           core-ext
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
 sp@     -- a_addr               fig             spat  sp@     -- a_addr               gforth          spat
 a_addr = sp+1;  a_addr = sp+1;
   
 sp!     a_addr --               fig             spstore  sp!     a_addr --               gforth          spstore
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without TOS caching */
   
 rp@     -- a_addr               fig             rpat  rp@     -- a_addr               gforth          rpat
 a_addr = rp;  a_addr = rp;
   
 rp!     a_addr --               fig             rpstore  rp!     a_addr --               gforth          rpstore
 rp = a_addr;  rp = a_addr;
   
 fp@     -- f_addr       new     fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
   
 fp!     f_addr --       new     fp_store  fp!     f_addr --       gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 ;s      --              fig     semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
 NEXT_P0;  NEXT_P0;
   
Line 755 
Line 755 
 :  :
  >r -rot r> -rot ;   >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-ext      two_rote
 :  :
  >r >r 2swap r> r> 2swap ;   >r >r 2swap r> r> 2swap ;
   
Line 928 
Line 928 
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (hashkey)       c_addr u1 -- u2         new     paren_hashkey  (hashkey)       c_addr u1 -- u2         gforth  paren_hashkey
 u2=0;  u2=0;
 while(u1--)  while(u1--)
    u2+=(Cell)toupper(*c_addr++);     u2+=(Cell)toupper(*c_addr++);
 :  :
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;   0 -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""  ""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  /* 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     ubits bits and xors it with the character. This function does ok in
Line 962 
Line 962 
   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, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
   7 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        gforth  paren_parse_white
 /* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
 Char *endp = c_addr1+u1;  Char *endp = c_addr1+u1;
 while (c_addr1<endp && isspace(*c_addr1))  while (c_addr1<endp && isspace(*c_addr1))
Line 1096 
Line 1096 
   wior=0;    wior=0;
 }  }
   
 comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)  comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, new, float, new)  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
 r = d;  r = d;
Line 1350 
Line 1350 
  fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/   fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
  r> IF  fnegate  THEN ;   r> IF  fnegate  THEN ;
   
   sfloats         n1 -- n2        float-ext       s_floats
   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));
   
   faligned        c_addr -- f_addr        float   f_aligned
   f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&~sizeof(Float));
   
   sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned
   sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&~sizeof(SFloat));
   
   dfaligned       c_addr -- df_addr       float-ext       d_f_aligned
   df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&~sizeof(DFloat));
   
 \ The following words access machine/OS/installation-dependent ANSI  \ The following words access machine/OS/installation-dependent ANSI
 \   figForth internals  \   figForth internals
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
Line 1358 
Line 1376 
 >body           xt -- a_addr    core    to_body  >body           xt -- a_addr    core    to_body
 a_addr = PFA(xt);  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""  ""c_addr is the code address of the word xt""
 /* !! This behaves installation-dependently for DOES-words */  /* !! This behaves installation-dependently for DOES-words */
 c_addr = CODE_ADDRESS(xt);  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,  ""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>; Otherwise the
 behaviour is undefined""  behaviour is undefined""
Line 1371 
Line 1389 
 defining-word-defined */  defining-word-defined */
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
   
 code-address!           c_addr 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""  ""Creates a code field with code address c_addr at xt""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,PFA(0));  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  ""creates a code field at xt for a defining-word-defined word; a_addr
 is the start of the Forth code after DOES>""  is the start of the Forth code after DOES>""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,PFA(0));  CACHE_FLUSH(xt,PFA(0));
   
 does-handler!   a_addr --       new     does_handler_store  does-handler!   a_addr --       gforth  does_handler_store
 ""creates a DOES>-handler at address a_addr. a_addr usually points  ""creates a DOES>-handler at address a_addr. a_addr usually points
 just behind a DOES>.""  just behind a DOES>.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  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)""  ""the size of a does-handler (includes possible padding)""
 /* !! a constant or environmental query might be better */  /* !! a constant or environmental query might be better */
 n = DOES_HANDLER_SIZE;  n = DOES_HANDLER_SIZE;
Line 1405 
Line 1423 
 cache.""  cache.""
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE(c_addr,u);
   
 toupper c1 -- c2        new  toupper c1 -- c2        gforth
 c2 = toupper(c1);  c2 = toupper(c1);
   
 \ local variable implementation primitives  \ local variable implementation primitives
 @local#         -- w    new     fetch_local_number  @local#         -- w    gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
   
Line 1425 
Line 1443 
 @local3 -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  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);  r = *(Float *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
   
Line 1435 
Line 1453 
 f@local1        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  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@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(Cell)NEXT_INST);  c_addr = (Char *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  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  ""used with negative immediate values it allocates memory on the
 local stack, a positive immediate argument drops memory from the local  local stack, a positive immediate argument drops memory from the local
 stack""  stack""
Line 1456 
Line 1474 
 lp+2    --      new     sixteen_lp_plus_store  lp+2    --      new     sixteen_lp_plus_store
 lp += 2*sizeof(Float);  lp += 2*sizeof(Float);
   
 lp!     c_addr --       new     lp_store  lp!     c_addr --       gforth  lp_store
 lp = (Address)c_addr;  lp = (Address)c_addr;
   
 >l      w --    new     to_l  >l      w --    gforth  to_l
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 f>l     r --    new     f_to_l  f>l     r --    gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 up!     a_addr --       new     up_store  up!     a_addr --       gforth  up_store
 up0=up=(char *)a_addr;  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  ""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  access the stack itself. The stack pointers are exported in the gloabl
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{FP}.""
Line 1485 
Line 1503 
 IF_TOS(TOS=sp[0]);  IF_TOS(TOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_FTOS(FTOS=fp[0]);
   
 strerror        n -- c_addr u   new  strerror        n -- c_addr u   gforth
 c_addr = strerror(n);  c_addr = strerror(n);
 u = strlen(c_addr);  u = strlen(c_addr);
   
 strsignal       n -- c_addr u   new  strsignal       n -- c_addr u   gforth
 c_addr = strsignal(n);  c_addr = strsignal(n);
 u = strlen(c_addr);  u = strlen(c_addr);

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help