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; }
/* * Must be called on the worker that created the bag, no check yet! */ static int p_dbag_dissolve(value vdbag, type tdbag, value vl, type tl) { aport_id_t bag_aport_id; dbag_descr_t *dbag_descr; amsg_t this_msg; amsg_ref_t *this_msg_data_hdr; pword list; register pword *car, *cdr; Check_Integer(tdbag); bag_aport_id = (aport_id_t) vdbag.nint; Check_Output_List(tl); if (aport_get_option(bag_aport_id, APORT_DATA_PTR, (aport_optval_t *) &dbag_descr) != AMSG_OK) { Bip_Error(MPS_ERROR); } this_msg = dbag_descr->first.msg; this_msg_data_hdr = dbag_descr->first.msg_data_hdr; hp_free_size((generic_ptr) dbag_descr, sizeof(dbag_descr_t)); cdr = &list; while (this_msg_data_hdr != &dbag_descr->first) { pword *pw1; amsg_t old_msg; car = TG; Push_List_Frame(); Make_List(cdr, car); cdr = car + 1; pw1 = dbformat_to_term((char*)(this_msg_data_hdr+1), D_UNKNOWN, tdict); if (!pw1) { value va; va.did = d_.abort; Bip_Throw(va, tdict); } car->val.ptr = pw1->val.ptr; car->tag.kernel = pw1->tag.kernel; old_msg = this_msg; this_msg = this_msg_data_hdr->msg; this_msg_data_hdr = this_msg_data_hdr->msg_data_hdr; (void) amsg_free(old_msg); } Make_Nil(cdr); if (aport_deallocate(bag_aport_id) != AMSG_OK) { Bip_Error(MPS_ERROR); } Return_Unify_Pw(vl, tl, list.val, list.tag); }
pword * dbformat_to_term(register char *buf, dident mod, type tmod) { register pword *pw; pword *p; pword *base, *top; pword *prev_ld = LD; pword *r; pword meta; word n, t; int res; meta.tag.kernel = TNIL; Load_Int32(n); base = pw = TG; TG = WordOffset(TG, n); if (GlobalStackOverflow) return (pword *)0; top = TG; while (pw < top) { Load_Byte(t); switch (TagTypeC(t)) { case TINT: /* value */ #ifdef OLD_FORMAT Load_Int32(n); #else Load_Int(n); #endif pw->val.nint = n; pw++->tag.kernel = t; break; case TNIL: /* */ pw++->tag.kernel = t; break; case TVAR_TAG: /* offset */ Load_Int(n); pw->val.ptr = WordOffset(base, n); pw++->tag.kernel = TREF; break; case TUNIV: /* offset, length, "string\0" */ case TNAME: case TMETA: Load_Int(n); pw->val.ptr = WordOffset(base, n); Load_Int(n); if (n) { pw++->tag.kernel = DidTag(t, enter_dict_n(buf, n, 0)); #ifdef OLD_FORMAT buf += n + 1; #else buf += n; #endif } else pw++->tag.kernel = RefTag(t); /* no name */ if (TagTypeC(t) == TMETA) { p = TG; TG += 2; Check_Gc p[0].val.ptr = pw; p[0].tag.kernel = TREF; p[1] = meta; meta.val.ptr = p; meta.tag.kernel = TLIST; } break; case TSUSP: case TCOMP: case TLIST: Load_Int(n); pw->val.ptr = WordOffset(base, n); pw++->tag.kernel = t; break; case TDICT: /* arity, length, "string\0" */ Load_Int(n); Load_Int(t); pw->val.did = enter_dict_n(buf, t, (int) n); pw++->tag.kernel = TDICT; #ifdef OLD_FORMAT buf += t + 1; #else buf += t; #endif break; case TDBL: /* length, double */ { ieee_double d; Load_Byte(n); /* backward compatibility */ Load_Int32(d.as_struct.mant1); Load_Int32(d.as_struct.mant0); Make_Double(pw, d.as_dbl); pw++; } break; case TIVL: /* double, double */ { ieee_double dlwb, dupb; Load_Int32(dlwb.as_struct.mant1); Load_Int32(dlwb.as_struct.mant0); Load_Int32(dupb.as_struct.mant1); Load_Int32(dupb.as_struct.mant0); Push_Interval(pw->val.ptr, dlwb.as_dbl, dupb.as_dbl); pw++->tag.kernel = TIVL; } break; case TSTRG: /* length, "string" */ { register char *string; Load_Int(n); Make_Stack_String(n, pw->val, string); pw++->tag.kernel = TSTRG; #ifdef OLD_FORMAT while (n-- >= 0) *string++ = *buf++; #else while (n-- > 0) *string++ = *buf++; *string = 0; #endif } break; case TDE: pw[SUSP_LD].val.ptr = LD; Update_LD(pw) Load_Int32(n); pw[SUSP_FLAGS].tag.kernel = n; pw[SUSP_PRI].val.ptr = (pword *) 0; /* missing */ pw[SUSP_INVOC].tag.kernel = 0; if (!SuspDead(pw)) { Load_Byte(n); Init_Susp_State(pw, n & 0xF, (n>>4) & 0xF); pw += SUSP_GOAL; } else { pw += SUSP_HEADER_SIZE; } break; default: if (t >= 0 && t <= NTYPES) { Load_Int(n); pw->tag.kernel = t; /* from_string() may change tag! */ if (tag_desc[t].from_string(buf, pw, 10) != PSUCCEED) { /* this can happen e.g. if we try to read a bignum * in an Eclipse that doesn't support them */ Make_Nil(pw); p_fprintf(current_err_, "dbformat_to_term: cannot represent constant of type %s\n", DidName(tag_desc[t].tag_name)); } ++pw; buf += n+1; } else { Make_Nil(pw); p_fprintf(current_err_, "bad type in dbformat_to_term: 0x%x\n", t); pw++; buf++; } break; }
int ec_load_eco_from_stream(stream_id nst, int options, pword *module) { int res; pword *clause, *query, *pw; pword query_pw, kernel_pw; pword top_module = *module; int encoded = 0; /* we are expecting an eco-encoded file, but we allow text as well */ res = _read_eco_header(nst); encoded = (res == PSUCCEED); StreamMode(nst) |= SNOMACROEXP; /* to avoid problems in text-eco files */ kernel_pw.val.did = d_.kernel_sepia; kernel_pw.tag.kernel = ModuleTag(d_.kernel_sepia); for(;;) { int recreate_module = 0; pword exports_pw, language_pw; pword *new_module = 0; if (encoded) /* encoded dbformat */ { int n; word nread; char *s = ec_getstring(nst, 4, &nread); if (!(s)) return nread; /* error code */ if (nread < 4) return (nread == 0) ? PSUCCEED : UNEXPECTED_EOF; n = (unsigned char) *s++ << 24; n |= (unsigned char) *s++ << 16; n |= (unsigned char) *s++ << 8; n |= (unsigned char) *s; s = ec_getstring(nst, n, &nread); if (!(s)) return nread; /* error code */ if (nread < n) return UNEXPECTED_EOF; clause = dbformat_to_term(s, module->val.did, module->tag); if (!clause) return NOT_DUMP_FILE; } else /* text format, call the parser */ { res = ec_read_term(nst, (GlobalFlags & VARIABLE_NAMES ? VARNAMES_PLEASE : 0), &query_pw, 0, 0, module->val, module->tag); if (res != PSUCCEED) return (res == PEOF) ? PSUCCEED : NOT_DUMP_FILE; clause = &query_pw; } Dereference_(clause); if (!IsStructure(clause->tag) || !Query(clause->val.ptr->val.did)) return NOT_DUMP_FILE; pw = query = clause->val.ptr + 1; Dereference_(pw); if (IsStructure(pw->tag)) /* look for special directives */ { if (pw->val.ptr->val.did == d_.module1) { recreate_module = 1; new_module = &pw->val.ptr[1]; Make_Nil(&exports_pw); Make_Atom(&language_pw, d_eclipse_language_); } if (pw->val.ptr->val.did == d_module_interface) { recreate_module = 1; new_module = &pw->val.ptr[1]; Make_Nil(&exports_pw); Make_Atom(&language_pw, d_eclipse_language_); } else if (pw->val.ptr->val.did == d_module2) { recreate_module = 1; new_module = &pw->val.ptr[1]; exports_pw = pw->val.ptr[2]; Make_Atom(&language_pw, d_eclipse_language_); } else if (pw->val.ptr->val.did == d_module3) { recreate_module = 1; new_module = &pw->val.ptr[1]; exports_pw = pw->val.ptr[2]; language_pw = pw->val.ptr[3]; } else if (pw->val.ptr->val.did == d_begin_module) { new_module = &pw->val.ptr[1]; query = &query_pw; /* don't execute anything */ Make_Atom(query, d_.true0); } else if (pw->val.ptr->val.did == d_.pragma) { query = &query_pw; /* ignore pragmas, replace with true */ Make_Atom(query, d_.true0); } } else if (pw->val.did == d_.system || pw->val.did == d_.system_debug) { query = &query_pw; /* ignore pragmas, replace with true */ Make_Atom(query, d_.true0); } if (recreate_module) /* build translated module query */ { pword *pgoal, *pcont; query = &query_pw; Make_Struct(query, TG); /* If module changes, raise CODE_UNIT_LOADED event first */ if (module->val.did != top_module.val.did) { pcont = TG; Push_Struct_Frame(d_.comma); Make_Struct(&pcont[1], TG); pgoal = TG; Push_Struct_Frame(d_.syserror); Make_Integer(&pgoal[1], CODE_UNIT_LOADED); Make_Atom(&pgoal[2], d_.eof); pgoal[3] = *module; pgoal[4] = *module; Make_Struct(&pcont[2], TG); } pcont = TG; Push_Struct_Frame(d_.comma); Make_Struct(&pcont[1], TG); pgoal = TG; Push_Struct_Frame(d_erase_module_); pgoal[1] = *new_module; Make_Struct(&pcont[2], TG); pgoal = TG; Push_Struct_Frame(d_create_module3_); pgoal[1] = *new_module; pgoal[2] = exports_pw; pgoal[3] = language_pw; res = query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag); } else { /* execute the query/directive */ res = query_emulc(query->val, query->tag, module->val, module->tag); } if (res != PSUCCEED) { pw = TG; Push_Struct_Frame(d_.syserror); Make_Integer(&pw[1], QUERY_FAILED); pw[2] = *query; pw[3] = *module; pw[4] = *module; query = &query_pw; Make_Struct(query, pw); (void) query_emulc(query->val, query->tag, kernel_pw.val, kernel_pw.tag); } if (new_module) /* change to new context module */ { Dereference_(new_module); *module = *new_module; } } return PSUCCEED; }