File:  [gforth] / gforth / engine / forth.h
Revision 1.87: download - view: text, annotated - select for diffs
Tue Dec 4 14:55:03 2007 UTC (16 years, 3 months ago) by anton
Branches: MAIN
CVS tags: HEAD
libcc.fs now uses libtool
OPEN-LIB and LIB-SYM now call libltdl (libtool) functions
  probably needs some additional adjustment in configure.in
added LIB-ERROR

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

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