annotate keiko/support.c @ 1:b5139af1a420 tip basis

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