File:  [gforth] / gforth / engine / support.c
Revision 1.7: download - view: text, annotated - select for diffs
Sun Mar 9 15:17:04 2003 UTC (18 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-6-2, v0-6-1, v0-6-0, HEAD
updated copyright years

    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:       s1 = "";
   80:     s2 = from+1;
   81:     s2_len = size-1;
   82:   } else {
   83:     UCell i;
   84:     for (i=1; i<size && from[i]!='/'; i++)
   85:       ;
   86:     if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
   87:       return cstr(from+3, size<3?0:size-3,clear);
   88:     {
   89:       char user[i];
   90:       memcpy(user,from+1,i-1);
   91:       user[i-1]='\0';
   92:       user_entry=getpwnam(user);
   93:     }
   94:     if (user_entry==NULL)
   95:       return cstr(from, size, clear);
   96:     s1 = user_entry->pw_dir;
   97:     s2 = from+i;
   98:     s2_len = size-i;
   99:   }
  100:   s1_len = strlen(s1);
  101:   if (s1_len>1 && s1[s1_len-1]=='/')
  102:     s1_len--;
  103:   {
  104:     char path[s1_len+s2_len];
  105:     memcpy(path,s1,s1_len);
  106:     memcpy(path+s1_len,s2,s2_len);
  107:     return cstr(path,s1_len+s2_len,clear);
  108:   }
  109: }
  110: #endif
  111: 
  112: DCell timeval2us(struct timeval *tvp)
  113: {
  114: #ifndef BUGGY_LONG_LONG
  115:   return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
  116: #else
  117:   DCell d2;
  118:   DCell d1=mmul(tvp->tv_sec,1000000);
  119:   d2.lo = d1.lo+tvp->tv_usec;
  120:   d2.hi = d1.hi + (d2.lo<d1.lo);
  121:   return d2;
  122: #endif
  123: }
  124: 
  125: DCell double2ll(Float r)
  126: {
  127: #ifndef BUGGY_LONG_LONG
  128:   return (DCell)(r);
  129: #else
  130:   double ldexp(double x, int exp);
  131:   DCell d;
  132:   if (r<0) {
  133:     d.hi = ldexp(-r,-(int)(CELL_BITS));
  134:     d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS);
  135:     return dnegate(d);
  136:   }
  137:   d.hi = ldexp(r,-(int)(CELL_BITS));
  138:   d.lo = r-ldexp((Float)d.hi,CELL_BITS);
  139:   return d;
  140: #endif
  141: }
  142: 
  143: void cmove(Char *c_from, Char *c_to, UCell u)
  144: {
  145:   while (u-- > 0)
  146:     *c_to++ = *c_from++;
  147: }
  148: 
  149: void cmove_up(Char *c_from, Char *c_to, UCell u)
  150: {
  151:   while (u-- > 0)
  152:     c_to[u] = c_from[u];
  153: }
  154: 
  155: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  156: {
  157:   Cell n;
  158: 
  159:   n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
  160:   if (n==0)
  161:     n = u1-u2;
  162:   if (n<0)
  163:     n = -1;
  164:   else if (n>0)
  165:     n = 1;
  166:   return n;
  167: }
  168: 
  169: Cell memcasecmp(const Char *s1, const Char *s2, Cell n)
  170: {
  171:   Cell i;
  172: 
  173:   for (i=0; i<n; i++) {
  174:     Char c1=toupper(s1[i]);
  175:     Char c2=toupper(s2[i]);
  176:     if (c1 != c2) {
  177:       if (c1 < c2)
  178: 	return -1;
  179:       else
  180: 	return 1;
  181:     }
  182:   }
  183:   return 0;
  184: }
  185: 
  186: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1)
  187: {
  188:   for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))
  189:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  190: 	memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
  191:       break;
  192:   return longname1;
  193: }
  194: 
  195: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr)
  196: {
  197:   struct Longname *longname1;
  198: 
  199:   while(a_addr != NULL) {
  200:     longname1=(struct Longname *)(a_addr[1]);
  201:     a_addr=(Cell *)(a_addr[0]);
  202:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  203: 	memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
  204:       return longname1;
  205:     }
  206:   }
  207:   return NULL;
  208: }
  209: 
  210: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr)
  211: {
  212:   struct Longname *longname1;
  213:   while(a_addr != NULL) {
  214:     longname1=(struct Longname *)(a_addr[1]);
  215:     a_addr=(Cell *)(a_addr[0]);
  216:     if ((UCell)LONGNAME_COUNT(longname1)==u &&
  217: 	memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) {
  218:       return longname1;
  219:     }
  220:   }
  221:   return NULL;
  222: }
  223: 
  224: UCell hashkey1(Char *c_addr, UCell u, UCell ubits)
  225: /* this hash function rotates the key at every step by rot bits within
  226:    ubits bits and xors it with the character. This function does ok in
  227:    the chi-sqare-test.  Rot should be <=7 (preferably <=5) for
  228:    ASCII strings (larger if ubits is large), and should share no
  229:    divisors with ubits.
  230: */
  231: {
  232:   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};
  233:   unsigned rot = rot_values[ubits];
  234:   Char *cp = c_addr;
  235:   UCell ukey;
  236: 
  237:   for (ukey=0; cp<c_addr+u; cp++)
  238:     ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) 
  239: 	     ^ toupper(*cp))
  240: 	    & ((1<<ubits)-1));
  241:   return ukey;
  242: }
  243: 
  244: struct Cellpair parse_white(Char *c_addr1, UCell u1)
  245: {
  246:   /* use !isgraph instead of isspace? */
  247:   struct Cellpair result;
  248:   Char *c_addr2;
  249:   Char *endp = c_addr1+u1;
  250:   while (c_addr1<endp && isspace(*c_addr1))
  251:     c_addr1++;
  252:   if (c_addr1<endp) {
  253:     for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++)
  254:       ;
  255:     result.n1 = (Cell)c_addr2;
  256:     result.n2 = c_addr1-c_addr2;
  257:   } else {
  258:     result.n1 = (Cell)c_addr1;
  259:     result.n2 = 0;
  260:   }
  261:   return result;
  262: }
  263: 
  264: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
  265: {
  266:   char *s1=tilde_cstr(c_addr2, u2, 1);
  267:   return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
  268: }
  269: 
  270: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid)
  271: {
  272:   UCell u2, u3;
  273:   Cell flag, wior;
  274:   Cell c;
  275:   struct Cellquad r;
  276: 
  277:   flag=-1;
  278:   u3=0;
  279:   for(u2=0; u2<u1; u2++) {
  280:     c = getc((FILE *)wfileid);
  281:     u3++;
  282:     if (c=='\n') break;
  283:     if (c=='\r') {
  284:       if ((c = getc((FILE *)wfileid))!='\n')
  285: 	ungetc(c,(FILE *)wfileid);
  286:       else
  287: 	u3++;
  288:       break;
  289:     }
  290:     if (c==EOF) {
  291:       flag=FLAG(u2!=0);
  292:       break;
  293:     }
  294:     c_addr[u2] = (Char)c;
  295:   }
  296:   wior=FILEIO(ferror((FILE *)wfileid));
  297:   r.n1 = u2;
  298:   r.n2 = flag;
  299:   r.n3 = u3;
  300:   r.n4 = wior;
  301:   return r;
  302: }
  303: 
  304: struct Cellpair file_status(Char *c_addr, UCell u)
  305: {
  306:   struct Cellpair r;
  307:   Cell wfam;
  308:   Cell wior;
  309:   char *filename=tilde_cstr(c_addr, u, 1);
  310: 
  311:   if (access (filename, F_OK) != 0) {
  312:     wfam=0;
  313:     wior=IOR(1);
  314:   }
  315:   else if (access (filename, R_OK | W_OK) == 0) {
  316:     wfam=2; /* r/w */
  317:     wior=0;
  318:   }
  319:   else if (access (filename, R_OK) == 0) {
  320:     wfam=0; /* r/o */
  321:     wior=0;
  322:   }
  323:   else if (access (filename, W_OK) == 0) {
  324:     wfam=4; /* w/o */
  325:     wior=0;
  326:   }
  327:   else {
  328:     wfam=1; /* well, we cannot access the file, but better deliver a
  329: 	       legal access mode (r/o bin), so we get a decent error
  330: 	       later upon open. */
  331:     wior=0;
  332:   }
  333:   r.n1 = wfam;
  334:   r.n2 = wior;
  335:   return r;
  336: }
  337: 
  338: Cell to_float(Char *c_addr, UCell u, Float *rp)
  339: {
  340:   Float r;
  341:   Cell flag;
  342:   char *number=cstr(c_addr, u, 1);
  343:   char *endconv;
  344:   int sign = 0;
  345:   if(number[0]=='-') {
  346:     sign = 1;
  347:     number++;
  348:     u--;
  349:   }
  350:   while(isspace((unsigned)(number[--u])) && u>0)
  351:     ;
  352:   switch(number[u]) {
  353:   case 'd':
  354:   case 'D':
  355:   case 'e':
  356:   case 'E':  break;
  357:   default :  u++; break;
  358:   }
  359:   number[u]='\0';
  360:   r=strtod(number,&endconv);
  361:   if((flag=FLAG(!(Cell)*endconv))) {
  362:     if (sign)
  363:       r = -r;
  364:   } else if(*endconv=='d' || *endconv=='D') {
  365:     *endconv='E';
  366:     r=strtod(number,&endconv);
  367:     if((flag=FLAG(!(Cell)*endconv))) {
  368:       if (sign)
  369: 	r = -r;
  370:     }
  371:   }
  372:   *rp = r;
  373:   return flag;
  374: }
  375: 
  376: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
  377: {
  378:   Float r;
  379: 
  380:   for (r=0.; ucount>0; ucount--) {
  381:     r += *f_addr1 * *f_addr2;
  382:     f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
  383:     f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
  384:   }
  385:   return r;
  386: }
  387: 
  388: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount)
  389: {
  390:   for (; ucount>0; ucount--) {
  391:     *f_y += ra * *f_x;
  392:     f_x = (Float *)(((Address)f_x)+nstridex);
  393:     f_y = (Float *)(((Address)f_y)+nstridey);
  394:   }
  395: }

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