File:  [gforth] / gforth / engine / forth.h
Revision 1.61: download - view: text, annotated - select for diffs
Fri Aug 27 15:53:51 2004 UTC (19 years, 7 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added and documented usage of $GFORTHSYSTEMPREFIX to SYSTEM
eliminated the now-unused (does>1)

    1: /* common header file
    2: 
    3:   Copyright (C) 1995,1996,1997,1998,2000,2003 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: 
   27: #if defined(DOUBLY_INDIRECT)||defined(INDIRECT_THREADED)||defined(VM_PROFILING)
   28: #define NO_DYNAMIC
   29: #endif
   30: 
   31: #if defined(DOUBLY_INDIRECT)
   32: #  undef DIRECT_THREADED
   33: #  undef INDIRECT_THREADED
   34: #  define INDIRECT_THREADED
   35: #endif
   36: 
   37: #if defined(GFORTH_DEBUGGING) || defined(INDIRECT_THREADED) || defined(DOUBLY_INDIRECT) || defined(VM_PROFILING)
   38: #  undef USE_TOS
   39: #  undef USE_FTOS
   40: #  undef USE_NO_TOS
   41: #  undef USE_NO_FTOS
   42: #  define USE_NO_TOS
   43: #  define USE_NO_FTOS
   44: 
   45: #define PRIM_I "prim.i"
   46: #define PRIM_LAB_I "prim_lab.i"
   47: #define PRIM_NAMES_I "prim_names.i"
   48: #define PRIM_SUPEREND_I "prim_superend.i"
   49: #define PRIM_NUM_I "prim_num.i"
   50: #define PRIM_GRP_I "prim_grp.i"
   51: #define COSTS_I "costs.i"
   52: #define SUPER2_I "super2.i"
   53: /* #define PROFILE_I "profile.i" */
   54: 
   55: #else
   56: /* gforth-fast or gforth-native */
   57: #  undef USE_TOS
   58: #  undef USE_FTOS
   59: #  undef USE_NO_TOS
   60: #  undef USE_NO_FTOS
   61: #  define USE_TOS
   62: #  define USE_NO_FTOS
   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 DODOES	6
   94: #define DOESJUMP	7
   95: 
   96: /* the size of the DOESJUMP, which resides between DOES> and the does-code */
   97: #define DOES_HANDLER_SIZE	(2*sizeof(Cell))
   98: 
   99: #include "machine.h"
  100: 
  101: /* Forth data types */
  102: /* Cell and UCell must be the same size as a pointer */
  103: #define CELL_BITS	(sizeof(Cell) * CHAR_BIT)
  104: #define FLAG(b) (-(b))
  105: #define FILEIO(error)	(FLAG(error) & -37)
  106: #define FILEEXIST(error)	(FLAG(error) & -38)
  107: 
  108: #define F_TRUE (FLAG(0==0))
  109: #define F_FALSE (FLAG(0!=0))
  110: 
  111: #ifdef BUGGY_LONG_LONG
  112: typedef struct {
  113:   Cell hi;
  114:   UCell lo;
  115: } DCell;
  116: 
  117: typedef struct {
  118:   UCell hi;
  119:   UCell lo;
  120: } UDCell;
  121: 
  122: #if SMALL_OFF_T
  123: #define OFF2UD(o) ({UDCell _ud; _ud.hi=0; _ud.lo=(Cell)(o); _ud;})
  124: #define UD2OFF(ud) ((ud).lo)
  125: #else /* !SMALL_OFF_T */
  126: #define OFF2UD(o) ({UDCell _ud; off_t _o=(o); _ud.hi=_o>>CELL_BITS; _ud.lo=(Cell)_o; _ud;})
  127: #define UD2OFF(ud) ({UDCell _ud=(ud); (((off_t)_ud.hi)<<CELL_BITS)+_ud.lo;})
  128: #endif /* !SMALL_OFF_T */
  129: #define DZERO		((DCell){0,0})
  130: 
  131: #else /* ! defined(BUGGY_LONG_LONG) */
  132: 
  133: /* DCell and UDCell must be twice as large as Cell */
  134: typedef DOUBLE_CELL_TYPE DCell;
  135: typedef unsigned DOUBLE_CELL_TYPE UDCell;
  136: 
  137: #define OFF2UD(o)	((UDCell)(o))
  138: #define UD2OFF(ud)	((off_t)(ud))
  139: #define DZERO		((DCell)0)
  140: 
  141: #endif /* ! defined(BUGGY_LONG_LONG) */
  142: 
  143: typedef union {
  144:   struct {
  145: #if defined(WORDS_BIGENDIAN)||defined(BUGGY_LONG_LONG)
  146:     Cell high;
  147:     UCell low;
  148: #else
  149:     UCell low;
  150:     Cell high;
  151: #endif
  152:   } cells;
  153:   DCell d;
  154:   UDCell ud;
  155: } Double_Store;
  156: 
  157: #define FETCH_DCELL_T(d_,lo,hi,t_)	({ \
  158: 				     Double_Store _d; \
  159: 				     _d.cells.low = (lo); \
  160: 				     _d.cells.high = (hi); \
  161: 				     (d_) = _d.t_; \
  162: 				 })
  163: 
  164: #define STORE_DCELL_T(d_,lo,hi,t_)	({ \
  165: 				     Double_Store _d; \
  166: 				     _d.t_ = (d_); \
  167: 				     (lo) = _d.cells.low; \
  168: 				     (hi) = _d.cells.high; \
  169: 				 })
  170: 
  171: #define vm_twoCell2d(lo,hi,d_)  FETCH_DCELL_T(d_,lo,hi,d);
  172: #define vm_twoCell2ud(lo,hi,d_) FETCH_DCELL_T(d_,lo,hi,ud);
  173: 
  174: #define vm_d2twoCell(d_,lo,hi)  STORE_DCELL_T(d_,lo,hi,d);
  175: #define vm_ud2twoCell(d_,lo,hi) STORE_DCELL_T(d_,lo,hi,ud);
  176: 
  177: typedef Label *Xt;
  178: 
  179: /* PFA gives the parameter field address corresponding to a cfa */
  180: #define PFA(cfa)	(((Cell *)cfa)+2)
  181: /* PFA1 is a special version for use just after a NEXT1 */
  182: #define PFA1(cfa)	PFA(cfa)
  183: /* CODE_ADDRESS is the address of the code jumped to through the code field */
  184: #define CODE_ADDRESS(cfa)	(*(Xt)(cfa))
  185: 
  186: /* DOES_CODE is the Forth code does jumps to */
  187: #if !defined(DOUBLY_INDIRECT)
  188: #  define DOES_CA (symbols[DODOES])
  189: #else /* defined(DOUBLY_INDIRECT) */
  190: #  define DOES_CA ((Label)&xts[DODOES])
  191: #endif /* defined(DOUBLY_INDIRECT) */
  192: 
  193: 
  194: 
  195: #define DOES_CODE1(cfa)	((Xt *)(cfa[1]))
  196: /* MAKE_CF creates an appropriate code field at the cfa;
  197:    ca is the code address */
  198: #define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca))
  199: /* make a code field for a defining-word-defined word */
  200: #define MAKE_DOES_CF(cfa,does_code)  ({MAKE_CF(cfa,DOES_CA);	\
  201: 				       ((Cell *)cfa)[1] = (Cell)(does_code);})
  202: 
  203: #define CF(const)	(-const-2)
  204: 
  205: #define CF_NIL	-1
  206: 
  207: #ifndef FLUSH_ICACHE
  208: #warning flush-icache probably will not work (see manual)
  209: #	define FLUSH_ICACHE(addr,size)
  210: #warning no FLUSH_ICACHE, turning off dynamic native code by default
  211: #undef NO_DYNAMIC_DEFAULT
  212: #define NO_DYNAMIC_DEFAULT 1
  213: #endif
  214: 
  215: #ifdef USE_TOS
  216: #define IF_spTOS(x) x
  217: #else
  218: #define IF_spTOS(x)
  219: #define spTOS (sp[0])
  220: #endif
  221: 
  222: #ifdef USE_FTOS
  223: #define IF_fpTOS(x) x
  224: #else
  225: #define IF_fpTOS(x)
  226: #define fpTOS (fp[0])
  227: #endif
  228: 
  229: #define IF_rpTOS(x)
  230: #define rpTOS (rp[0])
  231: 
  232: typedef struct {
  233:   Address base;		/* base address of image (0 if relocatable) */
  234:   UCell checksum;	/* checksum of ca's to protect against some
  235: 			   incompatible	binary/executable combinations
  236: 			   (0 if relocatable) */
  237:   UCell image_size;	/* all sizes in bytes */
  238:   UCell dict_size;
  239:   UCell data_stack_size;
  240:   UCell fp_stack_size;
  241:   UCell return_stack_size;
  242:   UCell locals_stack_size;
  243:   Xt *boot_entry;	/* initial ip for booting (in BOOT) */
  244:   Xt *throw_entry;	/* ip after signal (in THROW) */
  245:   Cell unused1;		/* possibly tib stack size */
  246:   Label *xt_base;         /* base of DOUBLE_INDIRECT xts[], for comp-i.fs */
  247:   Address data_stack_base; /* this and the following fields are initialized by the loader */
  248:   Address fp_stack_base;
  249:   Address return_stack_base;
  250:   Address locals_stack_base;
  251: } ImageHeader;
  252: /* the image-header is created in main.fs */
  253: 
  254: struct Longname {
  255:   struct Longname *next;  /* the link field for old hands */
  256:   Cell		countetc;
  257:   char		name[0];
  258: };
  259: 
  260: #define LONGNAME_COUNT(np)	((np)->countetc & (((~((UCell)0))<<3)>>3))
  261: 
  262: struct Cellpair {
  263:   Cell n1;
  264:   Cell n2;
  265: };
  266: 
  267: struct Cellquad {
  268:   Cell n1;
  269:   Cell n2;
  270:   Cell n3;
  271:   Cell n4;
  272: };
  273: 
  274: #define IOR(flag)	((flag)? -512-errno : 0)
  275: 
  276: Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  277: Label *engine2(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  278: Label *engine3(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  279: 
  280: /* engine/prim support routines */
  281: Address my_alloc(Cell size);
  282: char *cstr(Char *from, UCell size, int clear);
  283: char *tilde_cstr(Char *from, UCell size, int clear);
  284: DCell timeval2us(struct timeval *tvp);
  285: void cmove(Char *c_from, Char *c_to, UCell u);
  286: void cmove_up(Char *c_from, Char *c_to, UCell u);
  287: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2);
  288: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1);
  289: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr);
  290: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr);
  291: UCell hashkey1(Char *c_addr, UCell u, UCell ubits);
  292: struct Cellpair parse_white(Char *c_addr1, UCell u1);
  293: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2);
  294: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid);
  295: struct Cellpair file_status(Char *c_addr, UCell u);
  296: Cell to_float(Char *c_addr, UCell u, Float *rp);
  297: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount);
  298: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount);
  299: UCell lshift(UCell u1, UCell n);
  300: UCell rshift(UCell u1, UCell n);
  301: int gforth_system(Char *c_addr, UCell u);
  302: 
  303: 
  304: /* signal handler stuff */
  305: void install_signal_handlers(void);
  306: typedef void Sigfunc(int);
  307: Sigfunc *bsd_signal(int signo, Sigfunc *func);
  308: 
  309: /* dblsub routines */
  310: DCell dnegate(DCell d1);
  311: UDCell ummul (UCell a, UCell b);
  312: DCell mmul (Cell a, Cell b);
  313: UDCell umdiv (UDCell u, UCell v);
  314: DCell smdiv (DCell num, Cell denom);
  315: DCell fmdiv (DCell num, Cell denom);
  316: 
  317: Cell memcasecmp(const Char *s1, const Char *s2, Cell n);
  318: 
  319: void vm_print_profile(FILE *file);
  320: void vm_count_block(Xt *ip);
  321: 
  322: /* dynamic superinstruction stuff */
  323: void compile_prim1(Cell *start);
  324: void finish_code(void);
  325: int forget_dyncode(Address code);
  326: Label decompile_code(Label prim);
  327: 
  328: extern int offset_image;
  329: extern int die_on_signal;
  330: extern UCell pagesize;
  331: extern ImageHeader *gforth_header;
  332: extern Label *vm_prims;
  333: extern Label *xts;
  334: extern Cell npriminfos;
  335: 
  336: #ifdef HAS_DEBUG
  337: extern int debug;
  338: #else
  339: # define debug 0
  340: #endif
  341: 
  342: extern Cell *SP;
  343: extern Float *FP;
  344: extern Address UP;
  345: 
  346: #ifdef HAS_FFCALL
  347: extern Cell *RP;
  348: extern Address LP;
  349: extern void engine_callback(Xt* fcall, void * alist);
  350: #endif
  351: 
  352: #ifdef GFORTH_DEBUGGING
  353: extern Xt *saved_ip;
  354: extern Cell *rp;
  355: #endif
  356: 
  357: #ifdef NO_IP
  358: extern Label next_code;
  359: #endif
  360: 
  361: #ifdef HAS_FILE
  362: extern char* fileattr[6];
  363: extern char* pfileattr[6];
  364: extern int ufileattr[6];
  365: #endif
  366: 
  367: #ifdef PRINT_SUPER_LENGTHS
  368: Cell prim_length(Cell prim);
  369: void print_super_lengths();
  370: #endif
  371: 
  372: /* declare all the functions that are missing */
  373: #ifndef HAVE_ATANH
  374: extern double atanh(double r1);
  375: extern double asinh(double r1);
  376: extern double acosh(double r1);
  377: #endif
  378: #ifndef HAVE_ECVT
  379: /* extern char* ecvt(double x, int len, int* exp, int* sign);*/
  380: #endif
  381: #ifndef HAVE_MEMMOVE
  382: /* extern char *memmove(char *dest, const char *src, long n); */
  383: #endif
  384: #ifndef HAVE_POW10
  385: extern double pow10(double x);
  386: #endif
  387: #ifndef HAVE_STRERROR
  388: extern char *strerror(int err);
  389: #endif
  390: #ifndef HAVE_STRSIGNAL
  391: extern char *strsignal(int sig);
  392: #endif
  393: #ifndef HAVE_STRTOUL
  394: extern unsigned long int strtoul(const char *nptr, char **endptr, int base);
  395: #endif
  396: 
  397: 
  398: #define GROUP(x, n)
  399: #define GROUPADD(n)

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