File:  [gforth] / gforth / engine / forth.h
Revision 1.55: download - view: text, annotated - select for diffs
Fri Aug 22 08:08:46 2003 UTC (18 years, 3 months ago) by anton
Branches: MAIN
CVS tags: v0-6-2, HEAD
fixed bugs in doer routines (showed up with threadng scheme 1)
testdist portability improvements

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

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