File:  [gforth] / gforth / engine / forth.h
Revision 1.49: download - view: text, annotated - select for diffs
Mon Jan 27 18:59:42 2003 UTC (21 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
minor changes (64-bit-cleanups)

    1: /* common header file
    2: 
    3:   Copyright (C) 1995,1996,1997,1998,2000 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: #ifdef GFORTH_DEBUGGING
  169: #define NAME(string) { saved_ip=ip; asm(""); }
  170: /* the asm here is to avoid reordering of following stuff above the
  171:    assignment; this is an old-style asm (no operands), and therefore
  172:    is treated like "asm volatile ..."; i.e., it prevents most
  173:    reorderings across itself.  We want the assignment above first,
  174:    because the stack loads may already cause a stack underflow. */
  175: #elif DEBUG
  176: #	define	NAME(string)	fprintf(stderr,"%08lx: "string"\n",(Cell)ip);
  177: #else
  178: #	define	NAME(string)
  179: #endif
  180: 
  181: #define CF(const)	(-const-2)
  182: 
  183: #define CF_NIL	-1
  184: 
  185: #ifndef FLUSH_ICACHE
  186: #warning flush-icache probably will not work (see manual)
  187: #	define FLUSH_ICACHE(addr,size)
  188: #warning no FLUSH_ICACHE, turning off dynamic native code by default
  189: #undef NO_DYNAMIC_DEFAULT
  190: #define NO_DYNAMIC_DEFAULT 1
  191: #endif
  192: 
  193: #ifdef USE_TOS
  194: #define IF_spTOS(x) x
  195: #else
  196: #define IF_spTOS(x)
  197: #define spTOS (sp[0])
  198: #endif
  199: 
  200: #ifdef USE_FTOS
  201: #define IF_fpTOS(x) x
  202: #else
  203: #define IF_fpTOS(x)
  204: #define fpTOS (fp[0])
  205: #endif
  206: 
  207: #define IF_rpTOS(x)
  208: #define rpTOS (rp[0])
  209: 
  210: typedef struct {
  211:   Address base;		/* base address of image (0 if relocatable) */
  212:   UCell checksum;	/* checksum of ca's to protect against some
  213: 			   incompatible	binary/executable combinations
  214: 			   (0 if relocatable) */
  215:   UCell image_size;	/* all sizes in bytes */
  216:   UCell dict_size;
  217:   UCell data_stack_size;
  218:   UCell fp_stack_size;
  219:   UCell return_stack_size;
  220:   UCell locals_stack_size;
  221:   Xt *boot_entry;	/* initial ip for booting (in BOOT) */
  222:   Xt *throw_entry;	/* ip after signal (in THROW) */
  223:   Cell unused1;		/* possibly tib stack size */
  224:   Label *xt_base;         /* base of DOUBLE_INDIRECT xts[], for comp-i.fs */
  225:   Address data_stack_base; /* this and the following fields are initialized by the loader */
  226:   Address fp_stack_base;
  227:   Address return_stack_base;
  228:   Address locals_stack_base;
  229: } ImageHeader;
  230: /* the image-header is created in main.fs */
  231: 
  232: struct Longname {
  233:   struct Longname *next;  /* the link field for old hands */
  234:   Cell		countetc;
  235:   char		name[0];
  236: };
  237: 
  238: #define LONGNAME_COUNT(np)	((np)->countetc & (((~((UCell)0))<<3)>>3))
  239: 
  240: struct Cellpair {
  241:   Cell n1;
  242:   Cell n2;
  243: };
  244: 
  245: struct Cellquad {
  246:   Cell n1;
  247:   Cell n2;
  248:   Cell n3;
  249:   Cell n4;
  250: };
  251: 
  252: #define IOR(flag)	((flag)? -512-errno : 0)
  253: 
  254: Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  255: Label *engine2(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  256: Label *engine3(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
  257: 
  258: /* engine/prim support routines */
  259: Address my_alloc(Cell size);
  260: char *cstr(Char *from, UCell size, int clear);
  261: char *tilde_cstr(Char *from, UCell size, int clear);
  262: DCell timeval2us(struct timeval *tvp);
  263: void cmove(Char *c_from, Char *c_to, UCell u);
  264: void cmove_up(Char *c_from, Char *c_to, UCell u);
  265: Cell compare(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2);
  266: struct Longname *listlfind(Char *c_addr, UCell u, struct Longname *longname1);
  267: struct Longname *hashlfind(Char *c_addr, UCell u, Cell *a_addr);
  268: struct Longname *tablelfind(Char *c_addr, UCell u, Cell *a_addr);
  269: UCell hashkey1(Char *c_addr, UCell u, UCell ubits);
  270: struct Cellpair parse_white(Char *c_addr1, UCell u1);
  271: Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2);
  272: struct Cellquad read_line(Char *c_addr, UCell u1, Cell wfileid);
  273: struct Cellpair file_status(Char *c_addr, UCell u);
  274: Cell to_float(Char *c_addr, UCell u, Float *rp);
  275: Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount);
  276: void faxpy(Float ra, Float *f_x, Cell nstridex, Float *f_y, Cell nstridey, UCell ucount);
  277: 
  278: /* dblsub routines */
  279: DCell dnegate(DCell d1);
  280: UDCell ummul (UCell a, UCell b);
  281: DCell mmul (Cell a, Cell b);
  282: UDCell umdiv (UDCell u, UCell v);
  283: DCell smdiv (DCell num, Cell denom);
  284: DCell fmdiv (DCell num, Cell denom);
  285: 
  286: Cell memcasecmp(const Char *s1, const Char *s2, Cell n);
  287: 
  288: void vm_print_profile(FILE *file);
  289: void vm_count_block(Xt *ip);
  290: 
  291: /* dynamic superinstruction stuff */
  292: Label compile_prim(Label prim);
  293: void compile_prim1(Cell *start);
  294: void finish_code(void);
  295: int forget_dyncode(Address code);
  296: Label decompile_code(Label prim);
  297: 
  298: extern int offset_image;
  299: extern int die_on_signal;
  300: extern UCell pagesize;
  301: extern ImageHeader *gforth_header;
  302: extern Label *vm_prims;
  303: extern Label *xts;
  304: extern Cell npriminfos;
  305: 
  306: #ifdef HAS_DEBUG
  307: extern int debug;
  308: #else
  309: # define debug 0
  310: #endif
  311: 
  312: extern Cell *SP;
  313: extern Float *FP;
  314: extern Address UP;
  315: 
  316: #ifdef GFORTH_DEBUGGING
  317: extern Xt *saved_ip;
  318: extern Cell *rp;
  319: #endif
  320: 
  321: #ifdef NO_IP
  322: extern Label next_code;
  323: #endif
  324: 
  325: #ifdef HAS_FILE
  326: extern char* fileattr[6];
  327: extern char* pfileattr[6];
  328: extern int ufileattr[6];
  329: #endif
  330: 
  331: #ifdef PRINT_SUPER_LENGTHS
  332: Cell prim_length(Cell prim);
  333: void print_super_lengths();
  334: #endif
  335: 
  336: /* declare all the functions that are missing */
  337: #ifndef HAVE_ATANH
  338: extern double atanh(double r1);
  339: extern double asinh(double r1);
  340: extern double acosh(double r1);
  341: #endif
  342: #ifndef HAVE_ECVT
  343: /* extern char* ecvt(double x, int len, int* exp, int* sign);*/
  344: #endif
  345: #ifndef HAVE_MEMMOVE
  346: /* extern char *memmove(char *dest, const char *src, long n); */
  347: #endif
  348: #ifndef HAVE_POW10
  349: extern double pow10(double x);
  350: #endif
  351: #ifndef HAVE_STRERROR
  352: extern char *strerror(int err);
  353: #endif
  354: #ifndef HAVE_STRSIGNAL
  355: extern char *strsignal(int sig);
  356: #endif
  357: #ifndef HAVE_STRTOUL
  358: extern unsigned long int strtoul(const char *nptr, char **endptr, int base);
  359: #endif
  360: 
  361: 
  362: #define GROUP(x, n)

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