--- gforth/engine/support.c	2007/04/22 22:04:28	1.25
+++ gforth/engine/support.c	2012/12/31 15:25:19	1.51
@@ -1,12 +1,12 @@
 /* Gforth support functions
 
-  Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006 Free Software Foundation, Inc.
+  Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
 
   This file is part of Gforth.
 
   Gforth is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License
-  as published by the Free Software Foundation; either version 2
+  as published by the Free Software Foundation, either version 3
   of the License, or (at your option) any later version.
 
   This program is distributed in the hope that it will be useful,
@@ -15,8 +15,7 @@
   GNU General Public License for more details.
 
   You should have received a copy of the GNU General Public License
-  along with this program; if not, write to the Free Software
-  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+  along with this program; if not, see http://www.gnu.org/licenses/.
 */
 
 #include "config.h"
@@ -27,47 +26,33 @@
 #include <sys/time.h>
 #include <unistd.h>
 #include <pwd.h>
+#include <assert.h>
 #ifndef STANDALONE
 #include <dirent.h>
 #include <math.h>
 #include <ctype.h>
 #include <errno.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <time.h>
+#endif
+#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
+#include <dlfcn.h>
 #endif
 
 #ifdef HAS_FILE
-char *cstr(Char *from, UCell size, int clear)
+char *cstr(Char *from, UCell size)
 /* return a C-string corresponding to the Forth string ( FROM SIZE ).
-   the C-string lives until the next call of cstr with CLEAR being true */
+   the C-string lives until free */
 {
-  static struct cstr_buffer {
-    char *buffer;
-    size_t size;
-  } *buffers=NULL;
-  static int nbuffers=0;
-  static int used=0;
-  struct cstr_buffer *b;
-
-  if (buffers==NULL)
-    buffers=malloc(0);
-  if (clear)
-    used=0;
-  if (used>=nbuffers) {
-    buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
-    buffers[used]=(struct cstr_buffer){malloc(0),0};
-    nbuffers=used+1;
-  }
-  b=&buffers[used];
-  if (size+1 > b->size) {
-    b->buffer = realloc(b->buffer,size+1);
-    b->size = size+1;
-  }
-  memcpy(b->buffer,from,size);
-  b->buffer[size]='\0';
-  used++;
-  return b->buffer;
+  char * string = malloc(size+1);
+  memcpy(string,from,size);
+  string[size]='\0';
+  return string;
 }
 
