Annotation of gforth/engine/forth.h, revision 1.22
1.1 anton 1: /* common header file
2:
1.12 anton 3: Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
1.1 anton 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
1.13 anton 19: Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.1 anton 20: */
21:
1.14 anton 22: #define _GNU_SOURCE
23:
1.1 anton 24: #include "config.h"
1.18 anton 25: #include <stdio.h>
1.1 anton 26:
27: #if defined(DOUBLY_INDIRECT)
28: # undef DIRECT_THREADED
29: # undef INDIRECT_THREADED
30: # define INDIRECT_THREADED
31: #endif
32:
33: #include <limits.h>
34:
35: #if defined(NeXT)
36: # include <libc.h>
37: #endif /* NeXT */
38:
39: /* symbol indexed constants */
40:
41: #define DOCOL 0
42: #define DOCON 1
43: #define DOVAR 2
44: #define DOUSER 3
45: #define DODEFER 4
46: #define DOFIELD 5
47: #define DODOES 6
48: #define DOESJUMP 7
49:
50: /* the size of the DOESJUMP, which resides between DOES> and the does-code */
51: #define DOES_HANDLER_SIZE (2*sizeof(Cell))
52:
1.6 jwilke 53: #include "machine.h"
1.1 anton 54:
55: /* Forth data types */
56: /* Cell and UCell must be the same size as a pointer */
57: #define CELL_BITS (sizeof(Cell) * CHAR_BIT)
58: #define FLAG(b) (-(b))
59: #define FILEIO(error) (FLAG(error) & -37)
60: #define FILEEXIST(error) (FLAG(error) & -38)
61:
62: #define F_TRUE (FLAG(0==0))
63: #define F_FALSE (FLAG(0!=0))
64:
65: #ifdef BUGGY_LONG_LONG
66: typedef struct {
67: Cell hi;
68: UCell lo;
69: } DCell;
70:
71: typedef struct {
72: UCell hi;
73: UCell lo;
74: } UDCell;
75:
76: #define LONG2UD(l) ({UDCell _ud; _ud.hi=0; _ud.lo=(Cell)(l); _ud;})
77: #define UD2LONG(ud) ((long)(ud.lo))
78: #define DZERO ((DCell){0,0})
79:
80: #else /* ! defined(BUGGY_LONG_LONG) */
81:
82: /* DCell and UDCell must be twice as large as Cell */
83: typedef DOUBLE_CELL_TYPE DCell;
84: typedef unsigned DOUBLE_CELL_TYPE UDCell;
85:
1.16 anton 86: #define LONG2UD(l) ((UDCell)(l))
87: #define UD2LONG(ud) ((long)(ud))
88: #define DZERO ((DCell)0)
89:
90: #endif /* ! defined(BUGGY_LONG_LONG) */
91:
1.1 anton 92: typedef union {
93: struct {
1.16 anton 94: #if defined(WORDS_BIGENDIAN)||defined(BUGGY_LONG_LONG)
1.1 anton 95: Cell high;
96: UCell low;
97: #else
98: UCell low;
99: Cell high;
1.20 crook 100: #endif
1.1 anton 101: } cells;
1.16 anton 102: DCell d;
103: UDCell ud;
1.1 anton 104: } Double_Store;
105:
1.16 anton 106: #define FETCH_DCELL_T(d_,lo,hi,t_) ({ \
1.1 anton 107: Double_Store _d; \
108: _d.cells.low = (lo); \
109: _d.cells.high = (hi); \
1.16 anton 110: (d_) = _d.t_; \
1.1 anton 111: })
112:
1.16 anton 113: #define STORE_DCELL_T(d_,lo,hi,t_) ({ \
1.1 anton 114: Double_Store _d; \
1.16 anton 115: _d.t_ = (d_); \
1.1 anton 116: (lo) = _d.cells.low; \
117: (hi) = _d.cells.high; \
118: })
119:
1.16 anton 120: #define vm_twoCell2d(d_,lo,hi) FETCH_DCELL_T(d_,lo,hi,d)
121: #define vm_twoCell2ud(d_,lo,hi) FETCH_DCELL_T(d_,lo,hi,ud)
1.1 anton 122:
1.16 anton 123: #define vm_d2twoCell(d_,lo,hi) STORE_DCELL_T(d_,lo,hi,d)
124: #define vm_ud2twoCell(d_,lo,hi) STORE_DCELL_T(d_,lo,hi,ud)
1.1 anton 125:
126: #ifdef DIRECT_THREADED
127: typedef Label Xt;
128: #else
129: typedef Label *Xt;
130: #endif
131:
132: #if !defined(DIRECT_THREADED)
133: /* i.e. indirect threaded our doubly indirect threaded */
134: /* the direct threaded version is machine dependent and resides in machine.h */
135:
136: /* PFA gives the parameter field address corresponding to a cfa */
137: #define PFA(cfa) (((Cell *)cfa)+2)
138: /* PFA1 is a special version for use just after a NEXT1 */
139: #define PFA1(cfa) PFA(cfa)
140: /* CODE_ADDRESS is the address of the code jumped to through the code field */
141: #define CODE_ADDRESS(cfa) (*(Xt)(cfa))
142:
143: /* DOES_CODE is the Forth code does jumps to */
144: #if !defined(DOUBLY_INDIRECT)
145: # define DOES_CA (symbols[DODOES])
146: #else /* defined(DOUBLY_INDIRECT) */
147: # define DOES_CA ((Label)&symbols[DODOES])
148: #endif /* defined(DOUBLY_INDIRECT) */
149:
150:
151:
152: #define DOES_CODE(cfa) ({Xt _cfa=(Xt)(cfa); \
153: (Xt *)(_cfa[0]==DOES_CA ? _cfa[1] : NULL);})
154: #define DOES_CODE1(cfa) ((Xt *)(cfa[1]))
155: /* MAKE_CF creates an appropriate code field at the cfa;
156: ca is the code address */
157: #define MAKE_CF(cfa,ca) ((*(Label *)(cfa)) = ((Label)ca))
158: /* make a code field for a defining-word-defined word */
159: #define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,DOES_CA); \
160: ((Cell *)cfa)[1] = (Cell)(does_code);})
161: /* the does handler resides between DOES> and the following Forth code */
162: /* not needed in indirect threaded code */
163: #if defined(DOUBLY_INDIRECT)
164: #define MAKE_DOES_HANDLER(addr) MAKE_CF(addr, ((Label)&symbols[DOESJUMP]))
165: #else /* !defined(DOUBLY_INDIRECT) */
166: #define MAKE_DOES_HANDLER(addr) 0
167: #endif /* !defined(DOUBLY_INDIRECT) */
168: #endif /* !defined(DIRECT_THREADED) */
169:
170: #ifdef DEBUG
171: # define NAME(string) fprintf(stderr,"%08lx: "string"\n",(Cell)ip);
172: #else
173: # define NAME(string)
174: #endif
175:
176: #define CF(const) (-const-2)
177:
178: #define CF_NIL -1
179:
180: #ifndef FLUSH_ICACHE
181: #warning flush-icache probably will not work (see manual)
182: # define FLUSH_ICACHE(addr,size)
183: #endif
184:
185: #if defined(DIRECT_THREADED)
186: #define CACHE_FLUSH(addr,size) FLUSH_ICACHE(addr,size)
187: #else
188: #define CACHE_FLUSH(addr,size)
189: #endif
190:
191: #ifdef USE_TOS
1.14 anton 192: #define IF_spTOS(x) x
1.1 anton 193: #else
1.14 anton 194: #define IF_spTOS(x)
195: #define spTOS (sp[0])
1.1 anton 196: #endif
197:
198: #ifdef USE_FTOS
1.14 anton 199: #define IF_fpTOS(x) x
1.1 anton 200: #else
1.14 anton 201: #define IF_fpTOS(x)
202: #define fpTOS (fp[0])
1.1 anton 203: #endif
204:
1.15 anton 205: #define IF_rpTOS(x)
206: #define rpTOS (rp[0])
207:
1.10 anton 208: typedef struct {
209: Address base; /* base address of image (0 if relocatable) */
210: UCell checksum; /* checksum of ca's to protect against some
211: incompatible binary/executable combinations
212: (0 if relocatable) */
213: UCell image_size; /* all sizes in bytes */
214: UCell dict_size;
215: UCell data_stack_size;
216: UCell fp_stack_size;
217: UCell return_stack_size;
218: UCell locals_stack_size;
219: Xt *boot_entry; /* initial ip for booting (in BOOT) */
220: Xt *throw_entry; /* ip after signal (in THROW) */
221: Cell unused1; /* possibly tib stack size */
222: Cell unused2;
223: Address data_stack_base; /* this and the following fields are initialized by the loader */
224: Address fp_stack_base;
225: Address return_stack_base;
226: Address locals_stack_base;
227: } ImageHeader;
228: /* the image-header is created in main.fs */
229:
1.1 anton 230: Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
231: Address my_alloc(Cell size);
1.11 anton 232: char *tilde_cstr(Char *from, UCell size, int clear);
1.1 anton 233:
234: /* dblsub routines */
235: DCell dnegate(DCell d1);
236: UDCell ummul (UCell a, UCell b);
237: DCell mmul (Cell a, Cell b);
238: UDCell umdiv (UDCell u, UCell v);
239: DCell smdiv (DCell num, Cell denom);
240: DCell fmdiv (DCell num, Cell denom);
241:
1.7 pazsan 242: Cell memcasecmp(const Char *s1, const Char *s2, Cell n);
1.1 anton 243:
1.17 anton 244: /* peephole routines */
245:
246: Xt *primtable(Label symbols[], Cell size);
247: Cell prepare_peephole_table(Xt xts[]);
248: Xt peephole_opt(Xt xt1, Xt xt2, Cell peeptable);
1.18 anton 249: void vm_print_profile(FILE *file);
250: void vm_count_block(Xt *ip);
1.17 anton 251:
1.22 ! anton 252: /* dynamic superinstruction stuff */
! 253: Label compile_prim(Label prim);
1.17 anton 254:
1.1 anton 255: extern int offset_image;
1.5 anton 256: extern int die_on_signal;
1.10 anton 257: extern UCell pagesize;
258: extern ImageHeader *gforth_header;
1.19 anton 259: extern Label *vm_prims;
1.2 pazsan 260:
1.9 anton 261: #ifdef GFORTH_DEBUGGING
262: extern Xt *ip;
263: extern Cell *rp;
264: #endif
265:
266:
1.2 pazsan 267: /* declare all the functions that are missing */
268: #ifndef HAVE_ATANH
269: extern double atanh(double r1);
270: extern double asinh(double r1);
271: extern double acosh(double r1);
272: #endif
273: #ifndef HAVE_ECVT
1.4 anton 274: /* extern char* ecvt(double x, int len, int* exp, int* sign);*/
1.2 pazsan 275: #endif
276: #ifndef HAVE_MEMMOVE
1.3 anton 277: /* extern char *memmove(char *dest, const char *src, long n); */
1.2 pazsan 278: #endif
279: #ifndef HAVE_POW10
280: extern double pow10(double x);
281: #endif
282: #ifndef HAVE_STRERROR
283: extern char *strerror(int err);
284: #endif
285: #ifndef HAVE_STRSIGNAL
286: extern char *strsignal(int sig);
287: #endif
288: #ifndef HAVE_STRTOUL
1.3 anton 289: extern unsigned long int strtoul(const char *nptr, char **endptr, int base);
1.2 pazsan 290: #endif
291:
292:
1.21 pazsan 293: #define GROUP(x)
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>