Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | /* Gforth support functions |
| 2 : | |||
| 3 : | anton | 1.38 | Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
| 4 : | anton | 1.1 | |
| 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 : | anton | 1.31 | as published by the Free Software Foundation, either version 3 |
| 10 : | anton | 1.1 | 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 : | anton | 1.31 | along with this program; if not, see http://www.gnu.org/licenses/. |
| 19 : | anton | 1.1 | */ |
| 20 : | |||
| 21 : | #include "config.h" | ||
| 22 : | #include "forth.h" | ||
| 23 : | anton | 1.10 | #include "io.h" |
| 24 : | anton | 1.1 | #include <stdlib.h> |
| 25 : | #include <string.h> | ||
| 26 : | #include <sys/time.h> | ||
| 27 : | #include <unistd.h> | ||
| 28 : | #include <pwd.h> | ||
| 29 : | anton | 1.28 | #include <assert.h> |
| 30 : | pazsan | 1.23 | #ifndef STANDALONE |
| 31 : | anton | 1.1 | #include <dirent.h> |
| 32 : | anton | 1.2 | #include <math.h> |
| 33 : | anton | 1.5 | #include <ctype.h> |
| 34 : | #include <errno.h> | ||
| 35 : | anton | 1.32 | #include <sys/types.h> |
| 36 : | #include <sys/stat.h> | ||
| 37 : | #include <fcntl.h> | ||
| 38 : | #include <time.h> | ||
| 39 : | pazsan | 1.23 | #endif |
| 40 : | pazsan | 1.34 | #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */ |
| 41 : | #include <dlfcn.h> | ||
| 42 : | #endif | ||
| 43 : | anton | 1.1 | |
| 44 : | #ifdef HAS_FILE | ||
| 45 : | char *cstr(Char *from, UCell size, int clear) | ||
| 46 : | /* return a C-string corresponding to the Forth string ( FROM SIZE ). | ||
| 47 : | the C-string lives until the next call of cstr with CLEAR being true */ | ||
| 48 : | { | ||
| 49 : | static struct cstr_buffer { | ||
| 50 : | char *buffer; | ||
| 51 : | size_t size; | ||
| 52 : | } *buffers=NULL; | ||
| 53 : | static int nbuffers=0; | ||
| 54 : | static int used=0; | ||
| 55 : | struct cstr_buffer *b; | ||
| 56 : | |||
| 57 : | if (buffers==NULL) | ||
| 58 : | buffers=malloc(0); | ||
| 59 : | if (clear) | ||
| 60 : | used=0; | ||
| 61 : | if (used>=nbuffers) { | ||
| 62 : | buffers=realloc(buffers,sizeof(struct cstr_buffer)*(used+1)); | ||
| 63 : | buffers[used]=(struct cstr_buffer){malloc(0),0}; | ||
| 64 : | nbuffers=used+1; | ||
| 65 : | } | ||
| 66 : | b=&buffers[used]; | ||
| 67 : | if (size+1 > b->size) { | ||
| 68 : | b->buffer = realloc(b->buffer,size+1); | ||
| 69 : | b->size = size+1; | ||
| 70 : | } | ||
| 71 : | memcpy(b->buffer,from,size); | ||
| 72 : | b->buffer[size]='\0'; | ||
| 73 : | used++; | ||
| 74 : | return b->buffer; | ||
| 75 : | } | ||
| 76 : | |||
| 77 : | char *tilde_cstr(Char *from, UCell size, int clear) | ||
| 78 : | /* like cstr(), but perform tilde expansion on the string */ | ||
| 79 : | { | ||
| 80 : | char *s1,*s2; | ||
| 81 : | int s1_len, s2_len; | ||
| 82 : | struct passwd *getpwnam (), *user_entry; | ||
| 83 : | |||
| 84 : | if (size<1 || from[0]!='~') | ||
| 85 : | return cstr(from, size, clear); | ||
| 86 : | if (size<2 || from[1]=='/') { | ||
| 87 : | s1 = (char *)getenv ("HOME"); | ||
| 88 : | if(s1 == NULL) | ||
| 89 : | pazsan | 1.8 | #if defined(_WIN32) || defined (MSDOS) |
| 90 : | s1 = (char *)getenv ("TEMP"); | ||
| 91 : | if(s1 == NULL) | ||
| 92 : | s1 = (char *)getenv ("TMP"); | ||
| 93 : | if(s1 == NULL) | ||
| 94 : | #endif | ||
| 95 : | anton | 1.1 | s1 = ""; |
| 96 : | pazsan | 1.15 | s2 = (char *)from+1; |
| 97 : | anton | 1.1 | s2_len = size-1; |
| 98 : | } else { | ||
| 99 : | UCell i; | ||
| 100 : | for (i=1; i<size && from[i]!='/'; i++) | ||
| 101 : | ; | ||
| 102 : | if (i==2 && from[1]=='+') /* deal with "~+", i.e., the wd */ | ||
| 103 : | return cstr(from+3, size<3?0:size-3,clear); | ||
| 104 : | { | ||
| 105 : | char user[i]; | ||
| 106 : | memcpy(user,from+1,i-1); | ||
| 107 : | user[i-1]='\0'; | ||
| 108 : | user_entry=getpwnam(user); | ||
| 109 : | } | ||
| 110 : | if (user_entry==NULL) | ||
| 111 : | return cstr(from, size, clear); | ||
| 112 : | s1 = user_entry->pw_dir; | ||
| 113 : | pazsan | 1.15 | s2 = (char *)from+i; |
| 114 : | anton | 1.1 | s2_len = size-i; |
| 115 : | } | ||
| 116 : | s1_len = strlen(s1); | ||
| 117 : | if (s1_len>1 && s1[s1_len-1]=='/') | ||
| 118 : | s1_len--; | ||
| 119 : | { | ||
| 120 : | char path[s1_len+s2_len]; | ||
| 121 : | memcpy(path,s1,s1_len); | ||
| 122 : | memcpy(path+s1_len,s2,s2_len); | ||
| 123 : | pazsan | 1.15 | return cstr((Char *)path,s1_len+s2_len,clear); |
| 124 : | anton | 1.1 | } |
| 125 : | } | ||
| 126 : | anton | 1.29 | |
| 127 : | Cell opencreate_file(char *s, Cell wfam, int flags, Cell *wiorp) | ||
| 128 : | { | ||
| 129 : | Cell fd; | ||
| 130 : | Cell wfileid; | ||
| 131 : | fd = open(s, flags|ufileattr[wfam], 0666); | ||
| 132 : | if (fd != -1) { | ||
| 133 : | wfileid = (Cell)fdopen(fd, fileattr[wfam]); | ||
| 134 : | *wiorp = IOR(wfileid == 0); | ||
| 135 : | } else { | ||
| 136 : | wfileid = 0; | ||
| 137 : | *wiorp = IOR(1); | ||
| 138 : | } | ||
| 139 : | return wfileid; | ||
| 140 : | } | ||
| 141 : | #endif /* defined(HAS_FILE) */ | ||
| 142 : | anton | 1.1 | |
| 143 : | DCell timeval2us(struct timeval *tvp) | ||
| 144 : | { | ||
| 145 : | #ifndef BUGGY_LONG_LONG | ||
| 146 : | return (tvp->tv_sec*(DCell)1000000)+tvp->tv_usec; | ||
| 147 : | #else | ||
| 148 : | DCell d2; | ||
| 149 : | DCell d1=mmul(tvp->tv_sec,1000000); | ||
| 150 : | d2.lo = d1.lo+tvp->tv_usec; | ||
| 151 : | d2.hi = d1.hi + (d2.lo<d1.lo); | ||
| 152 : | return d2; | ||
| 153 : | #endif | ||
| 154 : | } | ||
| 155 : | |||
| 156 : | anton | 1.2 | DCell double2ll(Float r) |
| 157 : | { | ||
| 158 : | #ifndef BUGGY_LONG_LONG | ||
| 159 : | return (DCell)(r); | ||
| 160 : | #else | ||
| 161 : | double ldexp(double x, int exp); | ||
| 162 : | DCell d; | ||
| 163 : | if (r<0) { | ||
| 164 : | d.hi = ldexp(-r,-(int)(CELL_BITS)); | ||
| 165 : | d.lo = (-r)-ldexp((Float)d.hi,CELL_BITS); | ||
| 166 : | return dnegate(d); | ||
| 167 : | } | ||
| 168 : | d.hi = ldexp(r,-(int)(CELL_BITS)); | ||
| 169 : | d.lo = r-ldexp((Float)d.hi,CELL_BITS); | ||
| 170 : | return d; | ||
| 171 : | #endif | ||
| 172 : | anton | 1.5 | } |
| 173 : | |||
| 174 : | void cmove(Char *c_from, Char *c_to, UCell u) | ||
| 175 : | { | ||
| 176 : | while (u-- > 0) | ||
| 177 : | *c_to++ = *c_from++; | ||
| 178 : | } | ||
| 179 : | |||
| 180 : | void cmove_up(Char *c_from, Char *c_to, UCell u) | ||
| 181 : | { | ||
| 182 : | while (u-- > 0) | ||
| 183 : | c_to[u] = c_from[u]; | ||
| 184 : | } | ||
| 185 : | |||
| 186 : | Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2) | ||
| 187 : | { | ||
| 188 : | Cell n; | ||
| 189 : | |||
| 190 : | n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); | ||
| 191 : | if (n==0) | ||
| 192 : | n = u1-u2; | ||
| 193 : | if (n<0) | ||
| 194 : | n = -1; | ||
| 195 : | else if (n>0) | ||
| 196 : | n = 1; | ||
| 197 : | return n; | ||
| 198 : | } | ||
| 199 : | |||
| 200 : | Cell memcasecmp(const Char *s1, const Char *s2, Cell n) | ||
| 201 : | { | ||
| 202 : | Cell i; | ||
| 203 : | |||
| 204 : | for (i=0; i<n; i++) { | ||
| 205 : | Char c1=toupper(s1[i]); | ||
| 206 : | Char c2=toupper(s2[i]); | ||
| 207 : | if (c1 != c2) { | ||
| 208 : | if (c1 < c2) | ||
| 209 : | return -1; | ||
| 210 : | else | ||
| 211 : | return 1; | ||
| 212 : | } | ||
| 213 : | } | ||
| 214 : | return 0; | ||
| 215 : | } | ||
| 216 : | |||
| 217 : | pazsan | 1.14 | Cell capscompare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2) |
| 218 : | { | ||
| 219 : | Cell n; | ||
| 220 : | |||
| 221 : | n = memcasecmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); | ||
| 222 : | if (n==0) | ||
| 223 : | n = u1-u2; | ||
| 224 : | if (n<0) | ||
| 225 : | n = -1; | ||
| 226 : | else if (n>0) | ||
| 227 : | n = 1; | ||
| 228 : | return n; | ||
| 229 : | } | ||
| 230 : | |||
| 231 : | anton | 1.5 | struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1) |
| 232 : | { | ||
| 233 : | for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next)) | ||
| 234 : | if ((UCell)LONGNAME_COUNT(longname1)==u && | ||
| 235 : | pazsan | 1.15 | memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) |
| 236 : | anton | 1.5 | break; |
| 237 : | return longname1; | ||
| 238 : | } | ||
| 239 : | |||
| 240 : | struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr) | ||
| 241 : | { | ||
| 242 : | struct Longname *longname1; | ||
| 243 : | |||
| 244 : | while(a_addr != NULL) { | ||
| 245 : | longname1=(struct Longname *)(a_addr[1]); | ||
| 246 : | a_addr=(Cell *)(a_addr[0]); | ||
| 247 : | if ((UCell)LONGNAME_COUNT(longname1)==u && | ||
| 248 : | pazsan | 1.15 | memcasecmp(c_addr, (Char *)(longname1->name), u)== 0 /* or inline? */) { |
| 249 : | anton | 1.5 | return longname1; |
| 250 : | } | ||
| 251 : | } | ||
| 252 : | return NULL; | ||
| 253 : | } | ||
| 254 : | |||
| 255 : | struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr) | ||
| 256 : | { | ||
| 257 : | struct Longname *longname1; | ||
| 258 : | while(a_addr != NULL) { | ||
| 259 : | longname1=(struct Longname *)(a_addr[1]); | ||
| 260 : | a_addr=(Cell *)(a_addr[0]); | ||
| 261 : | if ((UCell)LONGNAME_COUNT(longname1)==u && | ||
| 262 : | memcmp(c_addr, longname1->name, u)== 0 /* or inline? */) { | ||
| 263 : | return longname1; | ||
| 264 : | } | ||
| 265 : | } | ||
| 266 : | return NULL; | ||
| 267 : | } | ||
| 268 : | |||
| 269 : | UCell hashkey1(Char *c_addr, UCell u, UCell ubits) | ||
| 270 : | /* this hash function rotates the key at every step by rot bits within | ||
| 271 : | ubits bits and xors it with the character. This function does ok in | ||
| 272 : | the chi-sqare-test. Rot should be <=7 (preferably <=5) for | ||
| 273 : | ASCII strings (larger if ubits is large), and should share no | ||
| 274 : | divisors with ubits. | ||
| 275 : | */ | ||
| 276 : | { | ||
| 277 : | 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}; | ||
| 278 : | unsigned rot = rot_values[ubits]; | ||
| 279 : | Char *cp = c_addr; | ||
| 280 : | UCell ukey; | ||
| 281 : | |||
| 282 : | for (ukey=0; cp<c_addr+u; cp++) | ||
| 283 : | ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) | ||
| 284 : | ^ toupper(*cp)) | ||
| 285 : | & ((1<<ubits)-1)); | ||
| 286 : | return ukey; | ||
| 287 : | } | ||
| 288 : | |||
| 289 : | struct Cellpair parse_white(Char *c_addr1, UCell u1) | ||
| 290 : | { | ||
| 291 : | /* use !isgraph instead of isspace? */ | ||
| 292 : | struct Cellpair result; | ||
| 293 : | Char *c_addr2; | ||
| 294 : | Char *endp = c_addr1+u1; | ||
| 295 : | while (c_addr1<endp && isspace(*c_addr1)) | ||
| 296 : | c_addr1++; | ||
| 297 : | if (c_addr1<endp) { | ||
| 298 : | for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++) | ||
| 299 : | ; | ||
| 300 : | anton | 1.6 | result.n1 = (Cell)c_addr2; |
| 301 : | anton | 1.5 | result.n2 = c_addr1-c_addr2; |
| 302 : | } else { | ||
| 303 : | anton | 1.6 | result.n1 = (Cell)c_addr1; |
| 304 : | anton | 1.5 | result.n2 = 0; |
| 305 : | } | ||
| 306 : | return result; | ||
| 307 : | } | ||
| 308 : | |||
| 309 : | pazsan | 1.22 | #ifdef HAS_FILE |
| 310 : | anton | 1.5 | Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2) |
| 311 : | { | ||
| 312 : | char *s1=tilde_cstr(c_addr2, u2, 1); | ||
| 313 : | return IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); | ||
| 314 : | } | ||
| 315 : | |||
| 316 : | anton | 1.40 | struct Cellquad read_line(Char *c_addr, UCell u1, FILE *wfileid) |
| 317 : | anton | 1.5 | { |
| 318 : | UCell u2, u3; | ||
| 319 : | Cell flag, wior; | ||
| 320 : | Cell c; | ||
| 321 : | struct Cellquad r; | ||
| 322 : | |||
| 323 : | flag=-1; | ||
| 324 : | u3=0; | ||
| 325 : | anton | 1.40 | if (u1>0) |
| 326 : | gf_regetc(wfileid); | ||
| 327 : | anton | 1.5 | for(u2=0; u2<u1; u2++) { |
| 328 : | anton | 1.40 | c = getc(wfileid); |
| 329 : | anton | 1.5 | u3++; |
| 330 : | if (c=='\n') break; | ||
| 331 : | if (c=='\r') { | ||
| 332 : | anton | 1.40 | if ((c = getc(wfileid))!='\n') |
| 333 : | gf_ungetc(c,wfileid); | ||
| 334 : | anton | 1.5 | else |
| 335 : | u3++; | ||
| 336 : | break; | ||
| 337 : | } | ||
| 338 : | if (c==EOF) { | ||
| 339 : | flag=FLAG(u2!=0); | ||
| 340 : | break; | ||
| 341 : | } | ||
| 342 : | c_addr[u2] = (Char)c; | ||
| 343 : | } | ||
| 344 : | anton | 1.40 | wior=FILEIO(ferror(wfileid)); |
| 345 : | anton | 1.5 | r.n1 = u2; |
| 346 : | r.n2 = flag; | ||
| 347 : | r.n3 = u3; | ||
| 348 : | r.n4 = wior; | ||
| 349 : | return r; | ||
| 350 : | } | ||
| 351 : | |||
| 352 : | struct Cellpair file_status(Char *c_addr, UCell u) | ||
| 353 : | { | ||
| 354 : | struct Cellpair r; | ||
| 355 : | Cell wfam; | ||
| 356 : | Cell wior; | ||
| 357 : | char *filename=tilde_cstr(c_addr, u, 1); | ||
| 358 : | |||
| 359 : | if (access (filename, F_OK) != 0) { | ||
| 360 : | wfam=0; | ||
| 361 : | wior=IOR(1); | ||
| 362 : | } | ||
| 363 : | else if (access (filename, R_OK | W_OK) == 0) { | ||
| 364 : | wfam=2; /* r/w */ | ||
| 365 : | wior=0; | ||
| 366 : | } | ||
| 367 : | else if (access (filename, R_OK) == 0) { | ||
| 368 : | wfam=0; /* r/o */ | ||
| 369 : | wior=0; | ||
| 370 : | } | ||
| 371 : | else if (access (filename, W_OK) == 0) { | ||
| 372 : | wfam=4; /* w/o */ | ||
| 373 : | wior=0; | ||
| 374 : | } | ||
| 375 : | else { | ||
| 376 : | wfam=1; /* well, we cannot access the file, but better deliver a | ||
| 377 : | legal access mode (r/o bin), so we get a decent error | ||
| 378 : | later upon open. */ | ||
| 379 : | wior=0; | ||
| 380 : | } | ||
| 381 : | r.n1 = wfam; | ||
| 382 : | r.n2 = wior; | ||
| 383 : | anton | 1.6 | return r; |
| 384 : | anton | 1.5 | } |
| 385 : | |||
| 386 : | Cell to_float(Char *c_addr, UCell u, Float *rp) | ||
| 387 : | { | ||
| 388 : | anton | 1.28 | /* convertible string := <significand>[<exponent>] |
| 389 : | <significand> := [<sign>]{<digits>[.<digits0>] | .<digits> } | ||
| 390 : | <exponent> := <marker><digits0> | ||
| 391 : | <marker> := {<e-form> | <sign-form>} | ||
| 392 : | <e-form> := <e-char>[<sign-form>] | ||
| 393 : | <sign-form> := { + | - } | ||
| 394 : | <e-char> := { D | d | E | e } | ||
| 395 : | */ | ||
| 396 : | Char *s = c_addr; | ||
| 397 : | Char c; | ||
| 398 : | Char *send = c_addr+u; | ||
| 399 : | UCell ndigits = 0; | ||
| 400 : | UCell ndots = 0; | ||
| 401 : | UCell edigits = 0; | ||
| 402 : | char cnum[u+3]; /* append at most "e0\0" */ | ||
| 403 : | char *t=cnum; | ||
| 404 : | char *endconv; | ||
| 405 : | anton | 1.5 | Float r; |
| 406 : | anton | 1.28 | |
| 407 : | if (s >= send) /* treat empty string as 0e */ | ||
| 408 : | goto return0; | ||
| 409 : | switch ((c=*s)) { | ||
| 410 : | case ' ': | ||
| 411 : | /* "A string of blanks should be treated as a special case | ||
| 412 : | representing zero."*/ | ||
| 413 : | for (s++; s<send; ) | ||
| 414 : | if (*s++ != ' ') | ||
| 415 : | goto error; | ||
| 416 : | goto return0; | ||
| 417 : | case '-': | ||
| 418 : | case '+': *t++ = c; s++; goto aftersign; | ||
| 419 : | } | ||
| 420 : | aftersign: | ||
| 421 : | if (s >= send) | ||
| 422 : | goto exponent; | ||
| 423 : | switch (c=*s) { | ||
| 424 : | case '0' ... '9': *t++ = c; ndigits++; s++; goto aftersign; | ||
| 425 : | case '.': *t++ = c; ndots++; s++; goto aftersign; | ||
| 426 : | default: goto exponent; | ||
| 427 : | } | ||
| 428 : | exponent: | ||
| 429 : | if (ndigits < 1 || ndots > 1) | ||
| 430 : | goto error; | ||
| 431 : | *t++ = 'E'; | ||
| 432 : | if (s >= send) | ||
| 433 : | goto done; | ||
| 434 : | switch (c=*s) { | ||
| 435 : | case 'D': | ||
| 436 : | anton | 1.5 | case 'd': |
| 437 : | anton | 1.28 | case 'E': |
| 438 : | case 'e': s++; break; | ||
| 439 : | anton | 1.5 | } |
| 440 : | anton | 1.28 | if (s >= send) |
| 441 : | goto done; | ||
| 442 : | switch (c=*s) { | ||
| 443 : | case '+': | ||
| 444 : | case '-': *t++ = c; s++; break; | ||
| 445 : | } | ||
| 446 : | edigits0: | ||
| 447 : | if (s >= send) | ||
| 448 : | goto done; | ||
| 449 : | switch (c=*s) { | ||
| 450 : | case '0' ... '9': *t++ = c; s++; edigits++; goto edigits0; | ||
| 451 : | default: goto error; | ||
| 452 : | } | ||
| 453 : | done: | ||
| 454 : | if (edigits == 0) | ||
| 455 : | *t++ = '0'; | ||
| 456 : | *t++ = '\0'; | ||
| 457 : | assert(t-cnum <= u+3); | ||
| 458 : | r = strtod(cnum, &endconv); | ||
| 459 : | assert(*endconv == '\0'); | ||
| 460 : | anton | 1.5 | *rp = r; |
| 461 : | anton | 1.28 | return -1; |
| 462 : | return0: | ||
| 463 : | *rp = 0.0; | ||
| 464 : | return -1; | ||
| 465 : | error: | ||
| 466 : | *rp = 0.0; | ||
| 467 : | return 0; | ||
| 468 : | anton | 1.5 | } |
| 469 : | pazsan | 1.22 | #endif |
| 470 : | anton | 1.5 | |
| 471 : | pazsan | 1.25 | #ifdef HAS_FLOATING |
| 472 : | anton | 1.5 | Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount) |
| 473 : | { | ||
| 474 : | Float r; | ||
| 475 : | |||
| 476 : | for (r=0.; ucount>0; ucount--) { | ||
| 477 : | r += *f_addr1 * *f_addr2; | ||
| 478 : | f_addr1 = (Float *)(((Address)f_addr1)+nstride1); | ||
| 479 : | f_addr2 = (Float *)(((Address)f_addr2)+nstride2); | ||
| 480 : | } | ||
| 481 : | return r; | ||
| 482 : | } | ||
| 483 : | |||
| 484 : | void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount) | ||
| 485 : | { | ||
| 486 : | for (; ucount>0; ucount--) { | ||
| 487 : | *f_y += ra * *f_x; | ||
| 488 : | f_x = (Float *)(((Address)f_x)+nstridex); | ||
| 489 : | f_y = (Float *)(((Address)f_y)+nstridey); | ||
| 490 : | } | ||
| 491 : | anton | 1.1 | } |
| 492 : | pazsan | 1.24 | #endif |
| 493 : | pazsan | 1.9 | |
| 494 : | UCell lshift(UCell u1, UCell n) | ||
| 495 : | { | ||
| 496 : | return u1 << n; | ||
| 497 : | } | ||
| 498 : | |||
| 499 : | UCell rshift(UCell u1, UCell n) | ||
| 500 : | { | ||
| 501 : | return u1 >> n; | ||
| 502 : | anton | 1.10 | } |
| 503 : | |||
| 504 : | pazsan | 1.24 | #ifndef STANDALONE |
| 505 : | anton | 1.10 | int gforth_system(Char *c_addr, UCell u) |
| 506 : | { | ||
| 507 : | int retval; | ||
| 508 : | char *prefix = getenv("GFORTHSYSTEMPREFIX") ? : DEFAULTSYSTEMPREFIX; | ||
| 509 : | size_t prefixlen = strlen(prefix); | ||
| 510 : | char buffer[prefixlen+u+1]; | ||
| 511 : | anton | 1.39 | fflush(stdout); |
| 512 : | anton | 1.10 | #ifndef MSDOS |
| 513 : | int old_tp=terminal_prepped; | ||
| 514 : | deprep_terminal(); | ||
| 515 : | #endif | ||
| 516 : | memcpy(buffer,prefix,prefixlen); | ||
| 517 : | memcpy(buffer+prefixlen,c_addr,u); | ||
| 518 : | buffer[prefixlen+u]='\0'; | ||
| 519 : | retval=system(buffer); /* ~ expansion on first part of string? */ | ||
| 520 : | #ifndef MSDOS | ||
| 521 : | if (old_tp) | ||
| 522 : | prep_terminal(); | ||
| 523 : | #endif | ||
| 524 : | return retval; | ||
| 525 : | pazsan | 1.9 | } |
| 526 : | anton | 1.26 | |
| 527 : | void gforth_ms(UCell u) | ||
| 528 : | { | ||
| 529 : | #ifdef HAVE_NANOSLEEP | ||
| 530 : | struct timespec time_req; | ||
| 531 : | time_req.tv_sec=u/1000; | ||
| 532 : | time_req.tv_nsec=1000000*(u%1000); | ||
| 533 : | while(nanosleep(&time_req, &time_req)); | ||
| 534 : | #else /* !defined(HAVE_NANOSLEEP) */ | ||
| 535 : | struct timeval timeout; | ||
| 536 : | timeout.tv_sec=u/1000; | ||
| 537 : | timeout.tv_usec=1000*(u%1000); | ||
| 538 : | (void)select(0,0,0,0,&timeout); | ||
| 539 : | #endif /* !defined(HAVE_NANOSLEEP) */ | ||
| 540 : | } | ||
| 541 : | pazsan | 1.33 | |
| 542 : | UCell gforth_dlopen(Char *c_addr, UCell u) | ||
| 543 : | { | ||
| 544 : | char * file=tilde_cstr(c_addr, u, 1); | ||
| 545 : | pazsan | 1.36 | UCell lib; |
| 546 : | pazsan | 1.34 | #if defined(HAVE_LIBLTDL) |
| 547 : | lib = (UCell)lt_dlopen(file); | ||
| 548 : | if(lib) return lib; | ||
| 549 : | pazsan | 1.33 | #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
| 550 : | #ifndef RTLD_GLOBAL | ||
| 551 : | #define RTLD_GLOBAL 0 | ||
| 552 : | #endif | ||
| 553 : | pazsan | 1.34 | lib = (UCell)dlopen(file, RTLD_GLOBAL | RTLD_LAZY); |
| 554 : | if(lib) return lib; | ||
| 555 : | #elif defined(_WIN32) | ||
| 556 : | lib = (UCell) GetModuleHandle(file); | ||
| 557 : | if(lib) return lib; | ||
| 558 : | #endif | ||
| 559 : | pazsan | 1.33 | return 0; |
| 560 : | } | ||
| 561 : | |||
| 562 : | anton | 1.26 | #endif /* !defined(STANDALONE) */ |
| 563 : | |||
| 564 : | anton | 1.16 | |
| 565 : | anton | 1.17 | /* mixed division support; should usually be faster than gcc's |
| 566 : | anton | 1.16 | double-by-double division (and gcc typically does not generate |
| 567 : | double-by-single division because of exception handling issues. If | ||
| 568 : | the architecture has double-by-single division, you should define | ||
| 569 : | anton | 1.17 | ASM_SM_SLASH_REM and ASM_UM_SLASH_MOD appropriately. */ |
| 570 : | anton | 1.16 | |
| 571 : | anton | 1.17 | /* Type definitions for longlong.h (according to the comments at the start): |
| 572 : | declarations taken from libgcc2.h */ | ||
| 573 : | |||
| 574 : | typedef unsigned int UQItype __attribute__ ((mode (QI))); | ||
| 575 : | typedef int SItype __attribute__ ((mode (SI))); | ||
| 576 : | typedef unsigned int USItype __attribute__ ((mode (SI))); | ||
| 577 : | typedef int DItype __attribute__ ((mode (DI))); | ||
| 578 : | typedef unsigned int UDItype __attribute__ ((mode (DI))); | ||
| 579 : | typedef UCell UWtype; | ||
| 580 : | #if (SIZEOF_CHAR_P == 4) | ||
| 581 : | typedef unsigned int UHWtype __attribute__ ((mode (HI))); | ||
| 582 : | #endif | ||
| 583 : | #if (SIZEOF_CHAR_P == 8) | ||
| 584 : | typedef USItype UHWtype; | ||
| 585 : | #endif | ||
| 586 : | #ifndef BUGGY_LONG_LONG | ||
| 587 : | typedef UDCell UDWtype; | ||
| 588 : | #endif | ||
| 589 : | #define W_TYPE_SIZE (SIZEOF_CHAR_P * 8) | ||
| 590 : | |||
| 591 : | #include "longlong.h" | ||
| 592 : | |||
| 593 : | anton | 1.37 | |
| 594 : | anton | 1.27 | #if defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION |
| 595 : | anton | 1.37 | |
| 596 : | #if defined(count_leading_zeros) | ||
| 597 : | const UQItype __clz_tab[256] = | ||
| 598 : | { | ||
| 599 : | 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, | ||
| 600 : | 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, | ||
| 601 : | 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, | ||
| 602 : | 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, | ||
| 603 : | 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, | ||
| 604 : | 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, | ||
| 605 : | 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, | ||
| 606 : | 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 | ||
| 607 : | }; | ||
| 608 : | #endif | ||
| 609 : | |||
| 610 : | anton | 1.17 | static Cell MAYBE_UNUSED nlz(UCell x) |
| 611 : | anton | 1.16 | /* number of leading zeros, adapted from "Hacker's Delight" */ |
| 612 : | { | ||
| 613 : | Cell n; | ||
| 614 : | |||
| 615 : | anton | 1.17 | #if !defined(COUNT_LEADING_ZEROS_0) |
| 616 : | anton | 1.16 | if (x == 0) return(CELL_BITS); |
| 617 : | anton | 1.17 | #endif |
| 618 : | #if defined(count_leading_zeros) | ||
| 619 : | count_leading_zeros(n,x); | ||
| 620 : | #else | ||
| 621 : | anton | 1.16 | n = 0; |
| 622 : | #if (SIZEOF_CHAR_P > 4) | ||
| 623 : | anton | 1.27 | if (x <= 0xffffffff) |
| 624 : | n+=32; | ||
| 625 : | else | ||
| 626 : | x >>= 32; | ||
| 627 : | anton | 1.16 | #endif |
| 628 : | if (x <= 0x0000FFFF) {n = n +16; x = x <<16;} | ||
| 629 : | if (x <= 0x00FFFFFF) {n = n + 8; x = x << 8;} | ||
| 630 : | if (x <= 0x0FFFFFFF) {n = n + 4; x = x << 4;} | ||
| 631 : | if (x <= 0x3FFFFFFF) {n = n + 2; x = x << 2;} | ||
| 632 : | if (x <= 0x7FFFFFFF) {n = n + 1;} | ||
| 633 : | anton | 1.17 | #endif |
| 634 : | anton | 1.16 | return n; |
| 635 : | } | ||
| 636 : | anton | 1.27 | #endif /*defined(udiv_qrnnd) && !defined(__alpha) && UDIV_NEEDS_NORMALIZATION*/ |
| 637 : | anton | 1.16 | |
| 638 : | anton | 1.17 | #if !defined(ASM_UM_SLASH_MOD) |
| 639 : | anton | 1.16 | UDCell umdiv (UDCell u, UCell v) |
| 640 : | /* Divide unsigned double by single precision using shifts and subtracts. | ||
| 641 : | Return quotient in lo, remainder in hi. */ | ||
| 642 : | { | ||
| 643 : | anton | 1.17 | UDCell res; |
| 644 : | anton | 1.27 | #if defined(udiv_qrnnd) && !defined(__alpha) |
| 645 : | #if 0 | ||
| 646 : | This code is slower on an Alpha (timings with gcc-3.3.5): | ||
| 647 : | other this | ||
| 648 : | */ 5205 ms 5741 ms | ||
| 649 : | */mod 5167 ms 5717 ms | ||
| 650 : | fm/mod 5467 ms 5312 ms | ||
| 651 : | sm/rem 4734 ms 5278 ms | ||
| 652 : | um/mod 4490 ms 5020 ms | ||
| 653 : | m*/ 15557 ms 17151 ms | ||
| 654 : | #endif /* 0 */ | ||
| 655 : | anton | 1.17 | UCell q,r,u0,u1; |
| 656 : | UCell MAYBE_UNUSED lz; | ||
| 657 : | |||
| 658 : | vm_ud2twoCell(u,u0,u1); | ||
| 659 : | if (v==0) | ||
| 660 : | throw(BALL_DIVZERO); | ||
| 661 : | if (u1>=v) | ||
| 662 : | throw(BALL_RESULTRANGE); | ||
| 663 : | #if UDIV_NEEDS_NORMALIZATION | ||
| 664 : | lz = nlz(v); | ||
| 665 : | v <<= lz; | ||
| 666 : | anton | 1.19 | u = UDLSHIFT(u,lz); |
| 667 : | anton | 1.17 | vm_ud2twoCell(u,u0,u1); |
| 668 : | #endif | ||
| 669 : | udiv_qrnnd(q,r,u1,u0,v); | ||
| 670 : | #if UDIV_NEEDS_NORMALIZATION | ||
| 671 : | r >>= lz; | ||
| 672 : | #endif | ||
| 673 : | vm_twoCell2ud(q,r,res); | ||
| 674 : | anton | 1.27 | #else /* !(defined(udiv_qrnnd) && !defined(__alpha)) */ |
| 675 : | anton | 1.16 | /* simple restoring subtract-and-shift algorithm, might be faster on Alpha */ |
| 676 : | int i = CELL_BITS, c = 0; | ||
| 677 : | UCell q = 0; | ||
| 678 : | anton | 1.27 | UCell h, l; |
| 679 : | anton | 1.16 | |
| 680 : | vm_ud2twoCell(u,l,h); | ||
| 681 : | if (v==0) | ||
| 682 : | throw(BALL_DIVZERO); | ||
| 683 : | if (h>=v) | ||
| 684 : | throw(BALL_RESULTRANGE); | ||
| 685 : | for (;;) | ||
| 686 : | { | ||
| 687 : | if (c || h >= v) | ||
| 688 : | { | ||
| 689 : | q++; | ||
| 690 : | h -= v; | ||
| 691 : | } | ||
| 692 : | if (--i < 0) | ||
| 693 : | break; | ||
| 694 : | c = HIGHBIT (h); | ||
| 695 : | h <<= 1; | ||
| 696 : | h += HIGHBIT (l); | ||
| 697 : | l <<= 1; | ||
| 698 : | q <<= 1; | ||
| 699 : | } | ||
| 700 : | vm_twoCell2ud(q,h,res); | ||
| 701 : | anton | 1.27 | #endif /* !(defined(udiv_qrnnd) && !defined(__alpha)) */ |
| 702 : | anton | 1.16 | return res; |
| 703 : | } | ||
| 704 : | #endif | ||
| 705 : | |||
| 706 : | #if !defined(ASM_SM_SLASH_REM) | ||
| 707 : | #if defined(ASM_UM_SLASH_MOD) | ||
| 708 : | /* define it if it is not defined above */ | ||
| 709 : | anton | 1.17 | static UDCell MAYBE_UNUSED umdiv (UDCell u, UCell v) |
| 710 : | anton | 1.16 | { |
| 711 : | UDCell res; | ||
| 712 : | UCell u0,u1; | ||
| 713 : | vm_ud2twoCell(u,u0,u1); | ||
| 714 : | ASM_UM_SLASH_MOD(u0,u1,v,r,q); | ||
| 715 : | vm_twoCell2ud(q,r,res); | ||
| 716 : | return res; | ||
| 717 : | } | ||
| 718 : | #endif /* defined(ASM_UM_SLASH_MOD) */ | ||
| 719 : | |||
| 720 : | #ifndef BUGGY_LONG_LONG | ||
| 721 : | #define dnegate(x) (-(x)) | ||
| 722 : | #endif | ||
| 723 : | |||
| 724 : | anton | 1.17 | DCell smdiv (DCell num, Cell denom) |
| 725 : | /* symmetric divide procedure, mixed prec */ | ||
| 726 : | anton | 1.16 | { |
| 727 : | DCell res; | ||
| 728 : | anton | 1.17 | #if defined(sdiv_qrnnd) |
| 729 : | anton | 1.32 | /* #warning "using sdiv_qrnnd" */ |
| 730 : | anton | 1.17 | Cell u1,q,r |
| 731 : | UCell u0; | ||
| 732 : | UCell MAYBE_UNUSED lz; | ||
| 733 : | |||
| 734 : | vm_d2twoCell(u,u0,u1); | ||
| 735 : | if (v==0) | ||
| 736 : | throw(BALL_DIVZERO); | ||
| 737 : | if (u1>=v) | ||
| 738 : | throw(BALL_RESULTRANGE); | ||
| 739 : | sdiv_qrnnd(q,r,u1,u0,v); | ||
| 740 : | vm_twoCell2d(q,r,res); | ||
| 741 : | #else | ||
| 742 : | anton | 1.16 | UDCell ures; |
| 743 : | UCell l, q, r; | ||
| 744 : | Cell h; | ||
| 745 : | Cell denomsign=denom; | ||
| 746 : | |||
| 747 : | vm_d2twoCell(num,l,h); | ||
| 748 : | if (h < 0) | ||
| 749 : | num = dnegate (num); | ||
| 750 : | if (denomsign < 0) | ||
| 751 : | denom = -denom; | ||
| 752 : | ures = umdiv(D2UD(num), denom); | ||
| 753 : | vm_ud2twoCell(ures,q,r); | ||
| 754 : | if ((h^denomsign)<0) { | ||
| 755 : | q = -q; | ||
| 756 : | if (((Cell)q) > 0) /* note: == 0 is possible */ | ||
| 757 : | throw(BALL_RESULTRANGE); | ||
| 758 : | } else { | ||
| 759 : | if (((Cell)q) < 0) | ||
| 760 : | throw(BALL_RESULTRANGE); | ||
| 761 : | } | ||
| 762 : | if (h<0) | ||
| 763 : | r = -r; | ||
| 764 : | vm_twoCell2d(q,r,res); | ||
| 765 : | anton | 1.17 | #endif |
| 766 : | anton | 1.16 | return res; |
| 767 : | } | ||
| 768 : | |||
| 769 : | anton | 1.17 | DCell fmdiv (DCell num, Cell denom) |
| 770 : | /* floored divide procedure, mixed prec */ | ||
| 771 : | anton | 1.16 | { |
| 772 : | /* I have this technique from Andrew Haley */ | ||
| 773 : | DCell res; | ||
| 774 : | UDCell ures; | ||
| 775 : | Cell denomsign=denom; | ||
| 776 : | Cell numsign; | ||
| 777 : | UCell q,r; | ||
| 778 : | |||
| 779 : | if (denom < 0) { | ||
| 780 : | denom = -denom; | ||
| 781 : | num = dnegate(num); | ||
| 782 : | } | ||
| 783 : | numsign = DHI(num); | ||
| 784 : | if (numsign < 0) | ||
| 785 : | DHI_IS(num,DHI(num)+denom); | ||
| 786 : | ures = umdiv(D2UD(num),denom); | ||
| 787 : | vm_ud2twoCell(ures,q,r); | ||
| 788 : | if ((numsign^((Cell)q)) < 0) | ||
| 789 : | throw(BALL_RESULTRANGE); | ||
| 790 : | if (denomsign<0) | ||
| 791 : | r = -r; | ||
| 792 : | vm_twoCell2d(q,r,res); | ||
| 793 : | return res; | ||
| 794 : | } | ||
| 795 : | #endif |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |