File:  [gforth] / gforth / engine / support.c
Revision 1.8: download - view: text, annotated - select for diffs
Sat Aug 30 19:55:13 2003 UTC (20 years, 7 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Fixes for Windows port

    1: /* Gforth support functions
    2: 
    3:   Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
    4: 
    5:   This file is part of Gforth.
    6: 
    7:   Gforth is free software; you can redistribute it and/or
    8:   modify it under the terms of the GNU General Public License
    9:   as published by the Free Software Foundation; either version 2
   10:   of the License, or (at your option) any later version.
   11: 
   12:   This program is distributed in the hope that it will be useful,
   13:   but WITHOUT ANY WARRANTY; without even the implied warranty of
   14:   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15:   GNU General Public License for more details.
   16: 
   17:   You should have received a copy of the GNU General Public License
   18:   along with this program; if not, write to the Free Software
   19:   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   20: */
   21: 
   22: #include "config.h"
   23: #include "forth.h"
   24: #include <stdlib.h>
   25: #include <string.h>
   26: #include <sys/time.h>
   27: #include <unistd.h>
   28: #include <pwd.h>
   29: #include <dirent.h>
   30: #include <math.h>
   31: #include <ctype.h>
   32: #include <errno.h>
   33: 
   34: #ifdef HAS_FILE
   35: char *cstr(Char *from, UCell size, int clear)
   36: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
   37:    the C-string lives until the next call of cstr with CLEAR being true */
   38: {
   39:   static struct cstr_buffer {
   40:     char *buffer;
   41:     size_t size;
   42:   } *buffers=NULL;
   43:   static int nbuffers=0;
   44:   static int used=0;
   45:   struct cstr_buffer *b;
   46: 
   47:   if (buffers==NULL)
   48:     buffers=malloc(0);
   49:   if (clear)
   50:     used=0;
   51:   if (used>=nbuffers) {
   52:     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
   53:     buffers[used]=(struct cstr_buffer){malloc(0),0};
   54:     nbuffers=used+1;
   55:   }
   56:   b=&buffers[used];
   57:   if (size+1 > b->size) {
   58:     b->buffer = realloc(b->buffer,size+1);
   59:     b->size = size+1;
   60:   }
   61:   memcpy(b->buffer,from,size);
   62:   b->buffer[size]='\0';
   63:   used++;
   64:   return b->buffer;
   65: }
   66: 
   67: char *tilde_cstr(Char *from, UCell size, int clear)
   68: /* like cstr(), but perform tilde expansion on the string */
   69: {
   70:   char *s1,*s2;
   71:   int s1_len, s2_len;
   72:   struct passwd *getpwnam (), *user_entry;
   73: 
   74:   if (size<1 || from[0]!='~')
   75:     return cstr(from, size, clear);
   76:   if (size<2 || from[1]=='/') {
   77:     s1 = (char *)getenv ("HOME");
   78:     if(s1 == NULL)
   79: #if defined(_WIN32) || defined (MSDOS)
   80:       s1 = (char *)getenv ("TEMP");
   81:       if(s1 == NULL)
   82:          s1 = (char *)getenv ("TMP");
   83:          if(s1 == NULL)
   84: #endif
   85:       s1 = "";
   86:     s2 = from+1;
   87:     s2_len = size-1;
   88:   } else {
   89:     UCell i;
   90:     for (i=1; i<size && from[i]!='/'; i++)
   91:       ;
   92:     if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
   93:       return cstr(from+3, size<3?0:size-3,clear);
   94:     {
   95:       char user[i];
   96:       memcpy(user,from+1,i-1);
   97:       user[i-1]='\0';
   98:       user_entry=getpwnam(user);
   99:     }
  100:     if (user_entry==NULL)
  101:       return cstr(from, size, clear);
  102:     s1 = user_entry->pw_dir;
  103:     s2 = from+i;
  104:     s2_len = size-i;
  105:   }
  106:   s1_len = strlen(s1);
  107:   if (s1_len>1 && s1[s1_len-1]=='/')
  108:     s1_len--;
  109:   {
  110:     char path[s1_len+s2_len];
  111:     memcpy(path,s1,s1_len);
  112:     memcpy(path+s1_len,s2,s2_len);
  113:     return cstr(path,s1_len+s2_len,clear);
  114:   }
  115: }
  116: #endif
  117: 
  118: DCell timeval2us(struct timeval *tvp)
  119: {
  120: #ifndef BUGGY_LONG_LONG
  121:   return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
  122: #else
  123:   DCell d2;
  124:   DCell d1=mmul(tvp->tv_sec,1000000);
  125:   d2.lo = d1.lo+tvp->tv_usec;
  126:   d2.hi = d1.hi + (d2.lo<d1.lo);
  127:   return d2;
  128: #endif
  129: }
  130: 
  131: DCell double2ll(Float r)
  132: {
  133: #ifndef BUGGY_LONG_LONG
  134:   return (DCell)(r);
  135: #else
  136:   double ldexp(double x, int exp);
  137:   DCell d;
  138:   if (r<0) {
  139:     d.hi = ldexp(-r,-(int)(CELL_BITS));
  140:     d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS);
  141:     return dnegate(d);
  142:   }
  143:   d.hi = ldexp(r,-(int)(CELL_BITS));
  144:   d.lo = r-ldexp((Float)d.hi,CELL_BITS);
  145:   return d;
  146: #endif
  147: }
  148: 
  149: void cmove(Char *c_from, Char *c_to, UCell u)
  150: {
  151:   while (u-- > 0)
  152:     *c_to++ = *c_from++;
  153: }
  154: 
  155: void cmove_up(Char *c_from, Char *c_to, UCell u)
  156: {
  157:   while (u-- > 0)
  158:     c_to[u] = c_from[u];
  159: }
  160: 
  161: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  162: {
  163:   Cell n;
  164: 
  165:   n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
  166:   if (n==0)
  167:     n = u1-u2;
  168:   if (n<0)
  169:     n = -1;
  170:   else if (n>0)
  171:     n = 1;
  172:   return n;
  173: }
  174: 
  175: Cell memcasecmp(const Char *s1, const Char *s2, Cell n)
  176: {
  177:   Cell i;
  178: 
  179:   for (i=0; i<n; i++) {
  180:     Char c1=toupper(s1[i]);
  181:     Char c2=toupper(s2[i]);
  182:     if (c1 != c2) {
  183:       if (c1 < c2)
  184: 	return -1;
  185:       else
  186: 	return 1;
  187:     }
  188:   }
  189:   return 0;
  190: }
  191: 
  192: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
  193: {
  194:   for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
  195:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  196: 	memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
  197:       break;
  198:   return longname1;
  199: }
  200: 
  201: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr)
  202: {
  203:   struct Longname *longname1;
  204: 
  205:   while(a_addr != NULL) {
  206:     longname1=(struct Longname *)(a_addr[1]);
  207:     a_addr=(Cell *)(a_addr[0]);
  208:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  209: 	memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
  210:       return longname1;
  211:     }
  212:   }
  213:   return NULL;
  214: }
  215: 
  216: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr)
  217: {
  218:   struct Longname *longname1;
  219:   while(a_addr != NULL) {
  220:     longname1=(struct Longname *)(a_addr[1]);
  221:     a_addr=(Cell *)(a_addr[0]);
  222:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  223: 	memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
  224:       return longname1;
  225:     }
  226:   }
  227:   return NULL;
  228: }
  229: 
  230: UCell hashkey1(Char *c_addr, UCell u, UCell ubits)
  231: /* this hash function rotates the key at every step by rot bits within
  232:    ubits bits and xors it with the character. This function does ok in
  233:    the chi-sqare-test.  Rot should be <=7 (preferably <=5) for
  234:    ASCII strings (larger if ubits is large), and should share no
  235:    divisors with ubits.
  236: */
  237: {
  238:   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};
  239:   unsigned rot = rot_values[ubits];
  240:   Char *cp = c_addr;
  241:   UCell ukey;
  242: 
  243:   for (ukey=0; cp<c_addr+u; cp++)
  244:     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) 
  245: 	     ^ toupper(*cp))
  246: 	    & ((1<<ubits)-1));
  247:   return ukey;
  248: }
  249: 
  250: struct Cellpair parse_white(Char *c_addr1, UCell u1)
  251: {
  252:   /* use !isgraph instead of isspace? */
  253:   struct Cellpair result;
  254:   Char *c_addr2;
  255:   Char *endp = c_addr1+u1;
  256:   while (c_addr1<endp && isspace(*c_addr1))
  257:     c_addr1++;
  258:   if (c_addr1<endp) {
  259:     for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
  260:       ;
  261:     result.n1 = (Cell)c_addr2;
  262:     result.n2 = c_addr1-c_addr2;
  263:   } else {
  264:     result.n1 = (Cell)c_addr1;
  265:     result.n2 = 0;
  266:   }
  267:   return result;
  268: }
  269: 
  270: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  271: {
  272:   char *s1=tilde_cstr(c_addr2, u2, 1);
  273:   return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
  274: }
  275: 
  276: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)
  277: {
  278:   UCell u2, u3;
  279:   Cell flag, wior;
  280:   Cell c;
  281:   struct Cellquad r;
  282: 
  283:   flag=-1;
  284:   u3=0;
  285:   for(u2=0; u2<u1; u2++) {
  286:     c = getc((FILE *)wfileid);
  287:     u3++;
  288:     if (c=='\n') break;
  289:     if (c=='\r') {
  290:       if ((c = getc((FILE *)wfileid))!='\n')
  291: 	ungetc(c,(FILE *)wfileid);
  292:       else
  293: 	u3++;
  294:       break;
  295:     }
  296:     if (c==EOF) {
  297:       flag=FLAG(u2!=0);
  298:       break;
  299:     }
  300:     c_addr[u2] = (Char)c;
  301:   }
  302:   wior=FILEIO(ferror((FILE *)wfileid));
  303:   r.n1 = u2;
  304:   r.n2 = flag;
  305:   r.n3 = u3;
  306:   r.n4 = wior;
  307:   return r;
  308: }
  309: 
  310: struct Cellpair file_status(Char *c_addr, UCell u)
  311: {
  312:   struct Cellpair r;
  313:   Cell wfam;
  314:   Cell wior;
  315:   char *filename=tilde_cstr(c_addr, u, 1);
  316: 
  317:   if (access (filename, F_OK) != 0) {
  318:     wfam=0;
  319:     wior=IOR(1);
  320:   }
  321:   else if (access (filename, R_OK | W_OK) == 0) {
  322:     wfam=2; /* r/w */
  323:     wior=0;
  324:   }
  325:   else if (access (filename, R_OK) == 0) {
  326:     wfam=0; /* r/o */
  327:     wior=0;
  328:   }
  329:   else if (access (filename, W_OK) == 0) {
  330:     wfam=4; /* w/o */
  331:     wior=0;
  332:   }
  333:   else {
  334:     wfam=1; /* well, we cannot access the file, but better deliver a
  335: 	       legal access mode (r/o bin), so we get a decent error
  336: 	       later upon open. */
  337:     wior=0;
  338:   }
  339:   r.n1 = wfam;
  340:   r.n2 = wior;
  341:   return r;
  342: }
  343: 
  344: Cell to_float(Char *c_addr, UCell u, Float *rp)
  345: {
  346:   Float r;
  347:   Cell flag;
  348:   char *number=cstr(c_addr, u, 1);
  349:   char *endconv;
  350:   int sign = 0;
  351:   if(number[0]=='-') {
  352:     sign = 1;
  353:     number++;
  354:     u--;
  355:   }
  356:   while(isspace((unsigned)(number[--u])) && u>0)
  357:     ;
  358:   switch(number[u]) {
  359:   case 'd':
  360:   case 'D':
  361:   case 'e':
  362:   case 'E':  break;
  363:   default :  u++; break;
  364:   }
  365:   number[u]='\0';
  366:   r=strtod(number,&endconv);
  367:   if((flag=FLAG(!(Cell)*endconv))) {
  368:     if (sign)
  369:       r = -r;
  370:   } else if(*endconv=='d' || *endconv=='D') {
  371:     *endconv='E';
  372:     r=strtod(number,&endconv);
  373:     if((flag=FLAG(!(Cell)*endconv))) {
  374:       if (sign)
  375: 	r = -r;
  376:     }
  377:   }
  378:   *rp = r;
  379:   return flag;
  380: }
  381: 
  382: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
  383: {
  384:   Float r;
  385: 
  386:   for (r=0.; ucount>0; ucount--) {
  387:     r += *f_addr1 * *f_addr2;
  388:     f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
  389:     f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
  390:   }
  391:   return r;
  392: }
  393: 
  394: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
  395: {
  396:   for (; ucount>0; ucount--) {
  397:     *f_y += ra * *f_x;
  398:     f_x = (Float *)(((Address)f_x)+nstridex);
  399:     f_y = (Float *)(((Address)f_y)+nstridey);
  400:   }
  401: }

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