-char *tilde_cstr(Char *from, UCell size, int clear)
+char *tilde_cstr(Char *from, UCell size)
 /* like cstr(), but perform tilde expansion on the string */
 {
   char *s1,*s2;
@@ -75,7 +60,7 @@ char *tilde_cstr(Char *from, UCell size,
   struct passwd *getpwnam (), *user_entry;
 
   if (size<1 || from[0]!='~')
-    return cstr(from, size, clear);
+    return cstr(from, size);
   if (size<2 || from[1]=='/') {
     s1 = (char *)getenv ("HOME");
     if(s1 == NULL)
@@ -93,7 +78,7 @@ char *tilde_cstr(Char *from, UCell size,
     for (i=1; i<size && from[i]!='/'; i++)
       ;
     if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
-      return cstr(from+3, size<3?0:size-3,clear);
+      return cstr(from+3, size<3?0:size-3);
     {
       char user[i];
       memcpy(user,from+1,i-1);
@@ -101,7 +86,7 @@ char *tilde_cstr(Char *from, UCell size,
       user_entry=getpwnam(user);
     }
     if (user_entry==NULL)
-      return cstr(from, size, clear);
+      return cstr(from, size);
     s1 = user_entry->pw_dir;
     s2 = (char *)from+i;
     s2_len = size-i;
@@ -113,10 +98,25 @@ char *tilde_cstr(Char *from, UCell size,
     char path[s1_len+s2_len];
     memcpy(path,s1,s1_len);
     memcpy(path+s1_len,s2,s2_len);
-    return cstr((Char *)path,s1_len+s2_len,clear);
+    return cstr((Char *)path,s1_len+s2_len);
   }
 }
-#endif
+
+Cell opencreate_file(char *s, Cell wfam, int flags, Cell *wiorp)
+{
+  Cell fd;
+  Cell wfileid;
+  fd = open(s, flags|ufileattr[wfam], 0666);
+  if (fd != -1) {
+    wfileid = (Cell)fdopen(fd, fileattr[wfam]);
+    *wiorp = IOR(wfileid == 0);
+  } else {
+    wfileid = 0;
+    *wiorp = IOR(1);
+  }
+  return wfileid;
+}
+#endif /* defined(HAS_FILE) */
 
 DCell timeval2us(struct timeval *tvp)
 {
@@ -131,6 +131,19 @@ DCell timeval2us(struct timeval *tvp)
 #endif
 }
 
+DCell timespec2ns(struct timespec *tvp)
+{
+#ifndef BUGGY_LONG_LONG
+  return (tvp->tv_sec*(DCell)1000000000LL)+tvp->tv_nsec;
+#else
+  DCell d2;
+  DCell d1=mmul(tvp->tv_sec,1000000000);
+  d2.lo = d1.lo+tvp->tv_nsec;
+  d2.hi = d1.hi + (d2.lo<d1.lo);
+  return d2;
+#endif
+}
+
 DCell double2ll(Float r)
 {
 #ifndef BUGGY_LONG_LONG
@@ -287,11 +300,14 @@ struct Cellpair parse_white(Char *c_addr
 #ifdef HAS_FILE
 Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
 {
-  char *s1=tilde_cstr(c_addr2, u2, 1);
-  return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
+  char *s1=tilde_cstr(c_addr2, u2);
+  char *s2=tilde_cstr(c_addr1, u1);
+  return IOR(rename(s2, s1)==-1);
+  free(s1);
+  free(s2);
 }
 
-struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)
+struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid)
 {
   UCell u2, u3;
   Cell flag, wior;
@@ -300,13 +316,15 @@ struct Cellquad read_line(Char *c_addr,
 
   flag=-1;
   u3=0;
+  if (u1>0)
+    gf_regetc(wfileid);
   for(u2=0; u2<u1; u2++) {
-    c = getc((FILE *)wfileid);
+    c = getc(wfileid);
     u3++;
     if (c=='\n') break;
     if (c=='\r') {
-      if ((c = getc((FILE *)wfileid))!='\n')
-	ungetc(c,(FILE *)wfileid);
+      if ((c = getc(wfileid))!='\n')
+	gf_ungetc(c,wfileid);
       else
 	u3++;
       break;
@@ -317,7 +335,7 @@ struct Cellquad read_line(Char *c_addr,
     }
     c_addr[u2] = (Char)c;
   }
-  wior=FILEIO(ferror((FILE *)wfileid));
+  wior=FILEIO(ferror(wfileid));
   r.n1 = u2;
   r.n2 = flag;
   r.n3 = u3;
@@ -330,7 +348,7 @@ struct Cellpair file_status(Char *c_addr
   struct Cellpair r;
   Cell wfam;
   Cell wior;
-  char *filename=tilde_cstr(c_addr, u, 1);
+  char *filename=tilde_cstr(c_addr, u);
 
   if (access (filename, F_OK) != 0) {
     wfam=0;
@@ -356,56 +374,92 @@ struct Cellpair file_status(Char *c_addr
   }
   r.n1 = wfam;
   r.n2 = wior;
+  free(filename);
   return r;
 }
 
-Cell to_float(Char *c_addr, UCell u, Float *rp)
+Cell to_float(Char *c_addr, UCell u, Float *rp, Char dot)
 {
-  Float r;
-  Cell flag;
-  char *number=cstr(c_addr, u, 1);
+  /* convertible string := <significand>[<exponent>]
+     <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> }
+     <exponent>    := <marker><digits0>
+     <marker>      := {<e-form> | <sign-form>}
+     <e-form>      := <e-char>[<sign-form>]
+     <sign-form>   := { + | - }
+     <e-char>      := { D | d | E | e }
+  */
+  Char *s = c_addr;
+  Char c;
+  Char *send = c_addr+u;
+  UCell ndigits = 0;
+  UCell ndots = 0;
+  UCell edigits = 0;
+  char cnum[u+3]; /* append at most "e0\0" */
+  char *t=cnum;
   char *endconv;
-  int sign = 0;
-  if(number[0]==' ') {
-    UCell i;
-    for (i=1; i<u; i++)
-      if (number[i] != ' ')
-	return 0;
-    *rp = 0.0;
-    return -1;
-  }
-  if(number[0]=='-') {
-    sign = 1;
-    number++;
-    u--;
-    if (u==0)
-      return 0;
-  }
-  switch(number[u-1]) {
-  case 'd':
+  Float r;
+  
+  if (s >= send) /* treat empty string as 0e */
+    goto return0;
+  switch ((c=*s)) {
+  case ' ':
+    /* "A string of blanks should be treated as a special case
+       representing zero."*/
+    for (s++; s<send; )
+      if (*s++ != ' ')
+        goto error;
+    goto return0;
+  case '-':
+  case '+': *t++ = c; s++; goto aftersign;
+  }
+  aftersign: 
+  if (s >= send)
+    goto exponent;
+  if((c=*s)==dot) { *t++ = '.'; ndots++; s++; goto aftersign; }
+  switch (c) {
+  case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign;
+  default:                                    goto exponent;
+  }
+ exponent:
+  if (ndigits < 1 || ndots > 1)
+    goto error;
+  *t++ = 'E';
+  if (s >= send)
+    goto done;
+  switch (c=*s) {
   case 'D':
-  case 'e':
-  case 'E':  
-    u--;
-    break;
-  }
-  number[u]='\0';
-  r=strtod(number,&endconv);
-  flag=FLAG((*endconv)=='\0');
-  if(flag) {
-    if (sign)
-      r = -r;
-  } else if(*endconv=='d' || *endconv=='D') {
-    *endconv='E';
-    r=strtod(number,&endconv);
-    flag=FLAG((*endconv)=='\0');
-    if (flag) {
-      if (sign)
-	r = -r;
-    }
+  case 'd':
+  case 'E':
+  case 'e': s++; break;
   }
+  if (s >= send)
+    goto done;
+  switch (c=*s) {
+  case '+':
+  case '-': *t++ = c; s++; break;
+  }
+ edigits0:
+  if (s >= send)
+    goto done;
+  switch (c=*s) {
+  case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0;
+  default: goto error;
+  }
+ done:
+  if (edigits == 0)
+    *t++ = '0';
+  *t++ = '\0';
+  assert(t-cnum <= u+3);
+  r = strtod(cnum, &endconv);
+  assert(*endconv == '\0');
   *rp = r;
-  return flag;
+  return -1;
+ return0:
+  *rp = 0.0;
+  return -1;
+ error:
+  *rp = 0.0;
+  return 0;
 }
 #endif
 
@@ -449,8 +503,10 @@ int gforth_system(Char *c_addr, UCell u)
   char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX;
   size_t prefixlen = strlen(prefix);
   char buffer[prefixlen+u+1];
+  int MAYBE_UNUSED old_tp;
+  fflush(stdout);
 #ifndef MSDOS
-  int old_tp=terminal_prepped;
+  old_tp=terminal_prepped;
   deprep_terminal();
 #endif
   memcpy(buffer,prefix,prefixlen);
@@ -463,7 +519,48 @@ int gforth_system(Char *c_addr, UCell u)
 #endif
   return retval;
 }
+
+void gforth_ms(UCell u)
+{
+#ifdef HAVE_NANOSLEEP
+  struct timespec time_req;
+  time_req.tv_sec=u/1000;
+  time_req.tv_nsec=1000000*(u%1000);
+  while(nanosleep(&time_req, &time_req));
+#else /* !defined(HAVE_NANOSLEEP) */
+  struct timeval timeout;
+  timeout.tv_sec=u/1000;
+  timeout.tv_usec=1000*(u%1000);
+  (void)select(0,0,0,0,&timeout);
+#endif /* !defined(HAVE_NANOSLEEP) */
+}
+
+UCell gforth_dlopen(Char *c_addr, UCell u)
+{
+  char * file=tilde_cstr(c_addr, u);
+  UCell lib;
+#if defined(HAVE_LIBLTDL)
+  lib = (UCell)lt_dlopen(file);
+  free(file);
+  if(lib) return lib;
+#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
+#ifndef RTLD_GLOBAL
+#define RTLD_GLOBAL 0
+#endif
+  lib = (UCell)dlopen(file, RTLD_GLOBAL);
+  free(file);
+  if(lib) return lib;
+  fprintf(stderr, "%s\n", dlerror());
+#elif defined(_WIN32)
+  lib = (UCell) GetModuleHandle(file);
+  free(file);
+  if(lib) return lib;
 #endif
+  return 0;
+}
+
+#endif /* !defined(STANDALONE) */
+
 
 /* mixed division support; should usually be faster than gcc's
    double-by-double division (and gcc typically does not generate
@@ -493,6 +590,23 @@ typedef UDCell UDWtype;
 
 #include "longlong.h"
 
+
+#if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION
+
+#if defined(count_leading_zeros)
+const UQItype __clz_tab[256] =
+{
+  0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
+  6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
+  7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
+  7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
+  8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+  8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+  8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+  8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8
+};
+#endif
+
 static Cell MAYBE_UNUSED nlz(UCell x)
      /* number of leading zeros, adapted from "Hacker's Delight" */
 {
@@ -504,11 +618,12 @@ static Cell MAYBE_UNUSED nlz(UCell x)
 #if defined(count_leading_zeros)
    count_leading_zeros(n,x);
 #else
-#warning "count_leading_zeros undefined (should not happen)"
    n = 0;
 #if (SIZEOF_CHAR_P > 4)
-   if (x <= 0xffffffff) {n+=32; x <<= 32;}
-#error "this can't be correct"
+   if (x <= 0xffffffff) 
+     n+=32;
+   else
+     x >>= 32;
 #endif
    if (x <= 0x0000FFFF) {n = n +16; x = x <<16;}
    if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;}
@@ -518,6 +633,7 @@ static Cell MAYBE_UNUSED nlz(UCell x)
 #endif
    return n;
 }
+#endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/
 
 #if !defined(ASM_UM_SLASH_MOD)
 UDCell umdiv (UDCell u, UCell v)
@@ -525,7 +641,17 @@ UDCell umdiv (UDCell u, UCell v)
    Return quotient in lo, remainder in hi. */
 {
   UDCell res;
-#if defined(udiv_qrnnd)
+#if defined(udiv_qrnnd) && !defined(__alpha)
+#if 0
+   This code is slower on an Alpha (timings with gcc-3.3.5):
+          other     this
+   */      5205 ms  5741 ms 
+   */mod   5167 ms  5717 ms 
+   fm/mod  5467 ms  5312 ms 
+   sm/rem  4734 ms  5278 ms 
+   um/mod  4490 ms  5020 ms 
+   m*/    15557 ms 17151 ms
+#endif /* 0 */
   UCell q,r,u0,u1;
   UCell MAYBE_UNUSED lz;
   
@@ -545,12 +671,11 @@ UDCell umdiv (UDCell u, UCell v)
   r >>= lz;
 #endif
   vm_twoCell2ud(q,r,res);
-#else /* !(defined(udiv_qrnnd) */
-#warning "udiv_qrnnd undefined (should not happen)"
+#else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
   /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */
   int i = CELL_BITS, c = 0;
   UCell q = 0;
-  Ucell h, l;
+  UCell h, l;
 
   vm_ud2twoCell(u,l,h);
   if (v==0)
@@ -573,7 +698,7 @@ UDCell umdiv (UDCell u, UCell v)
       q <<= 1;
     }
   vm_twoCell2ud(q,h,res);
-#endif /* !(defined(udiv_qrnnd) && */
+#endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */
   return res;
 }
 #endif
@@ -601,7 +726,7 @@ DCell smdiv (DCell num, Cell denom)
 {
   DCell res;
 #if defined(sdiv_qrnnd)
-#warning "using sdiv_qrnnd"
+  /* #warning "using sdiv_qrnnd" */
   Cell u1,q,r
   UCell u0;
   UCell MAYBE_UNUSED lz;