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: #define _GNU_SOURCE
23:
24: #include "config.h"
25: #include <stdio.h>
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:
53: #include "machine.h"
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:
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:
92: typedef union {
93: struct {
94: #if defined(WORDS_BIGENDIAN)||defined(BUGGY_LONG_LONG)
95: Cell high;
96: UCell low;
97: #else
98: UCell low;
99: Cell high;
100: #endif
101: } cells;
102: DCell d;
103: UDCell ud;
104: } Double_Store;
105:
106: #define FETCH_DCELL_T(d_,lo,hi,t_) ({ \
107: Double_Store _d; \
108: _d.cells.low = (lo); \
109: _d.cells.high = (hi); \
110: (d_) = _d.t_; \
111: })
112:
113: #define STORE_DCELL_T(d_,lo,hi,t_) ({ \
114: Double_Store _d; \
115: _d.t_ = (d_); \
116: (lo) = _d.cells.low; \
117: (hi) = _d.cells.high; \
118: })
119:
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)
122:
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)
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
192: #define IF_spTOS(x) x
193: #else
194: #define IF_spTOS(x)
195: #define spTOS (sp[0])
196: #endif
197:
198: #ifdef USE_FTOS
199: #define IF_fpTOS(x) x
200: #else
201: #define IF_fpTOS(x)
202: #define fpTOS (fp[0])
203: #endif
204:
205: #define IF_rpTOS(x)
206: #define rpTOS (rp[0])
207:
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:
230: Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
231: Address my_alloc(Cell size);
232: char *tilde_cstr(Char *from, UCell size, int clear);
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:
242: Cell memcasecmp(const Char *s1, const Char *s2, Cell n);
243:
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);
249: void vm_print_profile(FILE *file);
250: void vm_count_block(Xt *ip);
251:
252: /* dynamic superinstruction stuff */
253: Label compile_prim(Label prim);
254:
255: extern int offset_image;
256: extern int die_on_signal;
257: extern UCell pagesize;
258: extern ImageHeader *gforth_header;
259: extern Label *vm_prims;
260:
261: #ifdef GFORTH_DEBUGGING
262: extern Xt *ip;
263: extern Cell *rp;
264: #endif
265:
266:
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
274: /* extern char* ecvt(double x, int len, int* exp, int* sign);*/
275: #endif
276: #ifndef HAVE_MEMMOVE
277: /* extern char *memmove(char *dest, const char *src, long n); */
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
289: extern unsigned long int strtoul(const char *nptr, char **endptr, int base);
290: #endif
291:
292:
293: #define GROUP(x)
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to forth.h CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / engine