/* BEGIN LICENSE BLOCK * Version: CMPL 1.1 * * The contents of this file are subject to the Cisco-style Mozilla Public * License Version 1.1 (the "License"); you may not use this file except * in compliance with the License. You may obtain a copy of the License * at www.eclipse-clp.org/license. * * Software distributed under the License is distributed on an "AS IS" * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See * the License for the specific language governing rights and limitations * under the License. * * The Original Code is The ECLiPSe Constraint Logic Programming System. * The Initial Developer of the Original Code is Cisco Systems, Inc. * Portions created by the Initial Developer are * Copyright (C) 1997-2006 Cisco Systems, Inc. All Rights Reserved. * * Contributor(s): * * END LICENSE BLOCK */ /* * ECLiPSe LIBRARY MODULE * * $Id: embed.c,v 1.7 2013/04/17 01:34:21 jschimpf Exp $ * * * IDENTIFICATION: embed.c * * AUTHOR: Joachim Schimpf * AUTHOR: Stefano Novello * * CONTENTS: name/arity * * DESCRIPTION: * Call interface to embedded eclipse */ #include "config.h" #include "sepia.h" #include "types.h" #include "error.h" #include "mem.h" #include "dict.h" #include "module.h" #include "emu_export.h" #include "embed.h" #include "os_support.h" #include #ifdef STDC_HEADERS #include #include #include #else #include extern char * strcat(); extern char * strcpy(); #endif /* * EXTERN declarations */ extern int eclipse_global_init(int init_flags); extern int eclipse_boot(char *initfile); extern int mem_init(int flags); /* * Global state */ #ifdef _WIN32 static void *resume_thread = NULL; #endif /*---------------------------------------------------------------------- * Setting the initialisation options *----------------------------------------------------------------------*/ /* backwards compatibility */ int Winapi ec_set_option_int(int opt, int val) { return ec_set_option_long(opt, (word) val); } int Winapi ec_set_option_long(int opt, word val) { switch (opt) { case EC_OPTION_PARALLEL_WORKER: ec_options.parallel_worker = (int) val; break; case EC_OPTION_ARGC: ec_options.Argc = (int) val; break; case EC_OPTION_LOCALSIZE: ec_options.localsize = val; break; case EC_OPTION_GLOBALSIZE: ec_options.globalsize = val; break; case EC_OPTION_PRIVATESIZE: ec_options.privatesize = val; break; case EC_OPTION_SHAREDSIZE: ec_options.sharedsize = val; break; case EC_OPTION_ALLOCATION: ec_options.allocation = (int) val; break; case EC_OPTION_IO: ec_options.io_option = (int) val; break; case EC_OPTION_INIT: ec_options.init_flags = val; break; case EC_OPTION_DEBUG_LEVEL: ec_options.debug_level = val; break; case EC_OPTION_CWD_SEPARATE:ec_use_own_cwd = (int) val; break; default: return RANGE_ERROR; } return PSUCCEED; } int Winapi ec_set_option_ptr(int opt, void *val) { switch (opt) { case EC_OPTION_MAPFILE: ec_options.mapfile = (char *) val; break; case EC_OPTION_ARGV: ec_options.Argv = (char **) val; break; case EC_OPTION_PANIC: ec_options.user_panic = (void(*)(const char*,const char *)) val; break; case EC_OPTION_DEFAULT_MODULE: ec_options.default_module = (char *) val; break; case EC_OPTION_DEFAULT_LANGUAGE: ec_options.default_language = (char *) val; break; case EC_OPTION_ECLIPSEDIR: ec_options.eclipse_home = (char *) val; break; default: return RANGE_ERROR; } return PSUCCEED; } /*---------------------------------------------------------------------- * Initialising an embedded Eclipse *----------------------------------------------------------------------*/ int Winapi ec_init(void) { char * initfile = (char *) 0; char filename_buf[MAX_PATH_LEN]; pword goal,module; int res; /*---------------------------------------------------------------- * Make the connection to the shared heap, if any. * Because of mmap problems on some machines this should * happen AFTER initializing the message passing system. *----------------------------------------------------------------*/ mem_init(ec_options.init_flags); /* depends on -c and -m options */ /* * Init the global (shared) eclipse structures, dictionary, code... * Maybe load a saved state. * Note that we don't have an engine yet! */ eclipse_global_init(ec_options.init_flags); /*---------------------------------------------------------------- * Setup the Prolog engine *----------------------------------------------------------------*/ /* * Initialize the Prolog engine */ emu_init(ec_options.init_flags, 0); initfile = strcat(strcpy(filename_buf, ec_eclipse_home), "/lib/kernel.eco"); if (ec_access(initfile, R_OK) < 0) { initfile = strcat(strcpy(filename_buf, ec_eclipse_home), "/lib/kernel.pl"); if (ec_access(initfile, R_OK) < 0) { ec_panic("Aborting: Can't find boot file! Please check either\na) your program's setting for eclipsedir in ec_set_option(), or\nb) your setting for ECLIPSEDIR environment variable.\n","ec_init()"); } } res = eclipse_boot(initfile); if (res != PSUCCEED) return res; goal = ec_term(ec_did("main",1), ec_long(ec_options.init_flags & INIT_SHARED ? 0 : 1)); module.val.did = ec_.d.kernel_sepia; module.tag.kernel = ModuleTag(ec_.d.kernel_sepia); if (main_emulc_noexit(goal.val, goal.tag, module.val, module.tag) != PYIELD) return PFAIL; return PSUCCEED; } void ec_embed_fini(void) { #ifdef _WIN32 if (resume_thread) { (void) ec_thread_terminate(resume_thread, 3000/*ms timeout*/); resume_thread = NULL; } #endif hp_free(ec_eclipse_home); ec_eclipse_home = 0; } /*---------------------------------------------------------------------- * Posting goals *----------------------------------------------------------------------*/ void Winapi ec_post_goal(const pword goal) { pword *pw; if (g_emu_.nesting_level > 1) ec_panic("can't post goal to nested engine","ec_post_goal()"); pw = TG; /* new list element */ Push_List_Frame(); pw[0] = goal; Make_Var(&pw[1]); Bind_(POSTED_LAST.val.ptr, pw, TLIST); /* append */ ec_assign(&POSTED_LAST, pw[1].val, pw[1].tag); } static pword _get_posted_goals(void) { pword posted, empty; /* terminate the posted-goals-list and copy its beginning */ Bind_(POSTED_LAST.val.ptr, 0, TNIL); posted = POSTED; /* reinitialise the list to an empty difference list */ Make_Ref(&empty, TG); Push_Var(); ec_assign(&POSTED, empty.val, empty.tag); ec_assign(&POSTED_LAST, empty.val, empty.tag); return posted; } void Winapi ec_post_string(const char *callstring) { ec_post_goal(ec_term(ec_.d.colon, ec_atom(ec_.d.kernel_sepia), ec_term(ec_did("exec_string",2), ec_string(callstring), ec_newvar()))); } void Winapi ec_post_exdr(int length, const char *exdr_string) { ec_post_goal(ec_term(ec_.d.colon, ec_atom(ec_.d.kernel_sepia), ec_term(ec_did("exec_exdr",1), ec_length_string(length, exdr_string)))); } int Winapi ec_exec_string( char *callstring, ec_ref varsref) /* NULL is allowed */ { pword vars; dident exec_string_2 = enter_dict("exec_string",2); vars = ec_newvar(); if (varsref) ec_ref_set(varsref, vars); ec_post_goal(ec_term(ec_.d.colon, ec_atom(ec_.d.kernel_sepia), ec_term(exec_string_2, ec_string(callstring), vars))); return ec_resume1(0); } /*---------------------------------------------------------------------- * Resuming Eclipse execution *----------------------------------------------------------------------*/ int Winapi ec_resume(void) { return ec_resume1(0); } int Winapi ec_resume1(ec_ref chp) { return ec_resume2(_get_posted_goals(), chp); } int Winapi ec_resume2(const pword term, ec_ref chp) { int res; pword * pw; pword tterm; /* this assignment is needed to get around a compiler bug on Alpha Linux that otherwise corrupts chp */ tterm = term; if (g_emu_.nesting_level > 1) ec_panic("can't resume nested engine","ec_resume2()"); if (ec_running()) return PRUNNING; A[1] = tterm; Make_Integer(&A[2], RESUME_CONT); res = restart_emulc(); if (res != PYIELD) ec_panic("eclipse emulator did not yield properly","ec_resume()"); if (chp) ec_ref_set(chp,A[2]); pw = &A[1]; Dereference_(pw) if (IsInteger(pw->tag)) return pw->val.nint; else return TYPE_ERROR; } int Winapi ec_resume_long(long int *to_c) { int res; pword * pw; if (g_emu_.nesting_level > 1) ec_panic("can't resume nested engine","ec_resume_long()"); if (ec_running()) return PRUNNING; A[1] = _get_posted_goals(); Make_Integer(&A[2], RESUME_CONT); res = restart_emulc(); if (res != PYIELD) ec_panic("eclipse emulator did not yield properly","ec_resume_long()"); pw = &A[2]; Dereference_(pw) if (IsInteger(pw->tag)) *to_c = pw->val.nint; else *to_c = 0; pw = &A[1]; Dereference_(pw) if (IsInteger(pw->tag)) return pw->val.nint; else return TYPE_ERROR; } int Winapi ec_running(void) { #ifdef _WIN32 int res; if (resume_thread && !ec_thread_stopped(resume_thread, &res)) return 1; #endif return 0; } #ifdef _WIN32 /* this will be called in a thread */ static int restart_emulc_thread(void *dummy_arg_for_thread) { return restart_emulc(); } #endif int Winapi ec_resume_async(void) { if (g_emu_.nesting_level > 1) ec_panic("can't resume nested engine","ec_resume2()"); #ifdef _WIN32 if (!resume_thread) /* if we don't have a thread yet, make one */ { resume_thread = ec_make_thread(); if (!resume_thread) return SYS_ERROR; } else /* make sure the thread is not running */ { if (ec_running()) return PRUNNING; } #endif A[1] = _get_posted_goals(); Make_Integer(&A[2], RESUME_CONT); #ifdef _WIN32 if (!ec_start_thread(resume_thread, restart_emulc_thread, NULL)) return SYS_ERROR; #endif return PSUCCEED; } int Winapi ec_resume_status(void) { long dummy; return ec_resume_status_long(&dummy); } int Winapi ec_resume_status_long(long int *to_c) { return ec_wait_resume_status_long(to_c, 0); } int Winapi ec_wait_resume_status_long(long int *to_c, int timeout) { pword *pw; int res; #ifdef _WIN32 /* This is supposed to be called only after a resume_async! */ if (!resume_thread) return PERROR; if (!ec_thread_wait(resume_thread, &res, timeout)) return PRUNNING; #else /* We don't have threads: resume here in order to make resume_async- * resume_status sequences work anyway, so we can write portable code. */ res = restart_emulc(); #endif if (res != PYIELD) ec_panic("eclipse emulator did not yield properly","ec_resume_long()"); pw = &A[2]; Dereference_(pw) if (IsInteger(pw->tag)) *to_c = pw->val.nint; else *to_c = 0; pw = &A[1]; Dereference_(pw) if (IsInteger(pw->tag)) return pw->val.nint; else return TYPE_ERROR; } /*---------------------------------------------------------------------- * Resuming Eclipse without continuing * just create an opportunity for event handling * Return values: * PRUNNING * engine not yet ready (previous resume_async) * PFLUSHIO,PWAITIO * nested request from within handler * PSUCCEED * handler finished * PFAIL,PTHROW * should never occur (prevented by yield/3) * PYIELD * programmer error (yield/2 in handler) *----------------------------------------------------------------------*/ int Winapi ec_handle_events(long int *to_c) { int res; pword * pw; if (g_emu_.nesting_level > 1) ec_panic("can't resume nested engine","ec_handle_events()"); if (ec_running()) return PRUNNING; Make_Nil(&A[1]) /* don't care */ Make_Integer(&A[2], RESUME_SIMPLE); res = restart_emulc(); if (res != PYIELD) ec_panic("eclipse emulator did not yield properly","ec_handle_events()"); pw = &A[2]; Dereference_(pw) if (IsInteger(pw->tag)) *to_c = pw->val.nint; else *to_c = 0; pw = &A[1]; Dereference_(pw) if (IsInteger(pw->tag)) return pw->val.nint; else return TYPE_ERROR; } /*---------------------------------------------------------------------- * External references: * * States of external references: * * EC_REF_C: hp_allocated, simple value, not in global list * * This is the state just after an ec_refs has been created by a * call to ec_refs_create(), or after backtracking to such a point. * It is not "initialised" yet, i.e. no array (structure) for the * n slots has been allocated on the global stack, and it is not * yet known to the garbage collector. The var-field preliminarily * holds the init-value instead of a pointer to a global stack array. * * EC_REF_C_P: hp_allocated, prolog value, in global list * * This is the normal working state: the ec_refs is used from the * C program, its var-field points to a global stack array of arity * n, and it is known to the garbage collector via the global list. * The transition from EC_REF_C to EC_REF_C_P happens on the first * access to the ec_refs: a global stack arary is allocated and its * slots initialised with the requested init value. * * EC_REF_FREE: deallocated, no value, not in global list * * This state only exists temporarily just before deallocation. * * Allowed transitions: * (none) --create--> EC_REF_C * EC_REF_C --init--> EC_REF_C_P * EC_REF_C --destroy--> EC_REF_FREE * EC_REF_C --untrail--> EC_REF_C * EC_REF_C_P --destroy--> EC_REF_FREE * EC_REF_C_P --untrail--> EC_REF_C *----------------------------------------------------------------------*/ void Winapi ec_refs_destroy(ec_refs variable) { if (!(variable->refstate & EC_REF_C)) ec_panic("ec_ref already freed from C","ec_refs_destroy()"); if (variable->refstate & EC_REF_P) { /* Unlink the ec_ref to make the global stack array become garbage */ variable->next->prev = variable->prev; variable->prev->next = variable->next; } variable->refstate = EC_REF_FREE; hp_free_size((generic_ptr)variable, sizeof(struct eclipse_ref_)); } /*ARGSUSED*/ static void _ec_refs_untrail(pword *parray, word *pdata, int size, int flags) { ec_refs variable = g_emu_.allrefs.next; /* Find the ec_ref corresponding to parray in the global list. */ /* If it's not in there, then it has already been destroyed! */ while (variable != &g_emu_.allrefs) { if (variable->var.val.ptr == parray) { if (!(variable->refstate == EC_REF_C_P)) ec_panic("ec_ref already untrailed","_ec_refs_untrail()"); variable->refstate &= ~EC_REF_P; variable->next->prev = variable->prev; /* unlink */ variable->prev->next = variable->next; variable->var = *((pword*) pdata); /* reset value */ return; } variable = variable->next; } } int Winapi ec_refs_size(const ec_refs variable) { return variable->size; } ec_refs Winapi ec_refs_create_newvars(int n) { ec_ref new; new = hp_alloc_size(sizeof(struct eclipse_ref_)); new->var = g_emu_.allrefs.var; new->refstate = EC_REF_C; new->size = n; new->next = new->prev = 0; return new; } ec_refs Winapi ec_refs_create(int n, const pword initpw) { ec_ref new; if (!(IsSimple(initpw.tag) || IsPersistent(initpw.tag))) ec_panic("non-atomic initializer","ec_refs_create()"); new = hp_alloc_size(sizeof(struct eclipse_ref_)); new->var = initpw; new->refstate = EC_REF_C; new->size = n; new->next = new->prev = 0; return new; } static void _ec_ref_init(ec_refs variable) { pword * pw, initpw; int i; int n = variable->size; if (variable->refstate != EC_REF_C) ec_panic("ec_refs already freed from C","_ec_ref_init()"); initpw = variable->var; variable->refstate = EC_REF_C_P; /* Use the global stack array as trail item, so the trail entry */ /* gets garbage collected together with it. */ pw = TG; ec_trail_undo(_ec_refs_untrail, pw, NULL, (word *) &initpw, sizeof(pword)/sizeof(word), TRAILED_PWORD); Make_Struct(&(variable->var), pw); Push_Struct_Frame(ec_did("",n)); if (IsRef(initpw.tag)) { for (i=1; i<=n; i++) { /* brackets important */ Make_Var(pw+i); } } else { for (i=1; i<=n; i++) pw[i] = initpw; } variable->next = g_emu_.allrefs.next; variable->prev = &g_emu_.allrefs; g_emu_.allrefs.next->prev = variable; g_emu_.allrefs.next = variable; } void Winapi ec_refs_set(ec_refs variable, int i, const pword w) { if (variable->refstate != EC_REF_C_P) _ec_ref_init(variable); if (i >= variable->size) ec_panic("out of bounds","ec_refs_set()"); (void) ec_assign(variable->var.val.ptr+i+1, w.val,w.tag); } pword Winapi ec_refs_get(const ec_refs variable, int i) { if (variable->refstate != EC_REF_C_P) _ec_ref_init(variable); if (i >= variable->size) ec_panic("out of bounds","ec_refs_get()"); return variable->var.val.ptr[i+1]; } ec_ref Winapi ec_ref_create(pword initpw) { return (ec_ref) ec_refs_create(1, initpw); } ec_ref Winapi ec_ref_create_newvar(void) { return (ec_ref) ec_refs_create_newvars(1); } void Winapi ec_ref_set(ec_ref variable, const pword w) { ec_refs_set((ec_refs) variable, 0, w); } pword Winapi ec_ref_get(const ec_ref variable) { return ec_refs_get((ec_refs) variable, 0); } void Winapi ec_ref_destroy(ec_ref variable) { ec_refs_destroy((ec_refs) variable); } /*---------------------------------------------------------------------- * Choicepoints and cuts *----------------------------------------------------------------------*/ void Winapi ec_cut_to_chp(ec_ref chp) { ec_post_goal(ec_term(ec_.d.call_explicit, ec_term(ec_.d.cut_to,ec_ref_get(chp)), ec_atom(ec_.d.kernel_sepia))); } /*---------------------------------------------------------------------- * C->Prolog and Prolog->C type conversions *----------------------------------------------------------------------*/ pword Winapi ec_atom(const dident a) { pword w; if (a == ec_.d.nil) { Make_Nil(&w); } else { Make_Atom(&w,a); } return w; } int Winapi ec_get_atom(const pword w, dident *a) { const pword * pw = &w; Dereference_(pw); if (IsAtom(pw->tag)) *a = pw->val.did; else if (IsNil(pw->tag)) *a = ec_.d.nil; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } pword Winapi ec_string(const char *s) { pword w; Make_String(&w, (char *) s); return w; } pword Winapi ec_length_string(int l, const char *s) { pword w; char *s1; w.tag.kernel = TSTRG; w.val.ptr = TG; Push_Buffer(l+1); s1 = (char *) BufferStart(w.val.ptr); Copy_Bytes(s1, (char *) s, l); s1[l] = 0; return w; } int Winapi ec_get_string(const pword w, char **s) { const pword *pw = &w; Dereference_(pw); if (IsString(pw->tag)) *s = StringStart(pw->val); else if (IsAtom(pw->tag)) *s = DidName(pw->val.did); else if (IsNil(pw->tag)) *s = DidName(ec_.d.nil); else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } int Winapi ec_get_string_length(const pword w, char **s, long int *l) { const pword *pw = &w; Dereference_(pw); if (IsString(pw->tag)) { *s = StringStart(pw->val); *l = StringLength(pw->val); } else if (IsAtom(pw->tag)) { *s = DidName(pw->val.did); *l = DidLength(pw->val.did); } else if (IsNil(pw->tag)) { *s = DidName(ec_.d.nil); *l = 2; } else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } pword Winapi ec_long(const long int l) { pword w; Make_Integer(&w,(word)l); return w; } int Winapi ec_get_long(const pword w, long int *l) { const pword *pw = &w; Dereference_(pw); if (IsInteger(pw->tag)) { #if SIZEOF_WORD > SIZEOF_LONG /* range error if val.nint is too large for long */ if (pw->val.nint > LONG_MAX || pw->val.nint < LONG_MIN) return RANGE_ERROR; #endif *l = pw->val.nint; } else if (IsBignum(pw->tag)) return RANGE_ERROR; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } #ifdef HAVE_LONG_LONG #ifndef SIZEOF_LONG_LONG #ifdef __SIZEOF_LONG_LONG__ #define SIZEOF_LONG_LONG __SIZEOF_LONG_LONG__ #else #define SIZEOF_LONG_LONG 8 #endif #endif pword Winapi ec_long_long(const long long int l) { pword w; tag_desc[TBIG].arith_op[ARITH_BOXLONGLONG](l, &w); return w; } int Winapi ec_get_long_long(const pword w, long long int *l) { const pword *pw = &w; Dereference_(pw); if (IsInteger(pw->tag)) { #if SIZEOF_WORD > SIZEOF_LONG_LONG /* range error if val.nint is too large for long long */ if (pw->val.nint > LLONG_MAX || pw->val.nint < LLONG_MIN) return RANGE_ERROR; #endif *l = pw->val.nint; } else if (IsBignum(pw->tag)) return tag_desc[TBIG].arith_op[ARITH_TOCLONGLONG](&w, l) < 0 ? RANGE_ERROR : PSUCCEED; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } #endif pword Winapi ec_double(const double d) { pword result; Make_Double(&result, d); return result; } int Winapi ec_get_double(const pword w, double *d) { const pword *pw = &w; Dereference_(pw); if (IsDouble(pw->tag)) *d = Dbl(pw->val); else if (IsInteger(pw->tag)) *d = (double) pw->val.nint; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } #ifdef STDC_HEADERS pword ec_term(dident functor, ...) { va_list ap; int arity = DidArity(functor); pword * pw; pword result; int i; va_start(ap, functor); pw = TG; Push_Struct_Frame(functor); for (i=1 ; i <= arity ; i++) pw[i] = va_arg(ap,pword); va_end(ap); Make_Struct(&result,pw); return result; } #else pword ec_term(va_alist) va_dcl { va_list ap; dident functor; int arity; pword * pw; pword result; int i; va_start(ap); functor = va_arg(ap,dident); arity = DidArity(functor); pw = TG; Push_Struct_Frame(functor); for (i=1 ; i <= arity ; i++) pw[i] = va_arg(ap,pword); va_end(ap); Make_Struct(&result,pw); return result; } #endif pword Winapi ec_term_array(const dident functor, const pword *args) { int arity; pword * pw; pword result; arity = DidArity(functor); pw = TG; Make_Struct(&result,pw); Push_Struct_Frame(functor); pw++; while(arity--) *pw++ = *args++; return result; } pword Winapi ec_matrixofdouble(int n, int m, const double *darr) { dident row_functor = enter_dict("[]", n); dident col_functor = enter_dict("[]", m); pword *rows, *col; pword result; int i,j; rows = TG; Push_Struct_Frame(row_functor); for(i=1; i<=n; ++i) { col = TG; Make_Struct(&rows[i], col); Push_Struct_Frame(col_functor); for(j=1; j<=m; ++j) { Make_Double(&col[j], *darr++); } } Make_Struct(&result,rows); return result; } pword Winapi ec_arrayofdouble(int n, const double *darr) { dident functor = enter_dict("[]", n); pword result; pword *row; int i; row = TG; Push_Struct_Frame(functor); for(i=1; i<=n; ++i) { Make_Double(&row[i], *darr++) } Make_Struct(&result,row); return result; } pword Winapi ec_list(const pword head, const pword tail) { pword * pw; pword result; pw = TG; Push_List_Frame(); pw[0] = head; pw[1] = tail; Make_List(&result,pw); return result; } pword Winapi ec_listofdouble(int length, const double *array) { pword result; pword *pw = &result; while (length-- > 0) { Make_List(pw,TG); pw = TG; Push_List_Frame(); *pw++ = ec_double(*array++); } Make_Nil(pw); return result; } pword Winapi ec_listoflong(int length, const long int *array) { pword result; pword *pw = &result; while (length-- > 0) { Make_List(pw,TG); pw = TG; Push_List_Frame(); *pw++ = ec_long(*array++); } Make_Nil(pw); return result; } pword Winapi ec_listofchar(int length, const char *array) { pword result; pword *pw = &result; while (length-- > 0) { Make_List(pw,TG); pw = TG; Push_List_Frame(); *pw++ = ec_long(*array++); } Make_Nil(pw); return result; } pword Winapi ec_listofrefs(ec_refs refs) { pword result; pword *pw = &result; int length = refs->size; int i; if (refs->refstate != EC_REF_C_P) _ec_ref_init(refs); for (i=1; i<=length; i++) { Make_List(pw,TG); pw = TG; Push_List_Frame(); *pw++ = refs->var.val.ptr[i]; } Make_Nil(pw); return result; } int Winapi ec_get_nil(const pword list) { const pword * pw = &list; Dereference_(pw); return IsNil(pw->tag)? PSUCCEED: PFAIL; } int Winapi ec_is_var(const pword w) { const pword * pw = &w; Dereference_(pw); return IsRef(pw->tag)? PSUCCEED: PFAIL; } int Winapi ec_get_list(const pword list, pword *car, pword *cdr) { const pword * pw = &list; Dereference_(pw); if (IsList(pw->tag)) { *car = pw->val.ptr[0]; *cdr = pw->val.ptr[1]; return PSUCCEED; } else if (IsNil(pw->tag)) return PFAIL; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; } int Winapi ec_get_arg(const int n, pword term, pword *arg) { pword * pw = &term; Dereference_(pw); if (IsStructure(pw->tag)) if (n < 1 || n > DidArity(pw->val.ptr->val.did)) return RANGE_ERROR; else *arg = pw->val.ptr[n]; else if (IsList(pw->tag)) if (n < 1 || n > 2) return RANGE_ERROR; else *arg = pw->val.ptr[n-1]; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } int Winapi ec_get_functor(const pword term, dident *d) { const pword * pw = &term; Dereference_(pw); if (IsStructure(pw->tag)) *d = pw->val.ptr->val.did; else if (IsList(pw->tag)) *d = ec_.d.list; else if (IsRef(pw->tag)) return INSTANTIATION_FAULT; else return TYPE_ERROR; return PSUCCEED; } int Winapi ec_arity(const pword term) { const pword * pw = &term; Dereference_(pw); if (IsList(pw->tag)) return 2; if (IsStructure(pw->tag)) return DidArity(pw->val.ptr->val.did); return 0; } pword Winapi ec_newvar(void) { pword * pw; pw = TG++; Make_Ref(pw,pw); return *pw; } pword Winapi ec_nil(void) { pword p; Make_Nil(&p); return p; } static void ec_deref(pword *ppw) /* dereference in place */ { if (IsRef(ppw->tag)) { pword *ppw1 = ppw; Dereference_(ppw); *ppw1 = *ppw; } } int Winapi ec_var_lookup(ec_ref vars, char *name, pword *var) { pword list; pword pair; pword varname; list = ec_ref_get(vars); while (ec_deref(&list),IsList(list.tag)) { if ( PSUCCEED == ec_get_arg(1,list,&pair) && (ec_deref(&pair), IsList(pair.tag)) && PSUCCEED == ec_get_arg(1,pair,&varname) && (ec_deref(&varname), IsAtom(varname.tag)) && 0 == strcmp(DidName(varname.val.did),name) ) { ec_get_arg(2,pair,var); return PSUCCEED; } else { if (PSUCCEED != ec_get_arg(2,list,&list)) return PFAIL; } } return PFAIL; } /*---------------------------------------------------------------------- * Support for external C predicates *----------------------------------------------------------------------*/ int Winapi ec_unify(pword pw1, pword pw2) { return ec_unify_(pw1.val, pw1.tag, pw2.val, pw2.tag, &MU); } int Winapi ec_unify_arg(int n, pword term) { #ifdef __STDC__ static type tref = {TREF}; #else type tref; tref.kernel = TREF; #endif return ec_unify_(A[n].val, A[n].tag, term.val, term.tag, &MU); } int Winapi ec_compare(pword pw1, pword pw2) { pword *ppw1 = &pw1; pword *ppw2 = &pw2; Dereference_(ppw1); Dereference_(ppw2); return ec_compare_terms(ppw1->val, ppw1->tag, ppw2->val, ppw2->tag); } pword Winapi ec_arg(int n) { return A[n]; } int Winapi ec_schedule_suspensions(pword attr, int pos) { Check_Structure(attr.tag); if (pos < 1 || pos > DidArity(attr.val.ptr[0].val.did)) return RANGE_ERROR; return ec_schedule_susps(&(attr.val.ptr[pos])); } int Winapi ec_visible_procedure(dident proc_did, pword module, void **pproc) { pri *proc = visible_procedure(proc_did, module.val.did, module.tag, 0); if (!proc) { int res; Get_Bip_Error(res); return res; } *pproc = (void*) proc; return PSUCCEED; } /*---------------------------------------------------------------------- * Some predefined external data types *----------------------------------------------------------------------*/ /* * double [] */ static pword _double_arr_get(t_ext_ptr h, int i) { return ec_double(((double*)h)[i]); } static int _double_arr_set(t_ext_ptr h, int i, pword pw) { return ec_get_double(pw, &((double*)h)[i]); } t_ext_type ec_xt_double_arr = { 0, 0, 0, 0, 0, 0, 0, _double_arr_get, _double_arr_set }; /* * long [] */ static pword _long_arr_get(t_ext_ptr h, int i) { return ec_long(((long*)h)[i]); } static int _long_arr_set(t_ext_ptr h, int i, pword pw) { return ec_get_long(pw, &((long*)h)[i]); } t_ext_type ec_xt_long_arr = { 0, 0, 0, 0, 0, 0, 0, _long_arr_get, _long_arr_set }; /* * char [] */ static pword _char_arr_get(t_ext_ptr h, int i) { return ec_long((long) ((char*)h)[i]); } static int _char_arr_set(t_ext_ptr h, int i, pword pw) { long l; int err = ec_get_long(pw, &l); if (err == PSUCCEED) ((char*) h)[i] = (char) l; return err; } static int _char_arr_ss(t_ext_ptr h, int quoted) { return strlen((char*) h) + (quoted? 2: 0); } static int _char_arr_tos(t_ext_ptr h, char *buf, int quoted) { char *dest = buf; char *src = (char*) h; if (quoted) { *dest++ = '"'; while (*dest++ = *src++) ; *(dest-1) = '"'; *dest++ = 0; } else { while (*dest++ = *src++) ; } return dest-buf-1; } t_ext_type ec_xt_char_arr = { 0, 0, 0, _char_arr_ss, _char_arr_tos, 0, 0, _char_arr_get, _char_arr_set };