summaryrefslogtreecommitdiff
path: root/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c')
-rw-r--r--Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c275
1 files changed, 0 insertions, 275 deletions
diff --git a/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c b/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c
deleted file mode 100644
index 064a9b76db0..00000000000
--- a/Build/source/utils/xml2pmx/xml2pmx-src/dynlink.c
+++ /dev/null
@@ -1,275 +0,0 @@
-/*
- * dynlink.c
- *
- * This file is part of the Oxford Oberon-2 compiler
- * Copyright (c) 2006--2016 J. M. Spivey
- * All rights reserved
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- * 3. The name of the author may not be used to endorse or promote products
- * derived from this software without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
- * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
- * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
- * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
- * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
- * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
- * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
-
-/*
-Initially, the procedure descriptor for each such primitive has the
-trap handler |dltrap| as its interpreter, and the CP_CODE field of
-the descriptor points to the name of the primitive as a string.
-When the primitive is first called, the |dltrap| primitive looks up
-the symbol and binds the primitive to its value for future use.
-Finally, it calls the newly-loaded primitive to complete the first
-call.
-
-Function |load_lib| loads a dynamic library. Each Oberon module that
-links to a dynamic library should call |DynLink.Load("path")|
-in its initialization part.
-*/
-
-#include "obx.h"
-#include <string.h>
-#include <stdlib.h>
-
-#ifdef DYNLINK
-
-#ifndef __USE_GNU
-#define __USE_GNU
-#endif
-#include <dlfcn.h>
-
-#ifdef USE_FFI
-#include <ffi.h>
-#endif
-
-void load_lib(char *fname) {
- char buf[128];
-
- /* If the library name starts with '@', look in the OBC lib directory
- and append the extension ".so" or ".dylib" au chois */
- if (fname[0] == '@') {
- char *dir = getenv("OBC_LIB");
- if (dir == NULL) dir = libpath;
- if (dir == NULL) panic("no runtime library");
- strcpy(buf, dir);
- strcat(buf, "/");
- strcat(buf, fname+1);
- strcat(buf, DLEXT);
- fname = buf;
- }
-
- /* Load the library */
- if (dlopen(fname, RTLD_LAZY|RTLD_GLOBAL) == NULL)
- panic(dlerror());
-}
-
-#ifdef USE_FFI
-#define MAXP 16
-
-typedef struct {
- void (*fun)(void);
- ffi_cif cif;
-} wrapper;
-
-static ffi_type *ffi_decode(char c) {
- switch (c) {
- case 'C':
- case 'S':
- case 'I':
- return &ffi_type_sint32;
- case 'L':
- return &ffi_type_sint64;
- case 'F':
- return &ffi_type_float;
- case 'D':
- return &ffi_type_double;
- case 'P':
- case 'Q':
- case 'X':
- return &ffi_type_pointer;
- case 'V':
- return &ffi_type_void;
- default:
- panic("Bad type %c", c);
- return NULL;
- }
-}
-
-value *dlstub(value *bp) {
- value *cp = valptr(bp[CP]);
- char *tstring = pointer(cp[CP_CODE]);
- value *sp = bp;
-
- ffi_raw avals[MAXP], rval[2];
- int i, p = 0, q = 0;
- double d; longint z;
-
- FPINIT;
-
- for (i = 0; tstring[i+1] != '\0'; i++) {
- switch (tstring[i+1]) {
- case 'C':
- avals[q].sint = align_byte(bp[HEAD+p].i);
- p += 1; q += 1; break;
- case 'S':
- avals[q].sint = align_short(bp[HEAD+p].i);
- p += 1; q += 1; break;
- case 'I':
- avals[q].sint = bp[HEAD+p].i;
- p += 1; q += 1; break;
- case 'L':
- z = get_long(&bp[HEAD+p]);
- memcpy(avals[q].data, &z, sizeof(longint));
- p += 2; q += sizeof(longint)/sizeof(ffi_raw); break;
- case 'F':
- avals[q].flt = bp[HEAD+p].f;
- p += 1; q += 1; break;
- case 'D':
- d = get_double(&bp[HEAD+p]);
- memcpy(avals[q].data, &d, sizeof(double));
- p += 2; q += sizeof(double)/sizeof(ffi_raw); break;
- case 'P':
- avals[q].ptr = pointer(bp[HEAD+p]);
- p += 1; q += 1; break;
- case 'X':
- avals[q].ptr = pointer(bp[HEAD+p]);
- p += 2; q += 1; break;
- case 'Q':
- avals[q].ptr = ptrcast(uchar, get_long(&bp[HEAD+p]));
- p += 2; q += 1; break;
-#ifdef SPECIALS
- case 'S':
- /* Static link for compilers course -- ignored */
- p += 1; break;
-#endif
- default:
- panic("Bad type 2 %c", tstring[i+1]);
- }
- }
-
- wrapper *w = pointer(cp[CP_CONST]);
- ffi_raw_call(&w->cif, w->fun, rval, avals);
-
- switch (tstring[0]) {
- case 'C':
- case 'S':
- case 'I':
- (*--sp).i = rval->sint;
- break;
- case 'L':
- memcpy(&z, rval, sizeof(longint));
- sp -= 2;
- put_long(sp, z);
- break;
- case 'F':
- (*--sp).f = rval->flt;
- break;
- case 'D':
- memcpy(&d, rval, sizeof(double));
- sp -= 2;
- put_double(sp, d);
- break;
- case 'P':
- (*--sp).a = rval->uint;
- break;
- case 'Q':
- sp -= 2;
- put_long(sp, (ptrtype) rval->ptr);
- break;
- case 'V':
- break;
- default:
- panic("Bad type 3");
- }
-
- return sp;
-}
-#endif
-
-primitive *find_prim(char *name) {
- return (primitive *) dlsym(RTLD_DEFAULT, name);
-}
-
-#else
-
-void load_lib(char *fname) {
-}
-
-primitive *find_prim(char *name) {
- int i;
-
- for (i = 0; primtab[i].p_name != NULL; i++) {
- if (strcmp(name, primtab[i].p_name) == 0)
- return primtab[i].p_prim;
- }
-
- return NULL;
-}
-
-#endif
-
-value *dltrap(value *bp) {
- value *cp = valptr(bp[CP]);
- char *tstring = pointer(cp[CP_CODE]);
- char *name = tstring + strlen(tstring) + 1;
- primitive *prim = NULL;
-
- if (*name == '=') name++;
-
- if (tstring[0] == '*')
- prim = find_prim(name);
- else {
- /* Look for a static wrapper */
- char primname[32];
- sprintf(primname, "P_%s", name);
- prim = find_prim(primname);
- }
-
- if (prim != NULL) {
- cp[CP_PRIM].a = wrap_prim(prim);
- return (*prim)(bp);
- }
-
-#ifdef DYNLINK
-#ifdef USE_FFI
- /* Build a wrapper with FFI */
- void (*fun)(void) = (void(*)(void)) dlsym(RTLD_DEFAULT, name);
-
- if (fun != NULL && tstring[0] != '*') {
- int np = strlen(tstring)-1;
- ffi_type *rtype = ffi_decode(tstring[0]);
- ffi_type **atypes = scratch_alloc_atomic(np * sizeof(ffi_type *));
- for (int i = 0; tstring[i+1] != '\0'; i++)
- atypes[i] = ffi_decode(tstring[i+1]);
-
- word a = virtual_alloc_atomic(sizeof(wrapper));
- wrapper *w = ptrcast(wrapper, a);
- w->fun = fun;
- ffi_prep_cif(&w->cif, FFI_DEFAULT_ABI, np, rtype, atypes);
-
- cp[CP_PRIM].a = dynstub;
- cp[CP_CONST].a = a;
-
- return dlstub(bp);
- }
-#endif
-#endif
-
- panic("Couldn't find primitive %s", name);
- return NULL;
-}