[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.14 and 1.15

version 1.14, Sun Nov 8 23:08:04 1998 UTC version 1.15, Sun Nov 22 23:18:09 1998 UTC
Line 128 
Line 128 
 :  :
  @ execute ;   @ execute ;
   
 \+has? glocals [IF]  \+glocals
   
 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 */
Line 136 
Line 136 
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 \+[THEN]  \+
   
 branch  --              gforth  branch  --              gforth
 branch:  branch:
Line 157 
Line 157 
     INC_IP(1);      INC_IP(1);
 $4  $4
   
 \+has? glocals [IF]  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    goto branch_adjust_lp;
Line 165 
Line 165 
 else  else
     INC_IP(2);      INC_IP(2);
   
 \+[THEN]  \+
 )  )
   
 condbranch(?branch,f --         f83     question_branch,  condbranch(?branch,f --         f83     question_branch,
Line 181 
Line 181 
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  \ we don't need an lp_plus_store version of the ?dup-stuff, because it
 \ is only used in if's (yet)  \ is only used in if's (yet)
   
 \+has? xconds [IF]  \+xconds
   
 ?dup-?branch    f -- f  new     question_dupe_question_branch  ?dup-?branch    f -- f  new     question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""  ""The run-time procedure compiled by @code{?DUP-IF}.""
Line 210 
Line 210 
 else  else
   INC_IP(1);    INC_IP(1);
   
 \+[THEN]  \+
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
Line 250 
Line 250 
  IF    >r + >r dup @ + >r   IF    >r + >r dup @ + >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+has? xconds [IF]  \+xconds
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 286 
Line 286 
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 ,)  ,)
   
 \+[THEN]  \+
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
Line 325 
Line 325 
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+has? xconds [IF]  \+xconds
   
 (+do)   nlimit nstart --        gforth  paren_plus_do  (+do)   nlimit nstart --        gforth  paren_plus_do
 *--rp = nlimit;  *--rp = nlimit;
Line 407 
Line 407 
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 \+[THEN]  \+
   
 \ don't make any assumptions where the return stack is!!  \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!  \ implement this in machine code if it should run quickly!
Line 905 
Line 905 
   
 )  )
   
 \+has? dcomps [IF]  \+dcomps
   
 dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)  dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
 dcomparisons(d0, d, d_zero_, d, DZERO, 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)  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
   
 \+[THEN]  \+
   
 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 931 
Line 931 
 rp!     a_addr --               gforth          rpstore  rp!     a_addr --               gforth          rpstore
 rp = a_addr;  rp = a_addr;
   
 \+has? floating [IF]  \+floating
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
Line 939 
Line 939 
 fp!     f_addr --       gforth  fp_store  fp!     f_addr --       gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 \+[THEN]  \+
   
 ;s      --              gforth  semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
Line 1191 
Line 1191 
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (find-samelen) ( u f83name1 -- u f83name2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;      BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
   
 \+has? hash [IF]  \+hash
   
 (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind  (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
 struct F83Name *f83name1;  struct F83Name *f83name1;
Line 1272 
Line 1272 
   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,
   
 \+[THEN]  \+
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  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? */
Line 1369 
Line 1369 
 :  :
  1 ;   1 ;
   
 \+has? os [IF]  \+os
   
 key-file        wfileid -- n            gforth  paren_key_file  key-file        wfileid -- n            gforth  paren_key_file
 fflush(stdout);  fflush(stdout);
Line 1495 
Line 1495 
 IF_TOS(TOS=sp[0]);  IF_TOS(TOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_FTOS(FTOS=fp[0]);
   
 \+[THEN] ( has? os ) has? file [IF]  \+
   \+file
   
 close-file      wfileid -- wior         file    close_file  close-file      wfileid -- wior         file    close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
Line 1583 
Line 1584 
   u2=0;    u2=0;
 }  }
   
 \+[THEN]  has? file [IF] -1 [ELSE] has? os [THEN] [IF]  \+
   \+file
   
 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 1599 
Line 1601 
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 \+[THEN]  has? file [IF]  \+
   \+file
   
 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 1628 
Line 1631 
   wior=0;    wior=0;
 }  }
   
 \+[THEN] ( has? file ) has? floating [IF]  \+
   \+floating
   
 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)
Line 1923 
Line 1927 
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+[THEN] ( has? floats ) has? glocals [IF]  \+
   \+glocals
   
 @local#         -- w    gforth  fetch_local_number  @local#         -- w    gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+(Cell)NEXT_INST);
Line 1941 
Line 1946 
 @local3 -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = *(Cell *)(lp+3*sizeof(Cell));
   
 \+has? floating [IF]  \+floating
   
 f@local#        -- r    gforth  f_fetch_local_number  f@local#        -- r    gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+(Cell)NEXT_INST);
Line 1953 
Line 1958 
 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));
   
 \+[THEN]  \+
   
 laddr#          -- c_addr       gforth  laddr_number  laddr#          -- c_addr       gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
Line 1983 
Line 1988 
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 \+has? floating [IF]  \+floating
   
 f>l     r --    gforth  f_to_l  f>l     r --    gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
Line 1994 
Line 1999 
 :  :
  floats fp@ + f@ ;   floats fp@ + f@ ;
   
 \+[THEN]  [THEN] \ has? glocals  \+
   \+
   
 \+has? OS [IF]  \+OS
   
 define(`uploop',  define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')         `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
Line 2060 
Line 2066 
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+[THEN] \ has? OS  \+
   
 up!     a_addr --       gforth  up_store  up!     a_addr --       gforth  up_store
 UP=up=(char *)a_addr;  UP=up=(char *)a_addr;

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help