Diff for /gforth/prim between versions 1.114 and 1.140

version 1.114, 2003/01/07 22:38:36 version 1.140, 2003/08/20 13:29:19
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000 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 106 Line 106
 \E set-current  \E set-current
 \E store-optimization on  \E store-optimization on
 \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump  \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 137  undefine(`index') Line 141  undefine(`index')
 undefine(`shift')  undefine(`shift')
 undefine(`symbols')  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""
   a_retaddr = (Cell *)ip;
   SET_IP((Xt *)PFA(CFA));
   
   (docon) ( -- w )        gforth-internal paren_docon
   ""run-time routine for constants""
   w = *(Cell *)PFA(CFA);
   
   (dovar) ( -- a_body )   gforth-internal paren_dovar
   ""run-time routine for variables and CREATEd words""
   a_body = PFA(CFA);
   
   (douser) ( -- a_user )  gforth-internal paren_douser
   ""run-time routine for constants""
   a_user = (Cell *)(up+*(Cell *)PFA(CFA));
   
   (dodefer) ( -- )        gforth-internal paren_dodefer
   ""run-time routine for deferred words""
   SUPER_END;
   EXEC(*(Xt *)PFA(CFA));
   
   (dofield) ( n1 -- n2 )  gforth-internal paren_field
   ""run-time routine for fields""
   n2 = n1 + *(Cell *)PFA(CFA);
   
   (dodoes) ( -- a_body R:a_retaddr )      gforth-internal paren_dodoes
   ""run-time routine for @code{does>}-defined words""
   a_retaddr = (Cell *)ip;
   a_body = PFA(CFA);
   SET_IP(DOES_CODE1(CFA));
   
   (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  \g control
   
 noop    ( -- )          gforth  noop    ( -- )          gforth
Line 557  cmove ( c_from c_to u -- ) string c_move Line 604  cmove ( c_from c_to u -- ) string c_move
 @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 567  cmove> ( c_from c_to u -- ) string c_mov Line 613  cmove> ( c_from c_to u -- ) string c_mov
 @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 588  is 1. Currently this is based on the mac Line 633  is 1. Currently this is based on the mac
 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 )  : sgn ( n -- -1/0/1 )
  dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;
   
 -text   ( c_addr1 u c_addr2 -- n )      new     dash_text  \ -text is only used by replaced primitives now; move it elsewhere
 n = memcmp(c_addr1, c_addr2, u);  \ -text ( c_addr1 u c_addr2 -- n )      new     dash_text
 if (n<0)  \ n = memcmp(c_addr1, c_addr2, u);
   n = -1;  \ if (n<0)
 else if (n>0)  \   n = -1;
   n = 1;  \ else if (n>0)
 :  \   n = 1;
  swap bounds  \ :
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0  \  swap bounds
  ELSE  c@ I c@ - unloop  THEN  sgn ;  \  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
 : sgn ( n -- -1/0/1 )  \  ELSE  c@ I c@ - unloop  THEN  sgn ;
  dup 0= IF EXIT THEN  0< 2* 1+ ;  \ : 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}
Line 621  c2 = toupper(c1); Line 661  c2 = toupper(c1);
 :  :
  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 819  ud = ummul(u1,u2); Line 836  ud = ummul(u1,u2);
 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 1110  rdrop ( R:w -- )  gforth Line 1126  rdrop ( R:w -- )  gforth
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     ( w1 w2 -- R:w1 R:w2 )  core-ext        two_to_r  2>r     ( d -- R:d )    core-ext        two_to_r
 :  :
  swap r> swap >r swap >r >r ;   swap r> swap >r swap >r >r ;
   
 2r>     ( R:w1 R:w2 -- w1 w2 )  core-ext        two_r_from  2r>     ( R:d -- d )    core-ext        two_r_from
 :  :
  r> r> swap r> swap >r swap ;   r> r> swap r> swap >r swap ;
   
 2r@     ( R:w1 R:w2 -- R:w1 R:w2 w1 w2 )        core-ext        two_r_fetch  2r@     ( R:d -- R:d d )        core-ext        two_r_fetch
 :  :
  i' j ;   i' j ;
   
 2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop  2rdrop  ( R:d -- )              gforth  two_r_drop
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1342  c_addr2 = c_addr1+1; Line 1358  c_addr2 = c_addr1+1;
   
 \g compiler  \g compiler
   
 (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind  \+f83headerstring
 for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))  
   if ((UCell)LONGNAME_COUNT(longname1)==u &&  (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find
       memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
     if ((UCell)F83NAME_COUNT(f83name1)==u &&
         memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
 longname2=longname1;  f83name2=f83name1;
   :
       BEGIN  dup WHILE  (find-samelen)  dup  WHILE
           >r 2dup r@ cell+ char+ capscomp  0=
           IF  2drop r>  EXIT  THEN
           r> @
       REPEAT  THEN  nip nip ;
   : (find-samelen) ( u f83name1 -- u f83name2/0 )
       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      BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
         >r 2dup r@ cell+ cell+ capscomp  0=          >r 2dup r@ cell+ cell+ capscomp  0=
Line 1360  longname2=longname1; Line 1399  longname2=longname1;
 \+hash  \+hash
   
 (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind  (hashlfind)     ( c_addr u a_addr -- longname2 )        new     paren_hashlfind
 struct Longname *longname1;  longname2 = hashlfind(c_addr, u, a_addr);
 longname2=NULL;  
 while(a_addr != NULL)  
 {  
    longname1=(struct Longname *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)LONGNAME_COUNT(longname1)==u &&  
        memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)  
      {  
         longname2=longname1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ @ lcount-mask and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
Line 1383  while(a_addr != NULL) Line 1410  while(a_addr != NULL)
   
 (tablelfind)    ( c_addr u a_addr -- longname2 )        new     paren_tablelfind  (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 Longname *longname1;  longname2 = tablelfind(c_addr, u, a_addr);
 longname2=NULL;  
 while(a_addr != NULL)  
 {  
    longname1=(struct Longname *)(a_addr[1]);  
    a_addr=(Cell *)(a_addr[0]);  
    if ((UCell)LONGNAME_COUNT(longname1)==u &&  
        memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)  
      {  
         longname2=longname1;  
         break;  
      }  
 }  
 :  :
  BEGIN  dup  WHILE   BEGIN  dup  WHILE
         2@ >r >r dup r@ cell+ @ lcount-mask and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
Line 1403  while(a_addr != NULL) Line 1418  while(a_addr != NULL)
             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.  
 */  
 static char rot_values[] = {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};  
 unsigned rot = rot_values[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 1441  Create rot-values Line 1443  Create rot-values
   
 \+  \+
   
   \+
   
 (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 1473  f_addr = (Float *)((((Cell)c_addr)+(size Line 1467  f_addr = (Float *)((((Cell)c_addr)+(size
 :  :
  [ 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 child of a @code{DOES>} 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);  
 :  
     ! ;  
   
 does-code!      ( a_addr xt -- )                gforth  does_code_store  
 ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;  
 @i{a-addr} is the start of the Forth code after @code{DOES>}.""  
 MAKE_DOES_CF(xt, a_addr);  
 :  
     dodoes: over ! cell+ ! ;  
   
 does-handler!   ( a_addr -- )   gforth  does_handler_store  
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,  
 @i{a-addr} points just behind a @code{DOES>}.""  
 MAKE_DOES_HANDLER(a_addr);  
 :  
     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 1595  FLUSH_ICACHE(c_addr,u); Line 1539  FLUSH_ICACHE(c_addr,u);
 SUPER_END;  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 1627  wior = IOR(wretval==-1); Line 1571  wior = IOR(wretval==-1);
 time&date       ( -- nsec nmin nhour nday nmonth nyear )        facility-ext    time_and_date  time&date       ( -- nsec nmin nhour nday nmonth nyear )        facility-ext    time_and_date
 ""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 1634  gettimeofday(&time1,&zone1); Line 1584  gettimeofday(&time1,&zone1);
 /* !! 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 1687  c_addr = strerror(n); Line 1638  c_addr = strerror(n);
 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 1731  wior = IOR(unlink(tilde_cstr(c_addr, u, Line 1682  wior = IOR(unlink(tilde_cstr(c_addr, u,
   
 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? */
Line 1758  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1708  wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line  (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior ) file   paren_read_line
 Cell c;  struct Cellquad r = read_line(c_addr, u1, wfileid);
 flag=-1;  u2   = r.n1;
 u3=0;  flag = r.n2;
 for(u2=0; u2<u1; u2++)  u3   = r.n3;
 {  wior = r.n4;
    c = getc((FILE *)wfileid);  
    u3++;  
    if (c=='\n') break;  
    if (c=='\r') {  
      if ((c = getc((FILE *)wfileid))!='\n')  
        ungetc(c,(FILE *)wfileid);  
      else  
        u3++;  
      break;  
    }  
    if (c==EOF) {  
         flag=FLAG(u2!=0);  
         break;  
      }  
    c_addr[u2] = (Char)c;  
 }  
 wior=FILEIO(ferror((FILE *)wfileid));  
   
 \+  \+
   
Line 1812  flush-file ( wfileid -- wior )  file-ext Line 1745  flush-file ( wfileid -- wior )  file-ext
 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);  
 }  
 else if (access (filename, R_OK | W_OK) == 0) {  
   wfam=2; /* r/w */  
   wior=0;  
 }  
 else if (access (filename, R_OK) == 0) {  
   wfam=0; /* r/o */  
   wior=0;  
 }  
 else if (access (filename, W_OK) == 0) {  
   wfam=4; /* w/o */  
   wior=0;  
 }  
 else {  
   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;  
 }  
   
 file-eof?       ( wfileid -- flag )     gforth  file_eof_query  file-eof?       ( wfileid -- flag )     gforth  file_eof_query
 flag = FLAG(feof((FILE *) wfileid));  flag = FLAG(feof((FILE *) wfileid));
Line 1886  flag = FLAG(!fnmatch(pattern, string, 0) Line 1800  flag = FLAG(!fnmatch(pattern, string, 0)
 newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
 ""String containing the newline sequence of the host OS""  ""String containing the newline sequence of the host OS""
 char newline[] = {  char newline[] = {
 #if defined(unix) || defined(__MACH__)  #if DIRSEP=='/'
 /* Darwin/MacOS X sets __MACH__, but not unix. */  /* Unix */
 '\n'  '\n'
 #else  #else
   /* DOS, Win, OS/2 */
 '\r','\n'  '\r','\n'
 #endif  #endif
 };  };
Line 2060  else Line 1975  else
   
 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 2075  representation. If the string represents Line 1995  representation. If the string represents
 @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]=='-') {    fp += -1;
    sign = 1;    fpTOS = r;
    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_fpTOS(fp[0] = fpTOS);  
    fp += -1;  
    fpTOS = sign ? -r : r;  
 }  
 else if(*endconv=='d' || *endconv=='D')  
 {  
    *endconv='E';  
    r=strtod(number,&endconv);  
    if((flag=FLAG(!(Cell)*endconv)))  
      {  
         IF_fpTOS(fp[0] = fpTOS);  
         fp += -1;  
         fpTOS = sign ? -r : r;  
      }  
 }  }
   
 fabs    ( r1 -- r2 )    float-ext       f_abs  fabs    ( r1 -- r2 )    float-ext       f_abs
Line 2250  v* ( f_addr1 nstride1 f_addr2 nstride2 u Line 2139  v* ( f_addr1 nstride1 f_addr2 nstride2 u
 ""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the  ""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  next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
 ucount elements.""  ucount elements.""
 for (r=0.; ucount>0; ucount--) {  r = v_star(f_addr1, nstride1, f_addr2, nstride2, 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   >r swap 2swap swap 0e r> 0 ?DO
      dup f@ over + 2swap dup f@ f* f+ over + 2swap       dup f@ over + 2swap dup f@ f* f+ over + 2swap
Line 2262  for (r=0.; ucount>0; ucount--) { Line 2147  for (r=0.; ucount>0; ucount--) {
   
 faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth  faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
 ""vy=ra*vx+vy""  ""vy=ra*vx+vy""
 for (; ucount>0; ucount--) {  faxpy(ra, f_x, nstridex, f_y, nstridey, 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   >r swap 2swap swap r> 0 ?DO
      fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap       fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
Line 2358  r = fp[u+1]; /* +1, because update of fp Line 2239  r = fp[u+1]; /* +1, because update of fp
   
 \g syslib  \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
   
   \+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
   av_longlong(alist, d);
   
   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
   av_longlong(alist, d);
   
   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
   d = llrv;
   
   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
   d = va_arg_longlong(clist);
   
   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
   va_return_longlong(clist, d);
   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;
   
   \-
   
 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 2389  rret = (SYSCALL(Float(*)(argdlist($1)))u Line 2448  rret = (SYSCALL(Float(*)(argdlist($1)))u
   
 \ 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)
   
 \+  \+
   \+
   
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_fpTOS(fp[0]=fpTOS);  IF_fpTOS(fp[0]=fpTOS);
Line 2435  IF_fpTOS(fpTOS=fp[0]); Line 2468  IF_fpTOS(fpTOS=fp[0]);
   
 \g peephole  \g peephole
   
 primtable       ( -- wprimtable )       new  compile-prim1 ( a_prim -- ) gforth compile_prim1
 ""wprimtable is a table containing the xts of the primitives indexed  ""compile prim (incl. immargs) at @var{a_prim}""
 by sequence-number in prim (for use in prepare-peephole-table).""  compile_prim1(a_prim);
 wprimtable = (Cell)primtable(symbols+DOESJUMP+1,MAX_SYMBOLS-DOESJUMP-1);  
   
 prepare-peephole-table  ( wprimtable -- wpeeptable ) new prepare_peephole_opt  
 ""wpeeptable is a data structure used by @code{peephole-opt}; it is  
 constructed by combining a primitives table with a simple peephole  
 optimization table.""  
 wpeeptable = prepare_peephole_table((Xt *)wprimtable);  
   
 peephole-opt    ( xt1 xt2 wpeeptable -- xt )    new     peephole_opt  
 ""xt is the combination of xt1 and xt2 (according to wpeeptable); if  
 they cannot be combined, xt is 0.""  
 xt = peephole_opt(xt1, xt2, wpeeptable);  
   
 compile-prim ( xt1 -- xt2 )     obsolete        compile_prim  finish-code ( -- ) gforth finish_code
 xt2 = (Xt)compile_prim((Label)xt1);  ""Perform delayed steps in code generation (branch resolution, I-cache
   flushing).""
   finish_code();
   
   forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
   f = forget_dyncode(c_code);
   
   decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim
   ""a_prim is the code address of the primitive that has been
   compile_prim1ed to a_code""
   a_prim = (Cell *)decompile_code((Label)a_code);
   
 \ set-next-code and call2 do not appear in images and can be  \ set-next-code and call2 do not appear in images and can be
 \ renumbered arbitrarily  \ renumbered arbitrarily
Line 2471  JUMP(a_callee); Line 2502  JUMP(a_callee);
 assert(0);  assert(0);
 #endif  #endif
   
 compile-prim1 ( a_prim -- ) gforth compile_prim1  tag-offsets ( -- a_addr ) gforth tag_offsets
 ""compile prim (incl. immargs) at @var{a_prim}""  extern Cell groups[32];
 compile_prim1(a_prim);  a_addr = groups;
   
 finish-code ( -- ) gforth finish_code  \+
 ""Perform delayed steps in code generation (branch resolution, I-cache  
 flushing).""  
 finish_code();  
   
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode  
 f = forget_dyncode(c_code);  
   
 decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim  \g static_super
 ""a_prim is the code address of the primitive that has been  
 compile_prim1ed to a_code""  
 a_prim = (Label)decompile_code((Label)a_code);  
   
 \+  \C #if !defined(GFORTH_DEBUGGING) && !defined(INDIRECT_THREADED) && !defined(DOUBLY_INDIRECT) && !defined(VM_PROFILING)
   
 include(peeprules.vmg)  include(peeprules.vmg)
   
   \C #endif
   
 \g end  \g end

Removed from v.1.114  
changed lines
  Added in v.1.140


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>