File:  [gforth] / gforth / engine / forth.h
Revision 1.102: download - view: text, annotated - select for diffs
Thu Oct 9 16:30:56 2008 UTC (15 years, 5 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added gforth_dlopen as support word

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

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