Return to support.c CVS log

Up to [gforth] / gforth / engine

Alpha bug workaround (disabled ALIGN_CODE)
fixed bugs in F>D and D>F

    1: /* Gforth support functions
    2: 
    3:   Copyright (C) 1995,1996,1997,1998,2000 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: 
   32: #ifdef HAS_FILE
   33: char *cstr(Char *from, UCell size, int clear)
   34: /* return a C-string corresponding to the Forth string ( FROM SIZE ).
   35:    the C-string lives until the next call of cstr with CLEAR being true */
   36: {
   37:   static struct cstr_buffer {
   38:     char *buffer;
   39:     size_t size;
   40:   } *buffers=NULL;
   41:   static int nbuffers=0;
   42:   static int used=0;
   43:   struct cstr_buffer *b;
   44: 
   45:   if (buffers==NULL)
   46:     buffers=malloc(0);
   47:   if (clear)
   48:     used=0;
   49:   if (used>=nbuffers) {
   50:     buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1));
   51:     buffers[used]=(struct cstr_buffer){malloc(0),0};
   52:     nbuffers=used+1;
   53:   }
   54:   b=&buffers[used];
   55:   if (size+1 > b->size) {
   56:     b->buffer = realloc(b->buffer,size+1);
   57:     b->size = size+1;
   58:   }
   59:   memcpy(b->buffer,from,size);
   60:   b->buffer[size]='\0';
   61:   used++;
   62:   return b->buffer;
   63: }
   64: 
   65: char *tilde_cstr(Char *from, UCell size, int clear)
   66: /* like cstr(), but perform tilde expansion on the string */
   67: {
   68:   char *s1,*s2;
   69:   int s1_len, s2_len;
   70:   struct passwd *getpwnam (), *user_entry;
   71: 
   72:   if (size<1 || from[0]!='~')
   73:     return cstr(from, size, clear);
   74:   if (size<2 || from[1]=='/') {
   75:     s1 = (char *)getenv ("HOME");
   76:     if(s1 == NULL)
   77:       s1 = "";
   78:     s2 = from+1;
   79:     s2_len = size-1;
   80:   } else {
   81:     UCell i;
   82:     for (i=1; i<size && from[i]!='/'; i++)
   83:       ;
   84:     if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */
   85:       return cstr(from+3, size<3?0:size-3,clear);
   86:     {
   87:       char user[i];
   88:       memcpy(user,from+1,i-1);
   89:       user[i-1]='\0';
   90:       user_entry=getpwnam(user);
   91:     }
   92:     if (user_entry==NULL)
   93:       return cstr(from, size, clear);
   94:     s1 = user_entry->pw_dir;
   95:     s2 = from+i;
   96:     s2_len = size-i;
   97:   }
   98:   s1_len = strlen(s1);
   99:   if (s1_len>1 && s1[s1_len-1]=='/')
  100:     s1_len--;
  101:   {
  102:     char path[s1_len+s2_len];
  103:     memcpy(path,s1,s1_len);
  104:     memcpy(path+s1_len,s2,s2_len);
  105:     return cstr(path,s1_len+s2_len,clear);
  106:   }
  107: }
  108: #endif
  109: 
  110: DCell timeval2us(struct timeval *tvp)
  111: {
  112: #ifndef BUGGY_LONG_LONG
  113:   return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec;
  114: #else
  115:   DCell d2;
  116:   DCell d1=mmul(tvp->tv_sec,1000000);
  117:   d2.lo = d1.lo+tvp->tv_usec;
  118:   d2.hi = d1.hi + (d2.lo<d1.lo);
  119:   return d2;
  120: #endif
  121: }
  122: 
  123: Xt *primtable(Label symbols[], Cell size)
  124:      /* used in primitive primtable for peephole optimization */
  125: {
  126:   Xt *xts = (Xt *)malloc(size*sizeof(Xt));
  127:   Cell i;
  128: 
  129:   for (i=0; i<size; i++)
  130:     xts[i] = &symbols[i];
  131:   return xts;
  132: }
  133: 
  134: DCell double2ll(Float r)
  135: {
  136: #ifndef BUGGY_LONG_LONG
  137:   return (DCell)(r);
  138: #else
  139:   double ldexp(double x, int exp);
  140:   DCell d;
  141:   if (r<0) {
  142:     d.hi = ldexp(-r,-(int)(CELL_BITS));
  143:     d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS);
  144:     return dnegate(d);
  145:   }
  146:   d.hi = ldexp(r,-(int)(CELL_BITS));
  147:   d.lo = r-ldexp((Float)d.hi,CELL_BITS);
  148:   return d;
  149: #endif
  150: }