[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.56 and 1.152

version 1.56, Thu Aug 17 12:46:57 2000 UTC version 1.152, Mon Mar 29 13:54:14 2004 UTC
Line 1 
Line 1 
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 
Line 16 
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
Line 54 
Line 54 
 \ stack. Use different names on both sides of the '--', if you change a  \ stack. Use different names on both sides of the '--', if you change a
 \ value (some stores to the stack are optimized away).  \ value (some stores to the stack are optimized away).
 \  \
   \ For superinstructions the syntax is:
   \
   \ forth-name [/ c-name] = forth-name forth-name ...
 \  \
 \  \
 \ The stack variables have the following types:  \ The stack variables have the following types:
Line 72 
Line 75 
 \ df_.*         DFloat *  \ df_.*         DFloat *
 \ sf_.*         SFloat *  \ sf_.*         SFloat *
 \ xt.*          XT  \ xt.*          XT
 \ wid.*         WID  
 \ f83name.*     F83Name *  \ f83name.*     F83Name *
   
   \E stack data-stack   sp Cell
   \E stack fp-stack     fp Float
   \E stack return-stack rp Cell
   \E
   \E get-current prefixes set-current
   \E
   \E s" Bool"             single data-stack type-prefix f
   \E s" Char"             single data-stack type-prefix c
   \E s" Cell"             single data-stack type-prefix n
   \E s" Cell"             single data-stack type-prefix w
   \E s" UCell"            single data-stack type-prefix u
   \E s" DCell"            double data-stack type-prefix d
   \E s" UDCell"           double data-stack type-prefix ud
   \E s" Float"            single fp-stack   type-prefix r
   \E s" Cell *"           single data-stack type-prefix a_
   \E s" Char *"           single data-stack type-prefix c_
   \E s" Float *"          single data-stack type-prefix f_
   \E s" DFloat *"         single data-stack type-prefix df_
   \E s" SFloat *"         single data-stack type-prefix sf_
   \E s" Xt"               single data-stack type-prefix xt
   \E s" struct F83Name *" single data-stack type-prefix f83name
   \E s" struct Longname *" single data-stack type-prefix longname
   \E
   \E return-stack stack-prefix R:
   \E inst-stream  stack-prefix #
   \E
   \E set-current
   \E store-optimization on
   \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
   \E
   \E include-skipped-insts on \ static superinsts include cells for components
   \E                          \ useful for dynamic programming and
   \E                          \ superinsts across entry points
   
 \  \
 \  \
 \  \
Line 99 
Line 136 
 \ throw execute, cfa and NEXT1 out?  \ throw execute, cfa and NEXT1 out?
 \ macroize *ip, ip++, *ip++ (pipelining)?  \ macroize *ip, ip++, *ip++ (pipelining)?
   
   \ Stack caching setup
   
   ifdef(`M4_ENGINE_FAST', `include(cache1.vmg)', `include(cache0.vmg)')
   
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
 undefine(`shift')  undefine(`shift')
   undefine(`symbols')
   
   \F 0 [if]
   
   \ run-time routines for non-primitives.  They are defined as
   \ primitives, because that simplifies things.
   
   (docol) ( -- R:a_retaddr )      gforth-internal paren_docol
   ""run-time routine for colon definitions""
   #ifdef NO_IP
   a_retaddr = next_code;
   INST_TAIL;
   goto **(Label *)PFA(CFA);
   #else /* !defined(NO_IP) */
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)PFA(CFA));
   #endif /* !defined(NO_IP) */
   
   (docon) ( -- w )        gforth-internal paren_docon
   ""run-time routine for constants""
   w = *(Cell *)PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (dovar) ( -- a_body )   gforth-internal paren_dovar
   ""run-time routine for variables and CREATEd words""
   a_body = PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (douser) ( -- a_user )  gforth-internal paren_douser
   ""run-time routine for constants""
   a_user = (Cell *)(up+*(Cell *)PFA(CFA));
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (dodefer) ( -- )        gforth-internal paren_dodefer
   ""run-time routine for deferred words""
   #ifndef NO_IP
   ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
   #endif /* !defined(NO_IP) */
   SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
   EXEC(*(Xt *)PFA(CFA));
   
   (dofield) ( n1 -- n2 )  gforth-internal paren_field
   ""run-time routine for fields""
   n2 = n1 + *(Cell *)PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (dodoes) ( -- a_body R:a_retaddr )      gforth-internal paren_dodoes
   ""run-time routine for @code{does>}-defined words""
   #ifdef NO_IP
   a_retaddr = next_code;
   a_body = PFA(CFA);
   INST_TAIL;
   goto **(Label *)DOES_CODE1(CFA);
   #else /* !defined(NO_IP) */
   a_retaddr = (Cell *)IP;
   a_body = PFA(CFA);
   SET_IP(DOES_CODE1(CFA));
   #endif /* !defined(NO_IP) */
   
   (does-handler) ( -- )   gforth-internal paren_does_handler
   ""just a slot to have an encoding for the DOESJUMP,
   which is no longer used anyway (!! eliminate this)""
   
   \F [endif]
   
   \g control
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
 ;  
 :  :
  ;   ;
   
 lit     ( -- w )                gforth  call    ( #a_callee -- R:a_retaddr )    new
 w = (Cell)NEXT_INST;  ""Call callee (a variant of docol with inline argument).""
 INC_IP(1);  #ifdef NO_IP
 :  assert(0);
  r> dup @ swap cell+ >r ;  INST_TAIL;
   JUMP(a_callee);
   #else
   #ifdef DEBUG
       {
         CFA_TO_NAME((((Cell *)a_callee)-2));
         fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee,
                 len,name);
       }
   #endif
   a_retaddr = (Cell *)IP;
   SET_IP((Xt *)a_callee);
   #endif
   
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
   #ifndef NO_IP
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  #endif
   IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */
   SUPER_END;
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
   #ifndef NO_IP
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  #endif
   IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */
   SUPER_END;
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
   
 \fhas? skipbranchprims 0= [IF]  ;s      ( R:w -- )              gforth  semis
   ""The primitive compiled by @code{EXIT}.""
   #ifdef NO_IP
   INST_TAIL;
   goto *(void *)w;
   #else
   SET_IP((Xt *)w);
   #endif
   
   unloop  ( R:w1 R:w2 -- )        core
   /* !! alias for 2rdrop */
   :
    r> rdrop rdrop >r ;
   
   lit-perform     ( #a_addr -- )  new     lit_perform
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   EXEC(*(Xt *)a_addr);
   
   does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
   #ifdef NO_IP
   /* compiled to LIT CALL by compile_prim */
   assert(0);
   #else
   a_pfa = PFA(a_cfa);
   nest = (Cell)IP;
   IF_spTOS(spTOS = sp[0]);
   #ifdef DEBUG
       {
         CFA_TO_NAME(a_cfa);
         fprintf(stderr,"%08lx: does %08lx %.*s\n",
                 (Cell)ip,(Cell)a_cfa,len,name);
       }
   #endif
   SET_IP(DOES_CODE1(a_cfa));
   #endif
   
 \+glocals  \+glocals
   
 branch-lp+!#    ( -- )  gforth  branch_lp_plus_store_number  branch-lp+!# ( #a_target #nlocals -- )  gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  lp += nlocals;
 lp += (Cell)(IP[1]);  #ifdef NO_IP
 goto branch;  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
   
 \+  \+
   
 branch  ( -- )          gforth  branch  ( #a_target -- )        gforth
 branch:  #ifdef NO_IP
 SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   #endif
 :  :
  r> dup @ + >r ;   r> @ >r ;
   
 \ condbranch(forthname,restline,code,forthcode)  \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1      $2  $1 ( `#'a_target $2 ) $3
 $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  $4      #ifdef NO_IP
         NEXT;  INST_TAIL;
   #endif
   $5      #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 else  SUPER_CONTINUE;
     INC_IP(1);  $6
 $4  
   
 \+glocals  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number
 $3    goto branch_adjust_lp;  $4      #ifdef NO_IP
   INST_TAIL;
   #endif
   $5      lp += nlocals;
   #ifdef NO_IP
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;
   #endif
 }  }
 else  SUPER_CONTINUE;
     INC_IP(2);  
   
 \+  \+
 )  )
   
 condbranch(?branch,( f -- )             f83     question_branch,  condbranch(?branch,f --,f83     question_branch,
 if (f==0) {  ,if (f==0) {
     IF_TOS(TOS = sp[0]);  
 ,:  ,:
  0= dup     \ !f !f   0= dup 0=          \ !f f
  r> dup @   \ !f !f IP branchoffset   r> tuck cell+      \ !f branchoffset f IP+
  rot and +  \ !f IP|IP+branchoffset   and -rot @ and or  \ f&IP+|!f&branch
  swap 0= cell and + \ IP''  
  >r ;)   >r ;)
   
 \ 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
Line 183 
Line 377 
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( f -- f )      new     question_dupe_question_branch  ?dup-?branch    ( #a_target 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}.""
 if (f==0) {  if (f==0) {
   sp++;    sp++;
   IF_TOS(TOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  #ifdef NO_IP
   NEXT;  INST_TAIL;
   JUMP(a_target);
   #else
   SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;
   #endif
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 ?dup-0=-?branch ( f -- )        new     question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #a_target f -- ) new  question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
 /* the approach taken here of declaring the word as having the stack  /* 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  effect ( f -- ) and correcting for it in the branch-taken case costs a
Line 202 
Line 400 
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  #ifdef NO_IP
     JUMP(a_target);
   #else
     SET_IP((Xt *)a_target);
   NEXT;    NEXT;
   #endif
 }  }
 else  SUPER_CONTINUE;
   INC_IP(1);  
   
 \+  \+
 \f[THEN]  
 \fhas? skiploopprims 0= [IF]  \fhas? skiploopprims 0= [IF]
   
 condbranch((next),( -- )                cmFORTH paren_next,  condbranch((next),R:n1 -- R:n2,cmFORTH  paren_next,
 if ((*rp)--) {  n2=n1-1;
   ,if (n1) {
 ,:  ,:
  r> r> dup 1- >r   r> r> dup 1- >r
  IF dup @ + >r ELSE cell+ >r THEN ;)   IF @ >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),( -- )                gforth  paren_loop,  condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop,
 Cell index = *rp+1;  n2=n1+1;
 Cell limit = rp[1];  ,if (n2 != nlimit) {
 if (index != limit) {  
     *rp = index;  
 ,:  ,:
  r> r> 1+ r> 2dup =   r> r> 1+ r> 2dup =
  IF >r 1- >r cell+ >r   IF >r 1- >r cell+ >r
  ELSE >r >r dup @ + >r THEN ;)   ELSE >r >r @ >r THEN ;)
   
 condbranch((+loop),( n -- )             gforth  paren_plus_loop,  condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
 Cell index = *rp;  
 /* 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 */
 Cell olddiff = index-rp[1];  Cell olddiff = n1-nlimit;
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  n2=n1+n;
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {  ,if (((olddiff^(olddiff+n))    /* the limit is not crossed */
 #ifdef i386       &(olddiff^n))             /* OR it is a wrap-around effect */
     *rp += n;      >=0) { /* & is used to avoid having two branches for gforth-native */
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
  2 pick r@ + r@ xor 0< 0=   2 pick r@ + r@ xor 0< 0=
  3 pick r> xor 0< 0= or   3 pick r> xor 0< 0= or
  IF    >r + >r dup @ + >r   IF    >r + >r @ >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+xconds  \+xconds
   
 condbranch((-loop),( u -- )             gforth  paren_minus_loop,  condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop,
 /* !! check this thoroughly */  UCell olddiff = n1-nlimit;
 Cell index = *rp;  n2=n1-u;
 UCell olddiff = index-rp[1];  ,if (olddiff>u) {
 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,  condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth     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 */
 Cell index = *rp;  Cell diff = n1-nlimit;
 Cell diff = index-rp[1];  
 Cell newdiff = diff+n;  Cell newdiff = diff+n;
 if (n<0) {  if (n<0) {
     diff = -diff;      diff = -diff;
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 if (diff>=0 || newdiff<0) {  n2=n1+n;
 #ifdef i386  ,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,)  ,)
   
 \+  \+
   
 unloop  ( -- )  core  (for)   ( ncount -- R:nlimit R:ncount )         cmFORTH         paren_for
 rp += 2;  
 :  
  r> rdrop rdrop >r ;  
   
 (for)   ( ncount -- )           cmFORTH         paren_for  
 /* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
 *--rp = 0;  nlimit=0;
 *--rp = ncount;  
 :  :
  r> swap 0 >r >r >r ;   r> swap 0 >r >r >r ;
   
 (do)    ( nlimit nstart -- )            gforth          paren_do  (do)    ( nlimit nstart -- R:nlimit R:nstart )  gforth          paren_do
 /* or do it in high-level? 0.09/0.23% */  
 *--rp = nlimit;  
 *--rp = nstart;  
 :  :
  r> swap rot >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   ( nlimit nstart -- )    gforth  paren_question_do  (?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth   paren_question_do
 *--rp = nlimit;  #ifdef NO_IP
 *--rp = nstart;      INST_TAIL;
   #endif
 if (nstart == nlimit) {  if (nstart == nlimit) {
     IF_TOS(TOS = sp[0]);  #ifdef NO_IP
     goto branch;      JUMP(a_target);
     }  #else
 else {      SET_IP((Xt *)a_target);
     INC_IP(1);      INST_TAIL; NEXT_P2;
   #endif
 }  }
   SUPER_CONTINUE;
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
        dup @ + >r         @ >r
   ELSE r> swap rot >r >r    ELSE r> swap rot >r >r
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+xconds  \+xconds
   
 (+do)   ( nlimit nstart -- )    gforth  paren_plus_do  (+do)   ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do
 *--rp = nlimit;  #ifdef NO_IP
 *--rp = nstart;      INST_TAIL;
   #endif
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
     IF_TOS(TOS = sp[0]);  #ifdef NO_IP
     goto branch;      JUMP(a_target);
     }  #else
 else {      SET_IP((Xt *)a_target);
     INC_IP(1);      INST_TAIL; NEXT_P2;
   #endif
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  >=   >=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u+do)  ( ulimit ustart -- )    gforth  paren_u_plus_do  (u+do)  ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do
 *--rp = ulimit;  #ifdef NO_IP
 *--rp = ustart;      INST_TAIL;
   #endif
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
     IF_TOS(TOS = sp[0]);  #ifdef NO_IP
     goto branch;  JUMP(a_target);
     }  #else
 else {  SET_IP((Xt *)a_target);
     INC_IP(1);  INST_TAIL; NEXT_P2;
   #endif
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  u>=   u>=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (-do)   ( nlimit nstart -- )    gforth  paren_minus_do  (-do)   ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do
 *--rp = nlimit;  #ifdef NO_IP
 *--rp = nstart;      INST_TAIL;
   #endif
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
     IF_TOS(TOS = sp[0]);  #ifdef NO_IP
     goto branch;  JUMP(a_target);
     }  #else
 else {  SET_IP((Xt *)a_target);
     INC_IP(1);  INST_TAIL; NEXT_P2;
   #endif
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  <=   <=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u-do)  ( ulimit ustart -- )    gforth  paren_u_minus_do  (u-do)  ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do
 *--rp = ulimit;  #ifdef NO_IP
 *--rp = ustart;      INST_TAIL;
   #endif
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
     IF_TOS(TOS = sp[0]);  #ifdef NO_IP
     goto branch;  JUMP(a_target);
     }  #else
 else {  SET_IP((Xt *)a_target);
     INC_IP(1);  INST_TAIL; NEXT_P2;
   #endif
 }  }
   SUPER_CONTINUE;
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
  u<=   u<=
  IF   IF
      dup @ +       @
  ELSE   ELSE
      cell+       cell+
  THEN  >r ;   THEN  >r ;
Line 412 
Line 599 
 \ 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!
   
 i       ( -- n )                core  i       ( R:n -- R:n n )                core
 n = *rp;  
 :  :
 \ rp@ cell+ @ ;  \ rp@ cell+ @ ;
   r> r> tuck >r >r ;    r> r> tuck >r >r ;
   
 i'      ( -- w )                gforth          i_tick  i'      ( R:w R:w2 -- R:w R:w2 w )              gforth          i_tick
 ""loop end value""  
 w = rp[1];  
 :  :
 \ rp@ cell+ cell+ @ ;  \ rp@ cell+ cell+ @ ;
   r> r> r> dup itmp ! >r >r >r itmp @ ;    r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp  variable itmp
   
 j       ( -- n )                core  j       ( R:n R:d1 -- n R:n R:d1 )              core
 n = rp[2];  
 :  :
 \ rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;    r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [IFUNDEF] itmp variable itmp [THEN]
   
 k       ( -- n )                gforth  k       ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )            gforth
 n = rp[4];  
 :  :
 \ rp@ [ 5 cells ] Literal + @ ;  \ rp@ [ 5 cells ] Literal + @ ;
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;    r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
Line 444 
Line 626 
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
   \g strings
   
 move    ( c_from c_to ucount -- )               core  move    ( c_from c_to ucount -- )               core
 ""Copy the contents of @i{ucount} aus at @i{c-from} to  ""Copy the contents of @i{ucount} aus at @i{c-from} to
 @i{c-to}. @code{move} works correctly even if the two areas overlap.""  @i{c-to}. @code{move} works correctly even if the two areas overlap.""
Line 458 
Line 642 
 @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from low address to high address; i.e., for overlapping areas it is  from low address to high address; i.e., for overlapping areas it is
 safe if @i{c-to}=<@i{c-from}.""  safe if @i{c-to}=<@i{c-from}.""
 while (u-- > 0)  cmove(c_from,c_to,u);
   *c_to++ = *c_from++;  
 :  :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
Line 468 
Line 651 
 @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}
 from high address to low address; i.e., for overlapping areas it is  from high address to low address; i.e., for overlapping areas it is
 safe if @i{c-to}>=@i{c-from}.""  safe if @i{c-to}>=@i{c-from}.""
 while (u-- > 0)  cmove_up(c_from,c_to,u);
   c_to[u] = c_from[u];  
 :  :
  dup 0= IF  drop 2drop exit  THEN   dup 0= IF  drop 2drop exit  THEN
  rot over + -rot bounds swap 1-   rot over + -rot bounds swap 1-
Line 489 
Line 671 
 comparison. In the future, this may change to consider the current  comparison. In the future, this may change to consider the current
 locale and its collation order.""  locale and its collation order.""
 /* close ' to keep fontify happy */  /* close ' to keep fontify happy */
 n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = compare(c_addr1, u1, c_addr2, u2);
 if (n==0)  
   n = u1-u2;  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  :
  rot 2dup swap - >r min swap -text dup   rot 2dup swap - >r min swap -text dup
  IF  rdrop  ELSE  drop r> sgn  THEN ;   IF  rdrop  ELSE  drop r> sgn  THEN ;
 : sgn ( n -- -1/0/1 )  : -text ( c_addr1 u c_addr2 -- n )
  dup 0= IF EXIT THEN  0< 2* 1+ ;  
   
 -text   ( c_addr1 u c_addr2 -- n )      new     dash_text  
 n = memcmp(c_addr1, c_addr2, u);  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  
  swap bounds   swap bounds
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
  ELSE  c@ I c@ - unloop  THEN  sgn ;   ELSE  c@ I c@ - unloop  THEN  sgn ;
 : sgn ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
  dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
   \ -text is only used by replaced primitives now; move it elsewhere
   \ -text ( c_addr1 u c_addr2 -- n )      new     dash_text
   \ n = memcmp(c_addr1, c_addr2, u);
   \ if (n<0)
   \   n = -1;
   \ else if (n>0)
   \   n = 1;
   \ :
   \  swap bounds
   \  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
   \  ELSE  c@ I c@ - unloop  THEN  sgn ;
   \ : sgn ( n -- -1/0/1 )
   \  dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 toupper ( c1 -- c2 )    gforth  toupper ( c1 -- c2 )    gforth
 ""If @i{c1} is a lower-case character (in the current locale), @i{c2}  ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
 is the equivalent upper-case character. All other characters are unchanged.""  is the equivalent upper-case character. All other characters are unchanged.""
Line 522 
Line 703 
 :  :
  dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;   dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
   
 capscomp        ( c_addr1 u c_addr2 -- n )      new  
 n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */  
 if (n<0)  
   n = -1;  
 else if (n>0)  
   n = 1;  
 :  
  swap bounds  
  ?DO  dup c@ I c@ <>  
      IF  dup c@ toupper I c@ toupper =  
      ELSE  true  THEN  WHILE  1+  LOOP  drop 0  
  ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;  
   
 -trailing       ( c_addr u1 -- c_addr u2 )              string  dash_trailing  
 ""Adjust the string specified by @i{c-addr, u1} to remove all trailing  
 spaces. @i{u2} is the length of the modified string.""  
 u2 = u1;  
 while (u2>0 && c_addr[u2-1] == ' ')  
   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
 ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}  ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
 characters from the start of the string.""  characters from the start of the string.""
Line 553 
Line 711 
 :  :
  tuck - >r + r> dup 0< IF  - 0  THEN ;   tuck - >r + r> dup 0< IF  - 0  THEN ;
   
   \g arith
   
   lit     ( #w -- w )             gforth
   :
    r> dup @ swap cell+ >r ;
   
 +       ( n1 n2 -- n )          core    plus  +       ( n1 n2 -- n )          core    plus
 n = n1+n2;  n = n1+n2;
   
   \ lit+ / lit_plus = lit +
   
   lit+    ( n1 #n2 -- n )         new     lit_plus
   n=n1+n2;
   
 \ PFE-0.9.14 has it differently, but the next release will have it as follows  \ PFE-0.9.14 has it differently, but the next release will have it as follows
 under+  ( n1 n2 n3 -- n n2 )    gforth  under_plus  under+  ( n1 n2 n3 -- n n2 )    gforth  under_plus
 ""add @i{n3} to @i{n1} (giving @i{n})""  ""add @i{n3} to @i{n1} (giving @i{n})""
Line 709 
Line 878 
 ud = (UDCell)u1 * (UDCell)u2;  ud = (UDCell)u1 * (UDCell)u2;
 #endif  #endif
 :  :
    >r >r 0 0 r> r> [ 8 cells ] literal 0     0 -rot dup [ 8 cells ] literal -
    DO     DO
        over >r dup >r 0< and d2*+ drop          dup 0< I' and d2*+ drop
        r> 2* r> swap     LOOP ;
    LOOP 2drop ;  
 : d2*+ ( ud n -- ud+n c )  : d2*+ ( ud n -- ud+n c )
    over MINI     over MINI
    and >r >r 2dup d+ swap r> + swap r> ;     and >r >r 2dup d+ swap r> + swap r> ;
Line 829 
Line 997 
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
   \g compare
   
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,  define(comparisons,
 $1=     ( $2 -- f )             $6      $3equals  $1=     ( $2 -- f )             $6      $3equals
Line 950 
Line 1120 
 :  :
  over - >r - r> u< ;   over - >r - r> u< ;
   
   \g stack
   
   useraddr        ( #u -- a_addr )        new
   a_addr = (Cell *)(up+u);
   
   up!     ( a_addr -- )   gforth  up_store
   UP=up=(char *)a_addr;
   :
    up ! ;
   Variable UP
   
 sp@     ( -- a_addr )           gforth          sp_fetch  sp@     ( -- a_addr )           gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp+1;
   
 sp!     ( a_addr -- )           gforth          sp_store  sp!     ( a_addr -- )           gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without spTOS caching */
   
 rp@     ( -- a_addr )           gforth          rp_fetch  rp@     ( -- a_addr )           gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
Line 973 
Line 1154 
   
 \+  \+
   
 ;s      ( -- )          gforth  semis  >r      ( w -- R:w )            core    to_r
 ""The primitive compiled by @code{EXIT}.""  
 SET_IP((Xt *)(*rp++));  
   
 >r      ( w -- )                core    to_r  
 ""@code{( R: -- w )}""  
 *--rp = w;  
 :  :
  (>r) ;   (>r) ;
 : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;  : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
   
 r>      ( -- w )                core    r_from  r>      ( R:w -- w )            core    r_from
 ""@code{( R: w -- )}""  
 w = *rp++;  
 :  :
  rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;   rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 Create (rdrop) ' ;s A,  Create (rdrop) ' ;s A,
   
 rdrop   ( -- )          gforth  rdrop   ( R:w -- )              gforth
 ""@code{( R: w -- )}""  
 rp++;  
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     ( w1 w2 -- )    core-ext        two_to_r  2>r     ( d -- R:d )    core-ext        two_to_r
 ""@code{( R: -- w1 w2 )}""  
 *--rp = w1;  
 *--rp = w2;  
 :  :
  swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;
   
 2r>     ( -- w1 w2 )    core-ext        two_r_from  2r>     ( R:d -- d )    core-ext        two_r_from
 ""@code{( R: w1 w2 -- )}""  
 w2 = *rp++;  
 w1 = *rp++;  
 :  :
  r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;
   
 2r@     ( -- w1 w2 )    core-ext        two_r_fetch  2r@     ( R:d -- R:d d )        core-ext        two_r_fetch
 ""@code{( R: w1 w2 -- w1 w2 )}""  
 w2 = rp[0];  
 w1 = rp[1];  
 :  :
  i' j ;   i' j ;
   
 2rdrop  ( -- )          gforth  two_r_drop  2rdrop  ( R:d -- )              gforth  two_r_drop
 ""@code{( R: w1 w2 -- )}""  
 rp+=2;  
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1066 
Line 1226 
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a  ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""  @code{dup} if w is nonzero.""
 if (w!=0) {  if (w!=0) {
   IF_TOS(*sp-- = w;)    IF_spTOS(*sp-- = w;)
 #ifndef USE_TOS  #ifndef USE_TOS
   *--sp = w;    *--sp = w;
 #endif  #endif
Line 1110 
Line 1270 
   
 \ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%
   
   \g memory
   
 @       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
 ""@i{w} is the cell stored at @i{a_addr}.""  ""@i{w} is the cell stored at @i{a_addr}.""
 w = *a_addr;  w = *a_addr;
   
   \ lit@ / lit_fetch = lit @
   
   lit@            ( #a_addr -- w ) new    lit_fetch
   w = *a_addr;
   
 !       ( w a_addr -- )         core    store  !       ( w a_addr -- )         core    store
 ""Store @i{w} into the cell at @i{a-addr}.""  ""Store @i{w} into the cell at @i{a-addr}.""
 *a_addr = w;  *a_addr = w;
Line 1231 
Line 1398 
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
   \g compiler
   
   \+f83headerstring
   
 (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find
 for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
Line 1245 
Line 1416 
     REPEAT  THEN  nip nip ;      REPEAT  THEN  nip nip ;
 : (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 ;
   : capscomp ( c_addr1 u c_addr2 -- n )
    swap bounds
    ?DO  dup c@ I c@ <>
        IF  dup c@ toupper I c@ toupper =
        ELSE  true  THEN  WHILE  1+  LOOP  drop 0
    ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
   : sgn ( n -- -1/0/1 )
    dup 0= IF EXIT THEN  0< 2* 1+ ;
   
   \-
   
   (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
   longname2=listlfind(c_addr, u, longname1);
   :
       BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
           >r 2dup r@ cell+ cell+ capscomp  0=
           IF  2drop r>  EXIT  THEN
           r> @
       REPEAT  THEN  nip nip ;
   : (findl-samelen) ( u longname1 -- u longname2/0 )
       BEGIN  2dup cell+ @ lcount-mask and <> WHILE  @  dup 0= UNTIL  THEN ;
   : capscomp ( c_addr1 u c_addr2 -- n )
    swap bounds
    ?DO  dup c@ I c@ <>
        IF  dup c@ toupper I c@ toupper =
        ELSE  true  THEN  WHILE  1+  LOOP  drop 0
    ELSE  c@ toupper I c@ toupper - unloop  THEN  sgn ;
   : sgn ( n -- -1/0/1 )
    dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 \+hash  \+hash
   
 (hashfind)      ( c_addr u a_addr -- f83name2 ) new     paren_hashfind  (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind
 struct F83Name *f83name1;  longname2 = hashlfind(c_addr, u, a_addr);
 f83name2=NULL;  
 while(a_addr != NULL)  
 {  
    f83name1=(struct F83Name *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)F83NAME_COUNT(f83name1)==u &&  
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  
      {  
         f83name2=f83name1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ c@ $1F and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
         IF  2dup r@ cell+ char+ capscomp 0=          IF  2dup r@ cell+ cell+ capscomp 0=
             IF  2drop r> rdrop  EXIT  THEN  THEN              IF  2drop r> rdrop  EXIT  THEN  THEN
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   
 (tablefind)     ( c_addr u a_addr -- f83name2 ) new     paren_tablefind  (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind
 ""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
 struct F83Name *f83name1;  longname2 = tablelfind(c_addr, u, a_addr);
 f83name2=NULL;  
 while(a_addr != NULL)  
 {  
    f83name1=(struct F83Name *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)F83NAME_COUNT(f83name1)==u &&  
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)  
      {  
         f83name2=f83name1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ c@ $1F and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
         IF  2dup r@ cell+ char+ -text 0=          IF  2dup r@ cell+ cell+ -text 0=
             IF  2drop r> rdrop  EXIT  THEN  THEN              IF  2drop r> rdrop  EXIT  THEN  THEN
         rdrop r>          rdrop r>
  REPEAT nip nip ;   REPEAT nip nip ;
   : -text ( c_addr1 u c_addr2 -- n )
 (hashkey)       ( c_addr u1 -- u2 )             gforth  paren_hashkey   swap bounds
 u2=0;   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
 while(u1--)   ELSE  c@ I c@ - unloop  THEN  sgn ;
    u2+=(Cell)toupper(*c_addr++);  : sgn ( n -- -1/0/1 )
 :   dup 0= IF EXIT THEN  0< 2* 1+ ;
  0 -rot bounds ?DO  I c@ toupper +  LOOP ;  
   
 (hashkey1)      ( c_addr u ubits -- ukey )              gforth  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  ukey = hashkey1(c_addr, u, ubits);
    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   dup rot-values + c@ over 1 swap lshift 1- >r
  tuck - 2swap r> 0 2swap bounds   tuck - 2swap r> 0 2swap bounds
Line 1329 
Line 1493 
   
 \+  \+
   
   \+
   
 (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? */  struct Cellpair r=parse_white(c_addr1, u1);
 Char *endp = c_addr1+u1;  c_addr2 = (Char *)(r.n1);
 while (c_addr1<endp && isspace(*c_addr1))  u2 = r.n2;
   c_addr1++;  
 if (c_addr1<endp) {  
   for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)  
     ;  
   u2 = c_addr1-c_addr2;  
 }  
 else {  
   c_addr2 = c_addr1;  
   u2 = 0;  
 }  
 :  :
  BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string   BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string
  REPEAT  THEN  2dup   REPEAT  THEN  2dup
Line 1361 
Line 1517 
 :  :
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;   [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 >body   ( xt -- a_addr )        core    to_body  
 "" Get the address of the body of the word represented by @i{xt} (the address  
 of the word's data field).""  
 a_addr = PFA(xt);  
 :  
     2 cells + ;  
   
 \ threading stuff is currently only interesting if we have a compiler  \ threading stuff is currently only interesting if we have a compiler
 \fhas? standardthreading has? compiler and [IF]  \fhas? standardthreading has? compiler and [IF]
   
 >code-address   ( xt -- c_addr )                gforth  to_code_address  
 ""@i{c-addr} is the code address of the word @i{xt}.""  
 /* !! This behaves installation-dependently for DOES-words */  
 c_addr = (Address)CODE_ADDRESS(xt);  
 :  
     @ ;  
   
 >does-code      ( xt -- a_addr )                gforth  to_does_code  
 ""If @i{xt} is the execution token of a defining-word-defined word,  
 @i{a-addr} is the start of the Forth code after the @code{DOES>};  
 Otherwise @i{a-addr} is 0.""  
 a_addr = (Cell *)DOES_CODE(xt);  
 :  
     cell+ @ ;  
   
 code-address!   ( c_addr xt -- )                gforth  code_address_store  
 ""Create a code field with code address @i{c-addr} at @i{xt}.""  
 MAKE_CF(xt, c_addr);  
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  
     ! ;  
   
 does-code!      ( a_addr xt -- )                gforth  does_code_store  
 ""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}  
 is the start of the Forth code after @code{DOES>}.""  
 MAKE_DOES_CF(xt, a_addr);  
 CACHE_FLUSH(xt,(size_t)PFA(0));  
 :  
     dodoes: over ! cell+ ! ;  
   
 does-handler!   ( a_addr -- )   gforth  does_handler_store  
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points  
 just behind a @code{DOES>}.""  
 MAKE_DOES_HANDLER(a_addr);  
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  
 :  
     drop ;  
   
 /does-handler   ( -- n )        gforth  slash_does_handler  
 ""The size of a @code{DOES>}-handler (includes possible padding).""  
 /* !! a constant or environmental query might be better */  
 n = DOES_HANDLER_SIZE;  
 :  
     2 cells ;  
   
 threading-method        ( -- n )        gforth  threading_method  threading-method        ( -- n )        gforth  threading_method
 ""0 if the engine is direct threaded. Note that this may change during  ""0 if the engine is direct threaded. Note that this may change during
 the lifetime of an image.""  the lifetime of an image.""
Line 1433 
Line 1536 
   
 \f[THEN]  \f[THEN]
   
   \g hostos
   
 key-file        ( wfileid -- n )                gforth  paren_key_file  key-file        ( wfileid -- n )                gforth  paren_key_file
 #ifdef HAS_FILE  #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
Line 1481 
Line 1586 
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE(c_addr,u);
   
 (bye)   ( n -- )        gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
   SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  peren_system  (system)        ( c_addr u -- wretval wior )    gforth  paren_system
 #ifndef MSDOS  #ifndef MSDOS
 int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
 deprep_terminal();  deprep_terminal();
Line 1505 
Line 1611 
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
 wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
Line 1515 
Line 1621 
 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
 ""Report the current time of day. Seconds, minutes and hours are numbered from 0.  ""Report the current time of day. Seconds, minutes and hours are numbered from 0.
 Months are numbered from 1.""  Months are numbered from 1.""
   #if 1
   time_t now;
   struct tm *ltime;
   time(&now);
   ltime=localtime(&now);
   #else
 struct timeval time1;  struct timeval time1;
 struct timezone zone1;  struct timezone zone1;
 struct tm *ltime;  struct tm *ltime;
Line 1522 
Line 1634 
 /* !! Single Unix specification:  /* !! Single Unix specification:
    If tzp is not a null pointer, the behaviour is unspecified. */     If tzp is not a null pointer, the behaviour is unspecified. */
 ltime=localtime((time_t *)&time1.tv_sec);  ltime=localtime((time_t *)&time1.tv_sec);
   #endif
 nyear =ltime->tm_year+1900;  nyear =ltime->tm_year+1900;
 nmonth=ltime->tm_mon+1;  nmonth=ltime->tm_mon+1;
 nday  =ltime->tm_mday;  nday  =ltime->tm_mday;
Line 1575 
Line 1688 
 u = strlen(c_addr);  u = strlen(c_addr);
   
 strsignal       ( n -- c_addr u )       gforth  strsignal       ( n -- c_addr u )       gforth
 c_addr = strsignal(n);  c_addr = (Address)strsignal(n);
 u = strlen(c_addr);  u = strlen(c_addr);
   
 call-c  ( w -- )        gforth  call_c  call-c  ( w -- )        gforth  call_c
Line 1584 
Line 1697 
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{FP}.""
 /* This is a first attempt at support for calls to C. This may change in  /* This is a first attempt at support for calls to C. This may change in
    the future */     the future */
 IF_FTOS(fp[0]=FTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 SP=sp;  SP=sp;
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  sp=SP;
 fp=FP;  fp=FP;
 IF_TOS(TOS=sp[0]);  IF_spTOS(spTOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+  \+
 \+file  \+file
Line 1619 
Line 1732 
   
 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
 ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""  ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
 char *s1=tilde_cstr(c_addr2, u2, 1);  wior = rename_file(c_addr1, u1, c_addr2, u2);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);  
   
 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 = LONG2UD(ftell((FILE *)wfileid));  ud = OFF2UD(ftello((FILE *)wfileid));
 wior = IOR(UD2LONG(ud)==-1);  wior = IOR(UD2OFF(ud)==-1);
   
 reposition-file ( ud wfileid -- wior )  file    reposition_file  reposition-file ( ud wfileid -- wior )  file    reposition_file
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);  wior = IOR(fseeko((FILE *)wfileid, UD2OFF(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 = LONG2UD(buf.st_size);  ud = OFF2UD(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), UD2LONG(ud))==-1);  wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(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 1646 
Line 1758 
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 read-line       ( c_addr u1 wfileid -- u2 flag wior )   file    read_line  (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior ) file   paren_read_line
 #if 1  struct Cellquad r = read_line(c_addr, u1, wfileid);
 Cell c;  u2   = r.n1;
 flag=-1;  flag = r.n2;
 for(u2=0; u2<u1; u2++)  u3   = r.n3;
 {  wior = r.n4;
    c = getc((FILE *)wfileid);  
    if (c=='\n') break;  
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  
        ungetc(c,(FILE *)wfileid);  
      break;  
    }  
    if (c==EOF) {  
         flag=FLAG(u2!=0);  
         break;  
      }  
    c_addr[u2] = (Char)c;  
 }  
 wior=FILEIO(ferror((FILE *)wfileid));  
 #else  
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {  
   wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */  
   if (wior)  
     clearerr((FILE *)wfileid);  
   u2 = strlen(c_addr);  
   u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));  
 }  
 else {  
   wior=0;  
   u2=0;  
 }  
 #endif  
   
 \+  \+
   
Line 1711 
Line 1795 
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 file-status     ( c_addr u -- wfam wior )       file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
 char *filename=tilde_cstr(c_addr, u, 1);  struct Cellpair r = file_status(c_addr, u);
 if (access (filename, F_OK) != 0) {  wfam = r.n1;
   wfam=0;  wior = r.n2;
   wior=IOR(1);  
 }  file-eof?       ( wfileid -- flag )     gforth  file_eof_query
 else if (access (filename, R_OK | W_OK) == 0) {  flag = FLAG(feof((FILE *) wfileid));
   wfam=2; /* r/w */  
   wior=0;  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
 }  ""Open the directory specified by @i{c-addr, u}
 else if (access (filename, R_OK) == 0) {  and return @i{dir-id} for futher access to it.""
   wfam=0; /* r/o */  wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));
   wior=0;  wior =  IOR(wdirid == 0);
 }  
 else if (access (filename, W_OK) == 0) {  read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
   wfam=4; /* w/o */  ""Attempt to read the next entry from the directory specified
   by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}.
   If the attempt fails because there is no more entries,
   @i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified.
   If the attempt to read the next entry fails because of any other reason,
   return @i{ior}<>0.
   If the attempt succeeds, store file name to the buffer at @i{c-addr}
   and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name.
   If the length of the file name is greater than @i{u1},
   store first @i{u1} characters from file name into the buffer and
   indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}.""
   struct dirent * dent;
   dent = readdir((DIR *)wdirid);
   wior=0;    wior=0;
   flag = -1;
   if(dent == NULL) {
     u2 = 0;
     flag = 0;
   } else {
     u2 = strlen(dent->d_name);
     if(u2 > u1) {
       u2 = u1;
       wior = -512-ENAMETOOLONG;
 }  }
 else {    memmove(c_addr, dent->d_name, u2);
   wfam=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;  
 }  }
   
 \+  close-dir       ( wdirid -- wior )      gforth  close_dir
 \+floating  ""Close the directory specified by @i{dir-id}.""
   wior = IOR(closedir((DIR *)wdirid));
   
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)  filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)  char * string = cstr(c_addr1, u1, 1);
   char * pattern = cstr(c_addr2, u2, 0);
   flag = FLAG(!fnmatch(pattern, string, 0));
   
 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;  
 #endif  
   
 f>d     ( r -- d )              float   f_to_d  newline ( -- c_addr u ) gforth
 #ifdef BUGGY_LONG_LONG  ""String containing the newline sequence of the host OS""
 d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);  char newline[] = {
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  #if DIRSEP=='/'
 #else  /* Unix */
 d = r;  '\n'
   #else
   /* DOS, Win, OS/2 */
   '\r','\n'
   #endif
   };
   c_addr=newline;
   u=sizeof(newline);
   :
    "newline count ;
   Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
   
   \+os
   
   utime   ( -- dtime )    gforth
   ""Report the current time in microseconds since some epoch.""
   struct timeval time1;
   gettimeofday(&time1,NULL);
   dtime = timeval2us(&time1);
   
   cputime ( -- duser dsystem ) gforth
   ""duser and dsystem are the respective user- and system-level CPU
   times used since the start of the Forth system (excluding child
   processes), in microseconds (the granularity may be much larger,
   however).  On platforms without the getrusage call, it reports elapsed
   time (since some epoch) for duser and 0 for dsystem.""
   #ifdef HAVE_GETRUSAGE
   struct rusage usage;
   getrusage(RUSAGE_SELF, &usage);
   duser = timeval2us(&usage.ru_utime);
   dsystem = timeval2us(&usage.ru_stime);
   #else
   struct timeval time1;
   gettimeofday(&time1,NULL);
   duser = timeval2us(&time1);
   #ifndef BUGGY_LONG_LONG
   dsystem = (DCell)0;
   #else
   dsystem=(DCell){0,0};
   #endif
   #endif
   
   \+
   
   \+floating
   
   \g floating
   
   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
   #ifdef BUGGY_LONG_LONG
   extern double ldexp(double x, int exp);
   if (d.hi<0) {
     DCell d2=dnegate(d);
     r = -(ldexp((Float)d2.hi,CELL_BITS) + (Float)d2.lo);
   } else
     r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;
   #else
   r = d;
 #endif  #endif
   
   f>d     ( r -- d )              float   f_to_d
   extern DCell double2ll(Float r);
   d = double2ll(r);
   
 f!      ( r f_addr -- ) float   f_store  f!      ( r f_addr -- ) float   f_store
 ""Store @i{r} into the float at address @i{f-addr}.""  ""Store @i{r} into the float at address @i{f-addr}.""
 *f_addr = r;  *f_addr = r;
Line 1844 
Line 2007 
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 fround  ( r1 -- r2 )    float   f_round  fround  ( r1 -- r2 )    gforth  f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
 /* !! unclear wording */  
 #ifdef HAVE_RINT  
 r2 = rint(r1);  r2 = rint(r1);
 #else  
 r2 = floor(r1+0.5);  
 /* !! This is not quite true to the rounding rules given in the standard */  
 #endif  
   
 fmax    ( r1 r2 -- r3 ) float   f_max  fmax    ( r1 r2 -- r3 ) float   f_max
 if (r1<r2)  if (r1<r2)
Line 1868 
Line 2025 
   
 represent       ( r c_addr u -- n f1 f2 )       float  represent       ( r c_addr u -- n f1 f2 )       float
 char *sig;  char *sig;
   size_t siglen;
 int flag;  int flag;
 int decpt;  int decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &flag);
 n=(r==0 ? 1 : decpt);  n=(r==0. ? 1 : decpt);
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit((unsigned)(sig[0]))!=0);  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);  siglen=strlen(sig);
   if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */
     siglen=u;
   memcpy(c_addr,sig,siglen);
   memset(c_addr+siglen,f2?'0':' ',u-siglen);
   
 >float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- flag )    float   to_float
 ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
Line 1883 
Line 2045 
 @i{r} is placed on the floating-point stack and @i{flag} is  @i{r} is placed on the floating-point stack and @i{flag} is
 true. Otherwise, @i{flag} is false. A string of blanks is a special  true. Otherwise, @i{flag} is false. A string of blanks is a special
 case and represents the floating-point number 0.""  case and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */  
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  flag = to_float(c_addr, u, &r);
 char *endconv;  if (flag) {
 int sign = 0;    IF_fpTOS(fp[0] = fpTOS);
 if(number[0]=='-') {  
    sign = 1;  
    number++;  
    u--;  
 }  
 while(isspace((unsigned)(number[--u])) && u>0);  
 switch(number[u])  
 {  
    case 'd':  
    case 'D':  
    case 'e':  
    case 'E':  break;  
    default :  u++; break;  
 }  
 number[u]='\0';  
 r=strtod(number,&endconv);  
 if((flag=FLAG(!(Cell)*endconv)))  
 {  
    IF_FTOS(fp[0] = FTOS);  
    fp += -1;     fp += -1;
    FTOS = sign ? -r : r;    fpTOS = r;
 }  
 else if(*endconv=='d' || *endconv=='D')  
 {  
    *endconv='E';  
    r=strtod(number,&endconv);  
    if((flag=FLAG(!(Cell)*endconv)))  
      {  
         IF_FTOS(fp[0] = FTOS);  
         fp += -1;  
         FTOS = sign ? -r : r;  
      }  
 }  }
   
 fabs    ( r1 -- r2 )    float-ext       f_abs  fabs    ( r1 -- r2 )    float-ext       f_abs
Line 2054 
Line 2185 
 :  :
  [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;   [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ;
   
   v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
   ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the
   next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
   ucount elements.""
   r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount);
   :
    >r swap 2swap swap 0e r> 0 ?DO
        dup f@ over + 2swap dup f@ f* f+ over + 2swap
    LOOP 2drop 2drop ;
   
   faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
   ""vy=ra*vx+vy""
   faxpy(ra, f_x, nstridex, f_y, nstridey, ucount);
   :
    >r swap 2swap swap r> 0 ?DO
        fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
    LOOP 2drop 2drop fdrop ;
   
   \+
   
 \ The following words access machine/OS/installation-dependent  \ The following words access machine/OS/installation-dependent
 \   Gforth internals  \   Gforth internals
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+  
 \+glocals  \+glocals
   
 @local# ( -- w )        gforth  fetch_local_number  \g locals
 w = *(Cell *)(lp+(Cell)NEXT_INST);  
 INC_IP(1);  @local# ( #noffset -- w )       gforth  fetch_local_number
   w = *(Cell *)(lp+noffset);
   
 @local0 ( -- w )        new     fetch_local_zero  @local0 ( -- w )        new     fetch_local_zero
 w = *(Cell *)(lp+0*sizeof(Cell));  w = ((Cell *)lp)[0];
   
 @local1 ( -- w )        new     fetch_local_four  @local1 ( -- w )        new     fetch_local_four
 w = *(Cell *)(lp+1*sizeof(Cell));  w = ((Cell *)lp)[1];
   
 @local2 ( -- w )        new     fetch_local_eight  @local2 ( -- w )        new     fetch_local_eight
 w = *(Cell *)(lp+2*sizeof(Cell));  w = ((Cell *)lp)[2];
   
 @local3 ( -- w )        new     fetch_local_twelve  @local3 ( -- w )        new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = ((Cell *)lp)[3];
   
 \+floating  \+floating
   
 f@local#        ( -- r )        gforth  f_fetch_local_number  f@local#        ( #noffset -- r )       gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+noffset);
 INC_IP(1);  
   
 f@local0        ( -- r )        new     f_fetch_local_zero  f@local0        ( -- r )        new     f_fetch_local_zero
 r = *(Float *)(lp+0*sizeof(Float));  r = ((Float *)lp)[0];
   
 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];
   
 \+  \+
   
 laddr#  ( -- c_addr )   gforth  laddr_number  laddr#  ( #noffset -- 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+noffset);
 INC_IP(1);  
   
 lp+!#   ( -- )  gforth  lp_plus_store_number  lp+!#   ( #noffset -- ) 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""
 lp += (Cell)NEXT_INST;  lp += noffset;
 INC_IP(1);  
   
 lp-     ( -- )  new     minus_four_lp_plus_store  lp-     ( -- )  new     minus_four_lp_plus_store
 lp += -sizeof(Cell);  lp += -sizeof(Cell);
Line 2138 
Line 2287 
   
 \+OS  \+OS
   
   \g syslib
   
   open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   #ifndef RTLD_GLOBAL
   #define RTLD_GLOBAL 0
   #endif
   u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
   #else
   #  ifdef _WIN32
   u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
   #  else
   #warning Define open-lib!
   u2 = 0;
   #  endif
   #endif
   
   lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
   #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
   #else
   #  ifdef _WIN32
   u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
   #  else
   #warning Define lib-sym!
   u3 = 0;
   #  endif
   #endif
   
   wcall   ( u -- )        gforth
   IF_fpTOS(fp[0]=fpTOS);
   FP=fp;
   sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);
   fp=FP;
   IF_spTOS(spTOS=sp[0];)
   IF_fpTOS(fpTOS=fp[0]);
   
   \+FFCALL
   
   av-start-void   ( c_addr -- )   gforth  av_start_void
   av_start_void(alist, c_addr);
   
   av-start-int    ( c_addr -- )   gforth  av_start_int
   av_start_int(alist, c_addr, &irv);
   
   av-start-float  ( c_addr -- )   gforth  av_start_float
   av_start_float(alist, c_addr, &frv);
   
   av-start-double ( c_addr -- )   gforth  av_start_double
   av_start_double(alist, c_addr, &drv);
   
   av-start-longlong       ( c_addr -- )   gforth  av_start_longlong
   av_start_longlong(alist, c_addr, &llrv);
   
   av-start-ptr    ( c_addr -- )   gforth  av_start_ptr
   av_start_ptr(alist, c_addr, void*, &prv);
   
   av-int  ( w -- )  gforth  av_int
   av_int(alist, w);
   
   av-float        ( r -- )        gforth  av_float
   av_float(alist, r);
   
   av-double       ( r -- )        gforth  av_double
   av_double(alist, r);
   
   av-longlong     ( d -- )        gforth  av_longlong
   #ifdef BUGGY_LONG_LONG
   av_longlong(alist, d.lo);
   #else
   av_longlong(alist, d);
   #endif
   
   av-ptr  ( c_addr -- )   gforth  av_ptr
   av_ptr(alist, void*, c_addr);
   
   av-int-r  ( R:w -- )  gforth  av_int_r
   av_int(alist, w);
   
   av-float-r      ( -- )  gforth  av_float_r
   float r = *(Float*)lp;
   lp += sizeof(Float);
   av_float(alist, r);
   
   av-double-r     ( -- )  gforth  av_double_r
   double r = *(Float*)lp;
   lp += sizeof(Float);
   av_double(alist, r);
   
   av-longlong-r   ( R:d -- )      gforth  av_longlong_r
   #ifdef BUGGY_LONG_LONG
   av_longlong(alist, d.lo);
   #else
   av_longlong(alist, d);
   #endif
   
   av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r
   av_ptr(alist, void*, c_addr);
   
   av-call-void    ( -- )  gforth  av_call_void
   SAVE_REGS
   av_call(alist);
   REST_REGS
   
   av-call-int     ( -- w )        gforth  av_call_int
   SAVE_REGS
   av_call(alist);
   REST_REGS
   w = irv;
   
   av-call-float   ( -- r )        gforth  av_call_float
   SAVE_REGS
   av_call(alist);
   REST_REGS
   r = frv;
   
   av-call-double  ( -- r )        gforth  av_call_double
   SAVE_REGS
   av_call(alist);
   REST_REGS
   r = drv;
   
   av-call-longlong        ( -- d )        gforth  av_call_longlong
   SAVE_REGS
   av_call(alist);
   REST_REGS
   #ifdef BUGGY_LONG_LONG
   d.lo = llrv;
   d.hi = 0;
   #else
   d = llrv;
   #endif
   
   av-call-ptr     ( -- c_addr )   gforth  av_call_ptr
   SAVE_REGS
   av_call(alist);
   REST_REGS
   c_addr = prv;
   
   alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback
   c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);
   
   va-start-void   ( -- )  gforth  va_start_void
   va_start_void(clist);
   
   va-start-int    ( -- )  gforth  va_start_int
   va_start_int(clist);
   
   va-start-longlong       ( -- )  gforth  va_start_longlong
   va_start_longlong(clist);
   
   va-start-ptr    ( -- )  gforth  va_start_ptr
   va_start_ptr(clist, (char *));
   
   va-start-float  ( -- )  gforth  va_start_float
   va_start_float(clist);
   
   va-start-double ( -- )  gforth  va_start_double
   va_start_double(clist);
   
   va-arg-int      ( -- w )        gforth  va_arg_int
   w = va_arg_int(clist);
   
   va-arg-longlong ( -- d )        gforth  va_arg_longlong
   #ifdef BUGGY_LONG_LONG
   d.lo = va_arg_longlong(clist);
   d.hi = 0;
   #else
   d = va_arg_longlong(clist);
   #endif
   
   va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr
   c_addr = (char *)va_arg_ptr(clist,char*);
   
   va-arg-float    ( -- r )        gforth  va_arg_float
   r = va_arg_float(clist);
   
   va-arg-double   ( -- r )        gforth  va_arg_double
   r = va_arg_double(clist);
   
   va-return-void ( -- )   gforth va_return_void
   va_return_void(clist);
   return 0;
   
   va-return-int ( w -- )  gforth va_return_int
   va_return_int(clist, w);
   return 0;
   
   va-return-ptr ( c_addr -- )     gforth va_return_ptr
   va_return_ptr(clist, void *, c_addr);
   return 0;
   
   va-return-longlong ( d -- )     gforth va_return_longlong
   #ifdef BUGGY_LONG_LONG
   va_return_longlong(clist, d.lo);
   #else
   va_return_longlong(clist, d);
   #endif
   return 0;
   
   va-return-float ( r -- )        gforth va_return_float
   va_return_float(clist, r);
   return 0;
   
   va-return-double ( r -- )       gforth va_return_double
   va_return_double(clist, r);
   return 0;
   
   \+
   
   \+OLDCALL
   
 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')')
 define(`_uploop',  define(`_uploop',
Line 2169 
Line 2530 
   
 \ close ' to keep fontify happy  \ close ' to keep fontify happy
   
 open-lib        ( c_addr1 u1 -- u2 )    gforth  open_lib  
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 #ifndef RTLD_GLOBAL  
 #define RTLD_GLOBAL 0  
 #endif  
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  
 #else  
 #  ifdef _WIN32  
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define open-lib!  
 u2 = 0;  
 #  endif  
 #endif  
   
 lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym  
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  
 #else  
 #  ifdef _WIN32  
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define lib-sym!  
 u3 = 0;  
 #  endif  
 #endif  
   
 uploop(i, 0, 7, `icall(i)')  uploop(i, 0, 7, `icall(i)')
 icall(20)  icall(20)
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+  \+
   \+
   
 up!     ( a_addr -- )   gforth  up_store  \g peephole
 UP=up=(char *)a_addr;  
 :  
  up ! ;  
 Variable UP  
   
 wcall   ( u -- )        gforth  
 IF_FTOS(fp[0]=FTOS);  
 FP=fp;  
 sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);  
 fp=FP;  
 IF_TOS(TOS=sp[0];)  
 IF_FTOS(FTOS=fp[0]);  
   
 \+file  \+peephole
   
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  compile-prim1 ( a_prim -- ) gforth compile_prim1
 wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));  ""compile prim (incl. immargs) at @var{a_prim}""
 wior =  IOR(wdirid == 0);  compile_prim1(a_prim);
   
 read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir  finish-code ( -- ) gforth finish_code
 struct dirent * dent;  ""Perform delayed steps in code generation (branch resolution, I-cache
 dent = readdir((DIR *)wdirid);  flushing).""
 wior = 0;  IF_spTOS(sp[0]=spTOS); /* workaround for failing to save spTOS
 flag = -1;                            (gcc-2.95.1, gforth-fast --enable-force-reg) */
 if(dent == NULL) {  finish_code();
   u2 = 0;  IF_spTOS(spTOS=sp[0]);
   flag = 0;  
 } else {  
   u2 = strlen(dent->d_name);  
   if(u2 > u1)  
     u2 = u1;  
   memmove(c_addr, dent->d_name, u2);  
 }  
   
 close-dir       ( wdirid -- wior )      gforth  close_dir  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 wior = IOR(closedir((DIR *)wdirid));  f = forget_dyncode(c_code);
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
 char * string = cstr(c_addr1, u1, 1);  ""a_prim is the code address of the primitive that has been
 char * pattern = cstr(c_addr2, u2, 0);  compile_prim1ed to a_code""
 flag = FLAG(!fnmatch(pattern, string, 0));  a_prim = (Cell *)decompile_code((Label)a_code);
   
 \+  \ set-next-code and call2 do not appear in images and can be
   \ renumbered arbitrarily
   
 newline ( -- c_addr u ) gforth  set-next-code ( #w -- ) gforth set_next_code
 ""String containing the newline sequence of the host OS""  #ifdef NO_IP
 char newline[] = {  next_code = (Label)w;
 #ifdef unix  
 '\n'  
 #else  
 '\r','\n'  
 #endif  #endif
 };  
 c_addr=newline;  
 u=sizeof(newline);  
 :  
  "newline count ;  
 Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,  
   
 \+os  
   
 utime   ( -- dtime )    gforth  
 ""Report the current time in microseconds since some epoch.""  
 struct timeval time1;  
 gettimeofday(&time1,NULL);  
 dtime = timeval2us(&time1);  
   
 cputime ( -- duser dsystem ) gforth  call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth
 ""duser and dsystem are the respective user- and system-level CPU  /* call with explicit return address */
 times used since the start of the Forth system (excluding child  #ifdef NO_IP
 processes), in microseconds (the granularity may be much larger,  INST_TAIL;
 however).  On platforms without the getrusage call, it reports elapsed  JUMP(a_callee);
 time (since some epoch) for duser and 0 for dsystem.""  
 #ifdef HAVE_GETRUSAGE  
 struct rusage usage;  
 getrusage(RUSAGE_SELF, &usage);  
 duser = timeval2us(&usage.ru_utime);  
 dsystem = timeval2us(&usage.ru_stime);  
 #else  #else
 struct timeval time1;  assert(0);
 gettimeofday(&time1,NULL);  
 duser = timeval2us(&time1);  
 dsystem = (DCell)0;  
 #endif  #endif
   
 \+  tag-offsets ( -- a_addr ) gforth tag_offsets
   extern Cell groups[32];
   a_addr = groups;
   
 \+floating  \+
   
 v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star  \g static_super
 ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the  
 next at f_addr1+nstride1 and so on (similar for v2). Both vectors have  
 ucount elements.""  
 for (r=0.; ucount>0; ucount--) {  
   r += *f_addr1 * *f_addr2;  
   f_addr1 = (Float *)(((Address)f_addr1)+nstride1);  
   f_addr2 = (Float *)(((Address)f_addr2)+nstride2);  
 }  
 :  
  >r swap 2swap swap 0e r> 0 ?DO  
      dup f@ over + 2swap dup f@ f* f+ over + 2swap  
  LOOP 2drop 2drop ;  
   
 faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth  ifdef(`M4_ENGINE_FAST',
 ""vy=ra*vx+vy""  `include(peeprules.vmg)')
 for (; ucount>0; ucount--) {  
   *f_y += ra * *f_x;  
   f_x = (Float *)(((Address)f_x)+nstridex);  
   f_y = (Float *)(((Address)f_y)+nstridey);  
 }  
 :  
  >r swap 2swap swap r> 0 ?DO  
      fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap  
  LOOP 2drop 2drop fdrop ;  
   
 \+  \g end

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help