1 /* common header file 2 3 Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 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 3 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, see http://www.gnu.org/licenses/. 19 */ 20 21 #include "config.h" 22 #include "128bit.h" 23 #include <stdio.h> 24 #include <sys/time.h> 25 #include <unistd.h> 26 #ifndef STANDALONE 27 #if defined(HAVE_LIBLTDL) 28 #include <ltdl.h> 29 #endif 30 #endif 31 32 #if !defined(FORCE_LL) && !defined(BUGGY_LONG_LONG) 33 #define BUGGY_LONG_LONG 34 #endif 35 36 #if defined(DOUBLY_INDIRECT)||defined(INDIRECT_THREADED)||defined(VM_PROFILING) 37 #define NO_DYNAMIC 38 #endif 39 40 #if defined(DOUBLY_INDIRECT) 41 # undef DIRECT_THREADED 42 # undef INDIRECT_THREADED 43 # define INDIRECT_THREADED 44 #endif 45 46 #if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING) 47 # undef USE_TOS 48 # undef USE_FTOS 49 # undef USE_NO_TOS 50 # undef USE_NO_FTOS 51 # define USE_NO_TOS 52 # define USE_NO_FTOS 53 54 #define PRIM_I "prim.i" 55 #define PRIM_LAB_I "prim_lab.i" 56 #define PRIM_NAMES_I "prim_names.i" 57 #define PRIM_SUPEREND_I "prim_superend.i" 58 #define PRIM_NUM_I "prim_num.i" 59 #define PRIM_GRP_I "prim_grp.i" 60 #define COSTS_I "costs.i" 61 #define SUPER2_I "super2.i" 62 /* #define PROFILE_I "profile.i" */ 63 64 #else 65 /* gforth-fast or gforth-native */ 66 # undef USE_TOS 67 # undef USE_FTOS 68 # undef USE_NO_TOS 69 # undef USE_NO_FTOS 70 # define USE_TOS 71 72 #define PRIM_I "prim-fast.i" 73 #define PRIM_LAB_I "prim_lab-fast.i" 74 #define PRIM_NAMES_I "prim_names-fast.i" 75 #define PRIM_SUPEREND_I "prim_superend-fast.i" 76 #define PRIM_NUM_I "prim_num-fast.i" 77 #define PRIM_GRP_I "prim_grp-fast.i" 78 #define COSTS_I "costs-fast.i" 79 #define SUPER2_I "super2-fast.i" 80 /* profile.c uses profile.i but does not define VM_PROFILING */ 81 /* #define PROFILE_I "profile-fast.i" */ 82 83 #endif 84 85 86 87 #include <limits.h> 88 89 #if defined(NeXT) 90 # include <libc.h> 91 #endif /* NeXT */ 92 93 /* symbol indexed constants */ 94 95 #define DOCOL 0 96 #define DOCON 1 97 #define DOVAR 2 98 #define DOUSER 3 99 #define DODEFER 4 100 #define DOFIELD 5 101 #define DOVAL 6 102 #define DODOES 7 103 #define DOESJUMP 8 104 105 /* the size of the DOESJUMP, which resides between DOES> and the does-code */ 106 #define DOES_HANDLER_SIZE (2*sizeof(Cell)) 107 108 #include "machine.h" 109 110 /* C interface data types */ 111 112 typedef WYDE_TYPE Wyde; 113 typedef TETRABYTE_TYPE Tetrabyte; 114 typedef unsigned WYDE_TYPE UWyde; 115 typedef unsigned TETRABYTE_TYPE UTetrabyte; 116 117 /* Forth data types */ 118 /* Cell and UCell must be the same size as a pointer */ 119 #define CELL_BITS (sizeof(Cell) * CHAR_BIT) 120 #define CELL_MIN (((Cell)1)<<(sizeof(Cell)*CHAR_BIT-1)) 121 122 #define HALFCELL_BITS (CELL_BITS/2) 123 #define HALFCELL_MASK ((~(UCell)0)>>HALFCELL_BITS) 124 #define UH(x) (((UCell)(x))>>HALFCELL_BITS) 125 #define LH(x) ((x)&HALFCELL_MASK) 126 #define L2U(x) (((UCell)(x))<<HALFCELL_BITS) 127 #define HIGHBIT(x) (((UCell)(x))>>(CELL_BITS-1)) 128 129 #define FLAG(b) (-(b)) 130 #define FILEIO(error) (FLAG(error) & -37) 131 #define FILEEXIST(error) (FLAG(error) & -38) 132 133 #define F_TRUE (FLAG(0==0)) 134 #define F_FALSE (FLAG(0!=0)) 135 136 /* define this false if you want native division */ 137 #ifdef FORCE_CDIV 138 #define FLOORED_DIV 0 139 #else 140 #define FLOORED_DIV ((1%-3)>0) 141 #endif 142 143 #if defined(BUGGY_LONG_LONG) 144 145 #define BUGGY_LL_CMP /* compares not possible */ 146 #define BUGGY_LL_MUL /* multiplication not possible */ 147 #define BUGGY_LL_DIV /* division not possible */ 148 #define BUGGY_LL_ADD /* addition not possible */ 149 #define BUGGY_LL_SHIFT /* shift not possible */ 150 #define BUGGY_LL_D2F /* to float not possible */ 151 #define BUGGY_LL_F2D /* from float not possible */ 152 #define BUGGY_LL_SIZE /* long long "too short", so we use something else */ 153 154 typedef struct { 155 Cell hi; 156 UCell lo; 157 } DCell; 158 159 typedef struct { 160 UCell hi; 161 UCell lo; 162 } UDCell; 163 164 #define DHI(x) (x).hi 165 #define DLO(x) (x).lo 166 #define DHI_IS(x,y) (x).hi=(y) 167 #define DLO_IS(x,y) (x).lo=(y) 168 169 #define UD2D(ud) ({UDCell _ud=(ud); (DCell){_ud.hi,_ud.lo};}) 170 #define D2UD(d) ({DCell _d1=(d); (UDCell){_d1.hi,_d1.lo};}) 171 172 /* shifts by less than CELL_BITS */ 173 #define DLSHIFT(d,u) ({DCell _d=(d); UCell _u=(u); \ 174 ((_u==0) ? \ 175 _d : \ 176 (DCell){(_d.hi<<_u)|(_d.lo>>(CELL_BITS-_u)), \ 177 _d.lo<<_u});}) 178 179 #define UDLSHIFT(ud,u) D2UD(DLSHIFT(UD2D(ud),u)) 180 181 #if SMALL_OFF_T 182 #define OFF2UD(o) ({UDCell _ud; _ud.hi=0; _ud.lo=(Cell)(o); _ud;}) 183 #define UD2OFF(ud) ((ud).lo) 184 #else /* !SMALL_OFF_T */ 185 #define OFF2UD(o) ({UDCell _ud; off_t _o=(o); _ud.hi=_o>>CELL_BITS; _ud.lo=(Cell)_o; _ud;}) 186 #define UD2OFF(ud) ({UDCell _ud=(ud); (((off_t)_ud.hi)<<CELL_BITS)+_ud.lo;}) 187 #endif /* !SMALL_OFF_T */ 188 #define DZERO ((DCell){0,0}) 189 190 #else /* !defined(BUGGY_LONG_LONG) */ 191 192 /* DCell and UDCell must be twice as large as Cell */ 193 typedef DOUBLE_CELL_TYPE DCell; 194 typedef DOUBLE_UCELL_TYPE UDCell; 195 196 #define DHI(x) ({ Double_Store _d; _d.d=(x); _d.cells.high; }) 197 #define DLO(x) ({ Double_Store _d; _d.d=(x); _d.cells.low; }) 198 199 /* beware with the assignment: x is referenced twice! */ 200 #define DHI_IS(x,y) ({ Double_Store _d; _d.d=(x); _d.cells.high=(y); (x)=_d.d; }) 201 #define DLO_IS(x,y) ({ Double_Store _d; _d.d=(x); _d.cells.low =(y); (x)=_d.d; }) 202 203 #define UD2D(ud) ((DCell)(ud)) 204 #define D2UD(d) ((UDCell)(d)) 205 #define OFF2UD(o) ((UDCell)(o)) 206 #define UD2OFF(ud) ((off_t)(ud)) 207 #define DZERO ((DCell)0) 208 /* shifts by less than CELL_BITS */ 209 #define DLSHIFT(d,u) ((d)<<(u)) 210 #define UDLSHIFT(d,u) ((d)<<(u)) 211 212 #endif /* !defined(BUGGY_LONG_LONG) */ 213 214 typedef union { 215 struct { 216 #if defined(WORDS_BIGENDIAN)||defined(BUGGY_LONG_LONG) 217 Cell high; 218 UCell low; 219 #else 220 UCell low; 221 Cell high; 222 #endif 223 } cells; 224 DCell d; 225 UDCell ud; 226 } Double_Store; 227 228 #define FETCH_DCELL_T(d_,lo,hi,t_) ({ \ 229 Double_Store _d; \ 230 _d.cells.low = (lo); \ 231 _d.cells.high = (hi); \ 232 (d_) = _d.t_; \ 233 }) 234 235 #define STORE_DCELL_T(d_,lo,hi,t_) ({ \ 236 Double_Store _d; \ 237 _d.t_ = (d_); \ 238 (lo) = _d.cells.low; \ 239 (hi) = _d.cells.high; \ 240 }) 241 242 #define vm_twoCell2d(lo,hi,d_) FETCH_DCELL_T(d_,lo,hi,d); 243 #define vm_twoCell2ud(lo,hi,d_) FETCH_DCELL_T(d_,lo,hi,ud); 244 245 #define vm_d2twoCell(d_,lo,hi) STORE_DCELL_T(d_,lo,hi,d); 246 #define vm_ud2twoCell(d_,lo,hi) STORE_DCELL_T(d_,lo,hi,ud); 247 248 typedef Label *Xt; 249 250 /* PFA gives the parameter field address corresponding to a cfa */ 251 #define PFA(cfa) (((Cell *)cfa)+2) 252 /* PFA1 is a special version for use just after a NEXT1 */ 253 #define PFA1(cfa) PFA(cfa) 254 /* CODE_ADDRESS is the address of the code jumped to through the code field */ 255 #define CODE_ADDRESS(cfa) (*(Xt)(cfa)) 256 257 /* DOES_CODE is the Forth code does jumps to */ 258 #if !defined(DOUBLY_INDIRECT) 259 # define DOES_CA (symbols[DODOES]) 260 #else /* defined(DOUBLY_INDIRECT) */ 261 # define DOES_CA ((Label)&xts[DODOES]) 262 #endif /* defined(DOUBLY_INDIRECT) */ 263 264 265 266 #define DOES_CODE1(cfa) ((Xt *)(cfa[1])) 267 /* MAKE_CF creates an appropriate code field at the cfa; 268 ca is the code address */ 269 #define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca)) 270 /* make a code field for a defining-word-defined word */ 271 #define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,DOES_CA); \ 272 ((Cell *)cfa)[1] = (Cell)(does_code);}) 273 274 #define CF(const) (-const-2) 275 276 #define CF_NIL -1 277 278 #ifndef FLUSH_ICACHE 279 #warning flush-icache probably will not work (see manual) 280 # define FLUSH_ICACHE(addr,size) 281 #warning no FLUSH_ICACHE, turning off dynamic native code by default 282 #undef NO_DYNAMIC_DEFAULT 283 #define NO_DYNAMIC_DEFAULT 1 284 #endif 285 286 #if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING) 287 #define STACK_CACHE_DEFAULT 0 288 #else 289 #define STACK_CACHE_DEFAULT STACK_CACHE_DEFAULT_FAST 290 #endif 291 292 #ifdef USE_FTOS 293 #define IF_fpTOS(x) x 294 #else 295 #define IF_fpTOS(x) 296 #define fpTOS (fp[0]) 297 #endif 298 299 #define IF_rpTOS(x) 300 #define rpTOS (rp[0]) 301 302 typedef struct { 303 Address base; /* base address of image (0 if relocatable) */ 304 UCell checksum; /* checksum of ca's to protect against some 305 incompatible binary/executable combinations 306 (0 if relocatable) */ 307 UCell image_size; /* all sizes in bytes */ 308 UCell dict_size; 309 UCell data_stack_size; 310 UCell fp_stack_size; 311 UCell return_stack_size; 312 UCell locals_stack_size; 313 Xt *boot_entry; /* initial ip for booting (in BOOT) */ 314 Xt *throw_entry; /* ip after signal (in THROW) */ 315 Cell unused1; /* possibly tib stack size */ 316 Label *xt_base; /* base of DOUBLE_INDIRECT xts[], for comp-i.fs */ 317 Address data_stack_base; /* this and the following fields are initialized by the loader */ 318 Address fp_stack_base; 319 Address return_stack_base; 320 Address locals_stack_base; 321 } ImageHeader; 322 /* the image-header is created in main.fs */ 323 324 #ifdef HAS_F83HEADERSTRING 325 struct F83Name { 326 struct F83Name *next; /* the link field for old hands */ 327 char countetc; 328 char name[0]; 329 }; 330 331 #define F83NAME_COUNT(np) ((np)->countetc & 0x1f) 332 #endif 333 struct Longname { 334 struct Longname *next; /* the link field for old hands */ 335 Cell countetc; 336 char name[0]; 337 }; 338 339 #define LONGNAME_COUNT(np) ((np)->countetc & (((~((UCell)0))<<3)>>3)) 340 341 struct Cellpair { 342 Cell n1; 343 Cell n2; 344 }; 345 346 struct Cellquad { 347 Cell n1; 348 Cell n2; 349 Cell n3; 350 Cell n4; 351 }; 352 353 #define IOR(flag) ((flag)? -512-errno : 0) 354 355 #ifdef GFORTH_DEBUGGING 356 #if defined(GLOBALS_NONRELOC) 357 /* if globals cause non-relocatable primitives, keep saved_ip and rp 358 in a structure and access it through locals */ 359 typedef struct saved_regs { 360 Xt *sr_saved_ip; 361 Cell *sr_rp; 362 } saved_regs; 363 extern saved_regs saved_regs_v, *saved_regs_p; 364 #define saved_ip (saved_regs_p->sr_saved_ip) 365 #define rp (saved_regs_p->sr_rp) 366 /* for use in gforth_engine header */ 367 #error sr_proto not passed in fflib.fs callbacks (solution: disable GLOBALS_NONRELOC) 368 #define sr_proto , struct saved_regs *saved_regs_p0 369 #define sr_call , saved_regs_p 370 #else /* !defined(GLOBALS_NONRELOC) */ 371 extern Xt *saved_ip; 372 extern Cell *rp; 373 #define sr_proto 374 #define sr_call 375 #endif /* !defined(GLOBALS_NONRELOC) */ 376 #else /* !defined(GFORTH_DEBUGGING) */ 377 #define sr_proto 378 #define sr_call 379 #endif /* !defined(GFORTH_DEBUGGING) */ 380 381 Label *gforth_engine(Xt *ip, Cell *sp, Cell *rp0, Float *fp, Address lp sr_proto); 382 Label *gforth_engine2(Xt *ip, Cell *sp, Cell *rp0, Float *fp, Address lp sr_proto); 383 Label *gforth_engine3(Xt *ip, Cell *sp, Cell *rp0, Float *fp, Address lp sr_proto); 384 385 /* engine/prim support routines */ 386 Address gforth_alloc(Cell size); 387 char *cstr(Char *from, UCell size, int clear); 388 char *tilde_cstr(Char *from, UCell size, int clear); 389 Cell opencreate_file(char *s, Cell wfam, int flags, Cell *wiorp); 390 DCell timeval2us(struct timeval *tvp); 391 void cmove(Char *c_from, Char *c_to, UCell u); 392 void cmove_up(Char *c_from, Char *c_to, UCell u); 393 Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2); 394 struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1); 395 struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr); 396 struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr); 397 UCell hashkey1(Char *c_addr, UCell u, UCell ubits); 398 struct Cellpair parse_white(Char *c_addr1, UCell u1); 399 Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2); 400 struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid); 401 struct Cellpair file_status(Char *c_addr, UCell u); 402 Cell to_float(Char *c_addr, UCell u, Float *r_p); 403 Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount); 404 void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount); 405 UCell lshift(UCell u1, UCell n); 406 UCell rshift(UCell u1, UCell n); 407 int gforth_system(Char *c_addr, UCell u); 408 void gforth_ms(UCell u); 409 UCell gforth_dlopen(Char *c_addr, UCell u); 410 Cell capscompare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2); 411 412 /* signal handler stuff */ 413 void install_signal_handlers(void); 414 void throw(int code); 415 /* throw codes */ 416 #define BALL_DIVZERO -10 417 #define BALL_RESULTRANGE -11 418 419 typedef void Sigfunc(int); 420 Sigfunc *bsd_signal(int signo, Sigfunc *func); 421 422 /* dblsub routines */ 423 DCell dnegate(DCell d1); 424 UDCell ummul (UCell a, UCell b); 425 DCell mmul (Cell a, Cell b); 426 UDCell umdiv (UDCell u, UCell v); 427 DCell smdiv (DCell num, Cell denom); 428 DCell fmdiv (DCell num, Cell denom); 429 430 Cell memcasecmp(const Char *s1, const Char *s2, Cell n); 431 432 void vm_print_profile(FILE *file); 433 void vm_count_block(Xt *ip); 434 435 /* dynamic superinstruction stuff */ 436 void compile_prim1(Cell *start); 437 void finish_code(void); 438 int forget_dyncode(Address code); 439 Label decompile_code(Label prim); 440 441 extern int offset_image; 442 extern int die_on_signal; 443 extern int ignore_async_signals; 444 extern UCell pagesize; 445 extern ImageHeader *gforth_header; 446 extern Label *vm_prims; 447 extern Label *xts; 448 extern Cell npriminfos; 449 450 #ifdef HAS_DEBUG 451 extern int debug; 452 #else 453 # define debug 0 454 #endif 455 456 extern Cell *gforth_SP; 457 extern Cell *gforth_RP; 458 extern Address gforth_LP; 459 extern Float *gforth_FP; 460 extern Address gforth_UP; 461 #ifndef HAS_LINKBACK 462 extern void * gforth_pointers[]; 463 #endif 464 465 #ifdef HAS_FFCALL 466 extern Cell *gforth_RP; 467 extern Address gforth_LP; 468 extern void gforth_callback(Xt* fcall, void * alist); 469 #endif 470 471 #ifdef NO_IP 472 extern Label next_code; 473 #endif 474 475 #ifdef HAS_FILE 476 extern char* fileattr[6]; 477 extern char* pfileattr[6]; 478 extern int ufileattr[6]; 479 #endif 480 481 #ifdef PRINT_SUPER_LENGTHS 482 Cell prim_length(Cell prim); 483 void print_super_lengths(); 484 #endif 485 486 /* declare all the functions that are missing */ 487 #ifndef HAVE_ATANH 488 extern double atanh(double r1); 489 extern double asinh(double r1); 490 extern double acosh(double r1); 491 #endif 492 #ifndef HAVE_ECVT 493 /* extern char* ecvt(double x, int len, int* exp, int* sign);*/ 494 #endif 495 #ifndef HAVE_MEMMOVE 496 /* extern char *memmove(char *dest, const char *src, long n); */ 497 #endif 498 #ifndef HAVE_POW10 499 extern double pow10(double x); 500 #endif 501 #ifndef HAVE_STRERROR 502 extern char *strerror(int err); 503 #endif 504 #ifndef HAVE_STRSIGNAL 505 extern char *strsignal(int sig); 506 #endif 507 #ifndef HAVE_STRTOUL 508 extern unsigned long int strtoul(const char *nptr, char **endptr, int base); 509 #endif 510 511 #define GROUP(x, n) 512 #define GROUPADD(n) 513