comparison keiko/support.c @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 /*
2 * support.c
3 *
4 * This file is part of the Oxford Oberon-2 compiler
5 * Copyright (c) 2006--2016 J. M. Spivey
6 * All rights reserved
7 *
8 * Redistribution and use in source and binary forms, with or without
9 * modification, are permitted provided that the following conditions are met:
10 *
11 * 1. Redistributions of source code must retain the above copyright notice,
12 * this list of conditions and the following disclaimer.
13 * 2. Redistributions in binary form must reproduce the above copyright notice,
14 * this list of conditions and the following disclaimer in the documentation
15 * and/or other materials provided with the distribution.
16 * 3. The name of the author may not be used to endorse or promote products
17 * derived from this software without specific prior written permission.
18 *
19 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
20 * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
21 * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
22 * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
24 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
25 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
27 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
28 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 */
30
31 #include "obx.h"
32
33 /* Assorted runtime support routines */
34
35 void panic(const char *msg, ...) {
36 va_list va;
37
38 mybool bug = FALSE;
39
40 if (*msg == '*') {
41 bug = TRUE; msg++;
42 }
43
44 fflush(stdout);
45 fprintf(stderr, "Fatal error: ");
46 va_start(va, msg);
47 vfprintf(stderr, msg, va);
48 va_end(va);
49 fprintf(stderr, "\n");
50 if (bug)
51 fprintf(stderr, "Please report bugs to %s or %s\n",
52 PACKAGE_TRACKER, PACKAGE_BUGREPORT);
53 fflush(stderr);
54 error_exit(3);
55 }
56
57
58 /* Division operators for jit code */
59
60 static inline divop_decl(int)
61 static inline divop_decl(longint)
62
63 void int_div(value *sp) {
64 sp[1].i = int_divop(sp[1].i, sp[0].i, 1);
65 }
66
67 void int_mod(value *sp) {
68 sp[1].i = int_divop(sp[1].i, sp[0].i, 0);
69 }
70
71 void long_div(value *sp) {
72 put_long(sp+2, longint_divop(get_long(sp+2), get_long(sp), 1));
73 }
74
75 void long_mod(value *sp) {
76 put_long(sp+2, longint_divop(get_long(sp+2), get_long(sp), 0));
77 }
78
79 void long_flo(value *sp) {
80 put_double(sp, get_long(sp));
81 }
82
83 void long_zcheck(value *sp) {
84 if (get_long(sp+2) == 0)
85 rterror(E_DIV, sp[0].i, ptrcast(value, sp[1].a));
86 }
87
88 #ifndef M64X32
89 void long_add(value *sp) {
90 put_long(sp+2, get_long(sp+2) + get_long(sp));
91 }
92
93 void long_sub(value *sp) {
94 put_long(sp+2, get_long(sp+2) - get_long(sp));
95 }
96
97 void long_mul(value *sp) {
98 put_long(sp+2, get_long(sp+2) * get_long(sp));
99 }
100
101 void long_neg(value *sp) {
102 put_long(sp, -get_long(sp));
103 }
104
105 void long_cmp(value *sp) {
106 longint a = get_long(sp+2), b = get_long(sp);
107 sp[3].i = (a < b ? -1 : a > b ? 1 : 0);
108 }
109
110 void long_ext(value *sp) {
111 put_long(sp-1, (longint) sp[0].i);
112 }
113 #endif
114
115
116 /* Conversions between int and floating point */
117
118 #ifndef GCOV
119 /* These are not done inline in interp() because that upsets the
120 gcc optimiser on i386, adding overhead to every instruction. */
121 double flo_conv(int x) {
122 return (double) x;
123 }
124
125 double flo_convq(longint x) {
126 return (double) x;
127 }
128 #endif
129
130 /* obcopy -- like strncpy, but guarantees termination with zero */
131 void obcopy(char *dst, int dlen, const char *src, int slen, value *bp) {
132 if (slen == 0 || dlen < slen) {
133 strncpy(dst, src, dlen);
134 if (dst[dlen-1] != '\0')
135 liberror("string copy overflows destination");
136 } else {
137 strncpy(dst, src, slen);
138 if (dst[slen-1] != '\0')
139 liberror("source was not null-terminated");
140 memset(&dst[slen], '\0', dlen-slen);
141 }
142 }
143
144 #ifndef UNALIGNED_MEM
145 double get_double(value *v) {
146 dblbuf dd;
147 dd.n.lo = v[0].i;
148 dd.n.hi = v[1].i;
149 return dd.d;
150 }
151
152 void put_double(value *v, double x) {
153 dblbuf dd;
154 dd.d = x;
155 v[0].i = dd.n.lo;
156 v[1].i = dd.n.hi;
157 }
158
159 longint get_long(value *v) {
160 dblbuf dd;
161 dd.n.lo = v[0].i;
162 dd.n.hi = v[1].i;
163 return dd.q;
164 }
165
166 void put_long(value *v, longint x) {
167 dblbuf dd;
168 dd.q = x;
169 v[0].i = dd.n.lo;
170 v[1].i = dd.n.hi;
171 }
172 #endif
173
174 /* find_symbol -- find a procedure from its CP. Works for modules too. */
175 proc find_symbol(value *p, proc *table, int nelem) {
176 int a = 0, b = nelem;
177
178 if (p == NULL) return NULL;
179 if (nelem == 0 || p < table[0]->p_addr) return NULL;
180
181 /* Binary search */
182 /* Inv: 0 <= a < b <= nelem, table[a] <= x < table[b],
183 where table[nelem] = infinity */
184 while (a+1 != b) {
185 int m = (a+b)/2;
186 if (table[m]->p_addr <= p)
187 a = m;
188 else
189 b = m;
190 }
191
192 return table[a];
193 }
194
195 #ifdef WINDOWS
196 #ifdef OBXDEB
197 #define OBGETC 1
198 #endif
199 #endif
200
201 /* obgetc -- version of getc that compensates for Windows quirks */
202 int obgetc(FILE *fp) {
203 #ifdef OBGETC
204 /* Even if Ctrl-C is trapped, it causes a getc() call on the console
205 to return EOF. */
206 for (;;) {
207 int c = getc(fp);
208 if (c == EOF && intflag && prim_bp != NULL) {
209 value *cp = valptr(prim_bp[CP]);
210 debug_break(cp , prim_bp, NULL, "interrupt");
211 continue;
212 }
213 return c;
214 }
215 #else
216 return getc(fp);
217 #endif
218 }
219
220 #ifdef SPECIALS
221 /* Specials for the compiler course */
222
223 value *clotab[256];
224 int nclo = 0;
225
226 int pack(value *code, uchar *env) {
227 unsigned tag, val;
228
229 for (tag = 0; tag < nclo; tag++)
230 if (clotab[tag] == code) break;
231
232 if (tag == nclo) {
233 if (nclo == 256) panic("Out of closure tags");
234 clotab[nclo++] = code;
235 }
236
237 if (env != NULL && (env <= stack || env > stack + stack_size))
238 panic("Bad luck in pack");
239
240 val = (env == NULL ? 0 : env - stack);
241
242 return (tag << 24) | val;
243 }
244
245 value *getcode(int word) {
246 unsigned tag = ((unsigned) word) >> 24;
247 return clotab[tag];
248 }
249
250 uchar *getenvt(int word) {
251 unsigned val = ((unsigned) word) & 0xffffff;
252 return (val == 0 ? NULL : stack + val);
253 }
254 #endif