Annotation of gforth/engine/support.c, revision 1.7

1.1       anton       1: /* Gforth support functions
                      2: 
1.7     ! anton       3:   Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
1.1       anton       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>
1.2       anton      30: #include <math.h>
1.5       anton      31: #include <ctype.h>
                     32: #include <errno.h>
1.1       anton      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: 
1.2       anton     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
1.5       anton     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:       ;
1.6       anton     255:     result.n1 = (Cell)c_addr2;
1.5       anton     256:     result.n2 = c_addr1-c_addr2;
                    257:   } else {
1.6       anton     258:     result.n1 = (Cell)c_addr1;
1.5       anton     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;
1.6       anton     335:   return r;
1.5       anton     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:   }
1.1       anton     395: }

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