1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * VERSION $Id: bip_db.c,v 1.18 2013/03/04 18:22:32 kish_shen Exp $ 25 */ 26 27/**************************************************************************** 28 * 29 * SEPIA Built-in Predicates: Database 30 * 31 * 32 *****************************************************************************/ 33/* 34 * IDENTIFICATION bip_db.c 35 * 36 * DESCRIPTION 37 * 38 * CONTENTS: 39 * 40 * AUTHOR VERSION DATE REASON 41 * periklis 26.9.89 Major revision for the logical update semantics 42 * Dominique 43 * 44 */ 45 46 47#include "config.h" 48#include "sepia.h" 49#include "types.h" 50#include "embed.h" 51#include "mem.h" 52#include "error.h" 53#include "ec_io.h" 54#include "opcode.h" 55#include "gencode.h" 56#include "dict.h" 57#include "database.h" 58#include "emu_export.h" 59#include "module.h" 60#include "debug.h" /* for external definitions */ 61#include "property.h" 62 63#define MAX_KILLS 50 64#define MAX_KILLED_SIZE 1000 65 66#define Add_Did(vname, tname, varity, tarity, d) \ 67 if (IsRef(tname) || IsRef(tarity)) { \ 68 Bip_Error(INSTANTIATION_FAULT) \ 69 } \ 70 if (IsNil(tname)) d = add_dict(d_.nil, (int) varity.nint);\ 71 else { \ 72 if ((!IsAtom(tname)) || (!IsInteger(tarity))) { \ 73 Bip_Error(TYPE_ERROR) \ 74 } \ 75 d = add_dict(vname.did, (int) varity.nint); \ 76 } 77 78#define Get_Macro_Did(vproc, tproc, wd) \ 79 if (IsStructure(tproc) && vproc.ptr->val.did == d_type_) {\ 80 int res = _type_did(vproc.ptr+1, &(wd));\ 81 Return_If_Error(res);\ 82 } else {\ 83 Get_Functor_Did(vproc, tproc, wd)\ 84 } 85 86 87extern void 88 add_proc_to_chain(pri *p, proc_duet **chain), 89 reclaim_abolished_procedures(void); 90 91extern vmcode par_fail_code_[]; 92 93 94extern t_ext_type heap_rec_header_tid; 95 96static int 97#ifdef DBGING_DYN_DB 98 p_print_gc(void), 99#endif /* DBGING_DYN_DB */ 100 p_abolish(value n, type tn, value a, type ta, value vm, type tm), 101 p_current_functor(value valn, type tagn, value vala, type taga, value vopt, type topt, value valsn, type tagsn), 102 p_dynamic_create(value v1, type t1, value v2, type t2, value vm, type tm), 103 p_dynamic_source(value v1, type t1, value v2, type t2, value vsrc, type tsrc, value vm, type tm), 104 p_is_dynamic(value v1, type t1, value v2, type t2, value vm, type tm), 105 p_is_built_in(value val, type tag, value vm, type tm), 106 p_is_predicate(value val, type tag, value vm, type tm), 107 p_module_predicates(value vwhich, type twhich, value v, type t, value vm, type tm), 108 p_external(value vp, type tp, value vf, type tf, value vm, type tm), 109 p_b_external(value vp, type tp, value vf, type tf, value vm, type tm), 110 p_external_body(value vpred, type tpred, value vmod, type tmod), 111 p_load_eco(value vfile, type tfile, value vopt, type topt, value vmod, type tmod, value vout, type tout), 112#ifdef PRINTAM 113 p_vm_statistics(value v, type t), 114#endif 115#ifndef NOALS 116 p_als(value val, type tag, value vm, type tm), 117#endif 118 p_store_pred(value vproc, type tproc, value vcode, type tcode, value vsize, type tsize, value vbrktable, type tbrktable, value vflags, type tflags, value vfid, type tfid, value vlid, type tlid, value vbid, type tbid, value vm, type tm), 119 p_retrieve_code(value vproc, type tproc, value vcode, type tcode, value vm, type tm), 120 p_decode_code(value vcode, type tcode, value v, type t), 121 p_functor_did(value vspec, type tspec, value v, type t), 122 p_set_proc_flags(value vproc, type tproc, value vf, type tf, value vv, type tv, value vm, type tm), 123 p_proc_flags(value vn, type tn, value vc, type tc, value vf, type tf, value vm, type tm, value vp, type tp), 124 p_define_macro(value vproc, type tproc, value vtrans, type ttrans, value vprop, type tprop, value vmod, type tmod), 125 p_erase_macro(value vproc, type tproc, value vmod, type tmod), 126 p_erase_macro3(value vproc, type tproc, value vprop, type tprop, value vmod, type tmod), 127 p_illegal_macro(value v1, type t1, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5), 128 p_is_macro(value v1, type t1, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5, value v6, type t6), 129 p_visible_term_macro(value v1, type t1, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5, value v6, type t6), 130 p_visible_goal_macro(value vgoal, type tgoal, value vtrans, type ttrans, value vlm, type tlm, value vcm, type tcm), 131 p_trimcore(void), 132 p_create_call_n(value vn, type tn, value va, type ta), 133 p_mode(value pv, type pt, value mv, type mt); 134 135static int _type_did(pword*, dident*); 136 137static dident 138 d_autoload_, 139 d_auxiliary_, 140 d_demon_, 141 d_deprecated_, 142 d_dynamic_, 143 d_static_, 144 d_unfold6_, 145 d_invisible_, 146 d_imported_, 147 d_reexported_, 148 d_exported_, 149 d_parallel_, 150 d_run_priority_, 151 d_start_tracing_, 152#ifdef EXTENDED_MODES 153 d_plusminus, 154 d_minusplus, 155#endif 156 d_constant, 157 d_constant2, 158 d_nonvar, 159 d_ground, 160 d_a1, 161 d_y1, 162 d_ymask, 163 d_align, 164 d_table2, 165 d_refm, 166 d_edesc, 167 d_try_table2, 168 d_t1, 169 d_w1, 170 d_pw1, 171 d_mv1, 172 d_an1, 173 d_nv1, 174 d_par_fail, 175 d_init2, 176 d_val1, 177 d_tag1, 178 d_opc1, 179 d_proc1, 180 d_functor1, 181 d_ref1, 182 d_ref2, 183 d_source_file_, 184 d_source_line_, 185 d_source_offset_, 186 d_tags, 187 d_trace_meta_, 188 d_type0_, 189 d_type_; 190 191 192#define PREDLIST_UNDECLARED 0 193#define PREDLIST_LOCAL 1 194#define PREDLIST_EXPORTED 2 195#define PREDLIST_REEXPORTED 3 196#define PREDLIST_EXREEX 4 197#define PREDLIST_DEFINED 5 /* LOCAL or EXPORTED */ 198#define PREDLIST_UNDEFINED 6 /* LOCAL or EXPORTED */ 199#define PREDLIST_NOMODULE 7 200#define PREDLIST_NOEXPORT 8 201#define PREDLIST_DEPRECATED 9 202#define PREDLIST_SIZE 10 203 204static dident 205 d_predlist_option[PREDLIST_SIZE]; 206 207 208/* 209When a clause is asserted, its birth tag is set to the value of 210DynGlobalClock When a clause is retracted, its death tag is set 211to it. After both actions, DynGlobalClock is incremented by one. 212Whenever a call to a dynamic procedure is made it 'sees' only the 213currently living clauses, i.e. the ones for which 214birth < (DynGlobalClock at time of call) <= death. 215*/ 216 217/* DynKilledCodeSize keeps a count of the size of 'retracted' code. 218When this exceeds a set value, the dynamic database garbage collector 219is invoked. 220*/ 221 222 223void 224bip_db_init(int flags) 225{ 226 pri * proc; 227 228 d_autoload_ = in_dict("autoload", 0); 229 d_auxiliary_ = in_dict("auxiliary", 0); 230 d_trace_meta_ = in_dict("trace_meta", 0); 231 d_demon_ = in_dict("demon", 0); 232 d_deprecated_ = in_dict("deprecated", 0); 233 d_static_ = in_dict("static", 0); 234 d_dynamic_ = in_dict("dynamic", 0); 235 d_invisible_ = in_dict("invisible", 0); 236 d_imported_ = in_dict("imported", 0); 237 d_reexported_ = in_dict("reexported", 0); 238 d_exported_ = in_dict("exported", 0); 239 d_parallel_ = in_dict("parallel", 0); 240 d_run_priority_ = in_dict("run_priority", 0); 241 d_start_tracing_ = in_dict("start_tracing", 0); 242#ifdef EXTENDED_MODES 243 d_plusminus = in_dict("+-", 0); 244 d_minusplus = in_dict("-+", 0); 245#endif 246 d_constant = in_dict("constant", 0); 247 d_constant2 = in_dict("constant", 2); 248 d_nonvar = in_dict("nonvar", 0); 249 d_ground = in_dict("ground", 0); 250 d_a1 = in_dict("a", 1); 251 d_y1 = in_dict("y", 1); 252 d_ymask = in_dict("ymask", 1); 253 d_align = in_dict("align", 1); 254 d_table2 = in_dict("table", 2); 255 d_edesc = in_dict("edesc", 1); 256 d_try_table2 = in_dict("try_table", 2); 257 d_t1 = in_dict("t", 1); 258 d_w1 = in_dict("w", 1); 259 d_pw1 = in_dict("pw", 1); 260 d_nv1 = in_dict("nv", 1); 261 d_mv1 = in_dict("mv", 1); 262 d_an1 = in_dict("an", 1); 263 d_val1 = in_dict("val", 1); 264 d_tag1 = in_dict("tag", 1); 265 d_opc1 = in_dict("o", 1); 266 d_functor1 = in_dict("functor", 1); 267 d_proc1 = in_dict("proc", 1); 268 d_type0_ = in_dict("type", 0); 269 d_type_ = in_dict("type", 1); 270 d_init2 = in_dict("init", 2); 271 d_ref1 = in_dict("ref", 1); 272 d_ref2 = in_dict("ref", 2); 273 d_refm = in_dict("refm", 2); 274 d_tags = in_dict("tags", 0); 275 d_par_fail = in_dict("par_fail", 0); 276 d_source_file_ = in_dict("source_file", 0); 277 d_source_line_ = in_dict("source_line", 0); 278 d_source_offset_ = in_dict("source_offset", 0); 279 d_unfold6_ = in_dict("unfold", 6); 280 281 d_predlist_option[PREDLIST_UNDECLARED] = in_dict("undeclared",0); 282 d_predlist_option[PREDLIST_LOCAL] = in_dict("local",0); 283 d_predlist_option[PREDLIST_EXPORTED] = in_dict("exported",0); 284 d_predlist_option[PREDLIST_REEXPORTED] = in_dict("reexported",0); 285 d_predlist_option[PREDLIST_EXREEX] = in_dict("exported_reexported",0); 286 d_predlist_option[PREDLIST_DEFINED] = in_dict("defined",0); 287 d_predlist_option[PREDLIST_UNDEFINED] = in_dict("undefined",0); 288 d_predlist_option[PREDLIST_NOMODULE] = in_dict("no_module",0); 289 d_predlist_option[PREDLIST_NOEXPORT] = in_dict("no_export",0); 290 d_predlist_option[PREDLIST_DEPRECATED] = in_dict("deprecated",0); 291 292 if (!(flags & INIT_SHARED)) 293 return; 294 295 DynGlobalClock = 1; 296 DynKilledCodeSize = 0; 297 DynNumOfKills = 0; 298 DynamicProcedures = 0; 299 300#ifndef NOALS 301 exported_built_in(in_dict("als_", 2), p_als, B_SAFE); 302#endif 303#ifdef PRINTAM 304 (void) built_in(in_dict("vm_statistics", 1), p_vm_statistics, B_UNSAFE|U_SIMPLE); 305#endif 306 (void) built_in(in_dict("load_eco", 4), p_load_eco, B_UNSAFE|U_SIMPLE); 307 (void) exported_built_in(in_dict("store_pred", 9), p_store_pred, B_UNSAFE); 308 exported_built_in(in_dict("retrieve_code", 3), p_retrieve_code, B_UNSAFE) 309 -> mode = BoundArg(2, GROUND); 310 (void) exported_built_in(in_dict("decode_code", 2), p_decode_code, B_UNSAFE); 311 (void) exported_built_in(in_dict("functor_did", 2), p_functor_did, B_UNSAFE); 312 313#ifdef DBGING_DYN_DB 314 (void) built_in(in_dict("print_gc", 0), p_print_gc, B_SAFE); 315#endif /* DBGING_DYN_DB */ 316 317 (void) local_built_in(in_dict("trimcore0", 0), p_trimcore, B_SAFE); 318 (void) exported_built_in(in_dict("abolish_", 3), p_abolish, B_SAFE); 319 (void) local_built_in(in_dict("dynamic_create_", 3), p_dynamic_create, B_SAFE); 320 (void) exported_built_in(in_dict("dynamic_source_", 4), p_dynamic_source, B_UNSAFE|U_SIMPLE); 321 exported_built_in(in_dict("is_dynamic_", 3), p_is_dynamic, B_SAFE); 322 (void) local_built_in(in_dict("is_built_in_", 2), p_is_built_in, B_SAFE); 323 proc = exported_built_in(in_dict("is_predicate_", 2), 324 p_is_predicate, B_SAFE); 325 b_built_in(in_dict("current_functor", 4), 326 p_current_functor, d_.kernel_sepia) 327 -> mode = BoundArg(1, CONSTANT) | BoundArg(2, CONSTANT); 328 (void) exported_built_in(in_dict("external_", 3), p_external, B_SAFE); 329 (void) exported_built_in(in_dict("b_external_", 3), p_b_external, B_SAFE); 330 (void) exported_built_in(in_dict("external_body", 2), 331 p_external_body, B_SAFE); 332 (void) exported_built_in(in_dict("b_external_body", 2), 333 p_external_body, B_SAFE); 334 local_built_in(in_dict("local_proc_flags", 5), p_proc_flags, B_UNSAFE|U_GROUND) 335 -> mode = BoundArg(3, GROUND); 336 (void) local_built_in(in_dict("set_proc_flags", 4), p_set_proc_flags, B_UNSAFE); 337 (void) local_built_in(in_dict("dict_param", 2), ec_dict_param, B_UNSAFE|U_SIMPLE); 338 (void) exported_built_in(in_dict("garbage_collect_dictionary", 0), 339 ec_gc_dictionary, B_SAFE); 340 (void) exported_built_in(in_dict("mode_", 2), p_mode, B_SAFE|U_SIMPLE); 341 (void) exported_built_in(in_dict("define_macro_", 4), p_define_macro, B_UNSAFE); 342 (void) exported_built_in(in_dict("erase_macro_", 2), p_erase_macro, B_UNSAFE); 343 (void) exported_built_in(in_dict("erase_macro_", 3), p_erase_macro3, B_UNSAFE); 344 (void) exported_built_in(in_dict("is_macro", 6), p_is_macro, B_SAFE); 345 (void) local_built_in(in_dict("visible_term_macro", 6), p_visible_term_macro, B_SAFE); 346 (void) local_built_in(in_dict("illegal_macro", 5), p_illegal_macro, B_SAFE); 347 (void) local_built_in(in_dict("visible_goal_macro", 4), p_visible_goal_macro, B_UNSAFE); 348 (void) local_built_in(in_dict("create_call_n", 2), p_create_call_n, B_UNSAFE); 349 local_built_in(in_dict("module_predicates", 3), p_module_predicates, B_UNSAFE) 350 -> mode = BoundArg(2, GROUND); 351#ifdef lint 352 (void) als((word)0); 353#endif 354} 355 356#ifdef DBGING_DYN_DB 357static int 358p_print_gc(void) /* print debugging information for the garbage collector */ 359{ 360p_fprintf(current_err_, "bip_db.c/p_print_gc: \n"); 361p_fprintf(current_err_, "DynGlobalClock: "); 362p_fprintf(current_err_, "%d \n", DynGlobalClock); 363p_fprintf(current_err_, "DynKilledCodeSize: "); 364p_fprintf(current_err_, "%d \n", DynKilledCodeSize); 365} 366#endif /* DBGING_DYN_DB */ 367 368 369 370/* ******************************************************************** 371 STATIC AND DYNAMIC CODE 372 * ******************************************************************* */ 373 374 375static int 376p_load_eco(value vfile, type tfile, value vopt, type topt, value vmod, type tmod, value vout, type tout) 377{ 378 stream_id nst; 379 char *file; 380 int res; 381 pword mod_pw; 382 383 Get_Name(vfile, tfile, file); 384 Check_Integer(topt); 385 Check_Atom_Or_Nil(vmod, tmod); 386 387 nst = ec_open_file(file, SREAD, &res); 388 if (nst == NO_STREAM) 389 { 390 Bip_Error(res); 391 } 392 mod_pw.val.all = vmod.all; 393 mod_pw.tag.all = tmod.all; 394 res = ec_load_eco_from_stream(nst, vopt.nint, &mod_pw); 395 (void) ec_close_stream(nst, CLOSE_FORCE); 396 if (res != PSUCCEED) 397 return res; 398 Return_Unify_Pw(mod_pw.val, mod_pw.tag, vout, tout); 399} 400 401 402#ifndef NOALS 403 404extern vmcode *print_am(register vmcode *code, vmcode **label, int *res, int option); 405 406/* 407 als_(Name/Arity, Module) 408 It prints on the current ouput stream the abstract 409 code of the specified procedure. 410*/ 411static int 412p_als(value val, type tag, value vm, type tm) 413{ 414 dident wdid; 415 vmcode *code = 0; 416 vmcode *label = 0; 417 int res; 418 pri *proc; 419 unsigned dflags; 420 int err; 421 422 Check_Module(tm, vm); 423#ifdef PRINTAM 424 if (!IsRef(tag) && IsInteger(tag)) 425 code = (vmcode *) val.nint; 426 else 427#endif 428 { 429 Get_Proc_Did(val, tag, wdid); 430 proc = visible_procedure(wdid, vm.did, tm, 0); 431 if (proc) 432 { 433 if (IsLocked(proc->module_def)) { 434 Bip_Error(LOCKED) 435 } 436 code = PriCode(proc); 437 dflags = PriFlags(proc); 438 p_fprintf(current_output_, "\n%s", DidName(wdid)); 439 p_fprintf(current_output_, "/%d", DidArity(wdid)); 440 if (PriCodeType(proc) != VMCODE) 441 { 442 (void) ec_outf(current_output_, "\ta built-in procedure\n", 22); 443 Fail_; 444 } 445 } 446 else /* procedure not visible */ 447 { 448 Get_Bip_Error(err); 449 Bip_Error(err); 450 } 451 } 452 if (code) 453 { 454#ifdef PRINTAM 455 p_fprintf(current_output_, " (0x%" W_MOD "x):", code); 456#else 457 (void) ec_outfs(current_output_, " :"); 458#endif 459 (void) ec_newline(current_output_); 460 do 461 code = print_am(code, &label, &res, 1); 462 while (code || (code = label)); 463 if (res == PFAIL) 464 {Fail_} 465 Succeed_; 466 } 467 else 468 { 469 Bip_Error(NOENTRY); 470 } 471} 472 473#if defined(PRINTAM) || defined(LASTPP) 474int 475als(vmcode *code) /* for use with dbx */ 476{ 477 vmcode *save_code = code; 478 vmcode *label = 0; 479 int res; 480 do 481 code = print_am(code, &label, &res, 3); 482 while (code || (code = label)); 483 if (res == PFAIL) 484 {Fail_} 485 Succeed_; 486} 487#endif /* PRINTAM */ 488#endif /* NOALS */ 489 490#ifdef PRINTAM 491static int 492p_vm_statistics(value v, type t) 493{ 494 if (IsRef(t)) 495 { 496 Return_Unify_Atom(v,t, (VM_FLAGS & STATISTICS) ? d_.on : d_.off); 497 } 498 else 499 { 500 Check_Atom(t); 501 if (v.did == d_.on) 502 { 503 VM_FLAGS |= STATISTICS; 504 } 505 else if (v.did == d_.off) 506 { 507 VM_FLAGS &= ~STATISTICS; 508 } 509 else 510 { 511 Bip_Error(RANGE_ERROR); 512 } 513 Succeed_; 514 } 515} 516 517#endif /* PRINTAM */ 518 519/* 520 is_predicate/1 521 succeeds if this predicate is defined: predicate can be any 522 predicate (prolog, builtin, external) 523*/ 524static int 525p_is_predicate(value val, type tag, value vm, type tm) 526{ 527 dident d; 528 pri *proc; 529 int err; 530 531 Check_Module(tm, vm); 532 Get_Proc_Did(val, tag, d); 533 proc = visible_procedure(d, vm.did, tm, PRI_DONTIMPORT); 534 if (!proc) 535 { 536 Get_Bip_Error(err); 537 switch(err) { 538 539 case IMPORT_PENDING: 540 Succeed_; /* assume it's defined... */ 541 542 case NOENTRY: 543 Fail_; 544 545 default: 546 Bip_Error(err); 547 } 548 } 549 Succeed_If(proc->flags & CODE_DEFINED) 550} 551 552 553static int 554p_module_predicates(value vwhich, type twhich, value v, type t, value vm, type tm) 555{ 556 pri *pd; 557 pword result; 558 pword *list = &result; 559 pword *pw; 560 int which; 561 562 Check_Atom(twhich); 563 Check_Output_List(t); 564 Check_Module(tm, vm); 565 for(which=0;;) 566 { 567 if (vwhich.did == d_predlist_option[which]) 568 break; 569 if (++which >= PREDLIST_SIZE) 570 { Bip_Error(RANGE_ERROR); } 571 } 572 switch(which) 573 { 574 case PREDLIST_EXREEX: 575 case PREDLIST_EXPORTED: 576 case PREDLIST_REEXPORTED: 577 break; 578 default: 579 Check_Module_Access(vm, tm); 580 break; 581 } 582 a_mutex_lock(&ProcedureLock); 583 a_mutex_lock(&ModuleLock); 584 pd = ModuleItem(vm.did)->procedures; 585 a_mutex_unlock(&ModuleLock); 586 587 for (; pd; pd = pd->next_in_mod) 588 { 589 switch(which) 590 { 591 case PREDLIST_UNDECLARED: 592 if (PriScope(pd) == DEFAULT && PriReferenced(pd)) 593 break; 594 continue; 595 case PREDLIST_LOCAL: 596 if (PriScope(pd) == LOCAL && PriFlags(pd) & CODE_DEFINED) 597 break; 598 continue; 599 case PREDLIST_EXPORTED: 600 if (PriScope(pd) == EXPORT && PriFlags(pd) & (CODE_DEFINED|AUTOLOAD)) 601 break; 602 continue; 603 case PREDLIST_REEXPORTED: 604 if (PriScope(pd) == IMPEXP && PriFlags(pd) & (CODE_DEFINED|AUTOLOAD)) 605 break; 606 continue; 607 case PREDLIST_EXREEX: 608 if (PriAnyExp(pd) && PriFlags(pd) & (CODE_DEFINED|AUTOLOAD)) 609 break; 610 continue; 611 case PREDLIST_DEFINED: 612 if ((PriScope(pd) == LOCAL || PriScope(pd) == EXPORT) 613 && PriFlags(pd) & CODE_DEFINED) 614 break; 615 continue; 616 case PREDLIST_UNDEFINED: 617 if ((PriScope(pd) == LOCAL || PriScope(pd) == EXPORT) 618 && !(PriFlags(pd) & CODE_DEFINED)) 619 break; 620 continue; 621 case PREDLIST_NOMODULE: 622 /* find references (import/quali) to predicates 623 * whose home module does not exist (yet) */ 624 if (PriIsProxy(pd) && !IsModule(PriHomeModule(pd))) 625 break; 626 continue; 627 case PREDLIST_NOEXPORT: 628 /* find references (import/quali) to predicates 629 * that are not exported from their home module (yet) */ 630 if (PriIsProxy(pd) && IsModule(PriHomeModule(pd))) 631 { 632 type module_tag; 633 module_tag.kernel = ModuleTag(PriDid(pd)); 634 if (!visible_procedure(PriDid(pd), PriHomeModule(pd), 635 module_tag, PRI_DONTIMPORT|PRI_EXPORTEDONLY)) 636 { 637 Set_Bip_Error(0); 638 break; 639 } 640 } 641 continue; 642 case PREDLIST_DEPRECATED: 643 if (PriIsProxy(pd) && PriFlags(pd) & PROC_DEPRECATED) 644 break; 645 continue; 646 } 647 Make_List(list, TG); 648 list = TG; 649 Push_List_Frame(); 650 Make_Struct(list, TG); 651 ++list; 652 if (which == PREDLIST_NOMODULE || which == PREDLIST_NOEXPORT) 653 { 654 /* build a qualified predspec HM:Pred because the problem 655 * is actually in the home module, not the lookup module */ 656 pw = TG; 657 Push_Struct_Frame(d_.colon); 658 Make_Atom(&pw[1], PriHomeModule(pd)); 659 Make_Struct(&pw[2], TG); 660 } 661 pw = TG; 662 Push_Struct_Frame(d_.quotient); 663 Make_Atom(&pw[1], add_dict(PriDid(pd), 0)); 664 Make_Integer(&pw[2], DidArity(PriDid(pd))); 665 } 666 Make_Nil(list); 667 a_mutex_unlock(&ProcedureLock); 668 Return_Unify_Pw(v, t, result.val, result.tag); 669} 670 671 672/* 673 * current_functor(?Name, ?Arity, +Option, +DictIndex) - backtrackable built-in 674 * 675 * The last argument is used to Remember() the position in the dictionary. 676 * We either backtrack through the whole dictionary or, when the 677 * name is known, through the respective collision chain. 678 * 679 * Option = 0 all functors 680 * Option = 1 functors with properties only 681 * Option = 2 functors with predicates only 682 */ 683/*ARGSUSED*/ 684static int 685p_current_functor(value valn, type tagn, value vala, type taga, value vopt, type topt, value valsn, type tagsn) 686{ 687 dident functor, atom; 688 value vnext; 689 690 vnext.all = valsn.all; 691 if (IsRef(tagn)) /* we have to backtrack through the whole dictionary */ 692 { 693 while (next_functor((int *) &vnext.nint, &functor)) 694 { 695 if (vopt.nint == 1 && !DidProperties(functor)) 696 continue; 697 if (vopt.nint == 2 && !DidProc(functor)) 698 continue; 699 700 if (IsRef(taga)) 701 { 702 Bind_Var(vala, taga, DidArity(functor), TINT); 703 } 704 else if (!(IsInteger(taga) && DidArity(functor) == vala.nint)) 705 { 706 continue; 707 } 708 709 atom = add_dict(functor, 0); 710 Bind_Var(valn, tagn, atom, (atom == d_.nil ? TNIL : TDICT)); 711 712 Remember(4, vnext, tint); 713 Succeed_; 714 } 715 } 716 else if (IsAtom(tagn) /* name known, we can optimise this case */ 717 || (IsNil(tagn) && (valn.did = d_.nil))) /* I really mean '=' ! */ 718 { 719 if (IsInteger(tagsn)) /* initial call */ 720 { 721 if (IsInteger(taga)) /* name and arity are known, just check */ 722 { 723 Cut_External; 724 Succeed_If(check_did(valn.did, (int) vala.nint) != D_UNKNOWN) 725 } 726 else if (!IsRef(taga)) 727 { 728 Cut_External; 729 Fail_; 730 } 731 functor = valn.did; /* return the atom first */ 732 } 733 else /* find the next functor with this name */ 734 { 735 functor = (dident) DidNext(valsn.did); 736 while (functor != valn.did) 737 { 738 if (DidString(functor) == DidString(valn.did) 739 && (vopt.nint == 0 740 || vopt.nint == 1 && DidProperties(functor) 741 || vopt.nint == 2 && DidProc(functor))) 742 break; 743 functor = (dident) DidNext(functor); 744 } 745 if (functor == valn.did) /* wrapped around the chain, stop */ 746 { 747 Cut_External; 748 Fail_; 749 } 750 } 751 /* return the arity of functor and remember functor */ 752 vnext.did = functor; 753 Remember(4, vnext, tdict); 754 /* IsRef(taga) */ 755 Bind_Var(vala, taga, DidArity(functor), TINT); 756 Succeed_; 757 } 758 Cut_External; 759 Fail_; 760} 761 762 763/**************************************************************** 764 * Dynamic definitions of external predicates 765 * They rely on the "ec_getaddress" function (in bip_load.c) 766 * ec_getaddress returns either the address of a C object or -1. 767 **************************************************************** 768 */ 769 770#if defined(HAVE_DLOPEN) || defined(HAVE_NLIST) || defined(_WIN32) 771 772/* 773 * external_(pred, function, module) 774 * b_external_(pred,function,module) 775 * 776 * pred: atom or atom/arity 777 * function: name of a C function ('_' added if needed) 778 * module: source module 779 */ 780 781static int 782_external(value vp, type tp, value vf, type tf, value vm, type tm, int nondet) 783{ 784 char *name; 785 dident wdid; 786 word c_address; 787 uint32 new_flags; 788 int err; 789 pri *pd; 790 791 Check_Module(tm, vm); 792 Get_Name(vf, tf, name); /* name of the c function */ 793 Error_If_Ref(tp); 794 if (IsAtom(tp)) 795 wdid = vp.did; 796 else 797 { 798 Get_Proc_Did(vp, tp, wdid); 799 } 800 801 c_address = ec_getaddress(name); 802 if (!c_address) 803 { 804 Bip_Error(NOCODE) 805 } 806 pd = local_procedure(wdid, vm.did, tm, PRI_CREATE); 807 if (!pd) 808 { 809 Get_Bip_Error(err); 810 Bip_Error(err); 811 } 812 new_flags = VMCODE|ARGFIXEDWAM|EXTERN|(GlobalFlags & DBGCOMP ? DEBUG_DB : 0); 813 err = pri_compatible_flags(pd, CODETYPE|ARGPASSING|EXTERN|DEBUG_DB, new_flags); 814 if (err != PSUCCEED) 815 { 816 Bip_Error(err); 817 } 818 pri_change_flags(pd, CODETYPE|ARGPASSING|EXTERN|DEBUG_DB, new_flags); 819 return b_built_code(pd, c_address, nondet); 820} 821 822static int 823p_external(value vp, type tp, value vf, type tf, value vm, type tm) 824{ 825 return _external(vp, tp, vf, tf, vm, tm, 0); 826} 827 828static int 829p_b_external(value vp, type tp, value vf, type tf, value vm, type tm) 830{ 831 return _external(vp, tp, vf, tf, vm, tm, 1); 832} 833 834 835static int 836p_external_body(value vpred, type tpred, value vmod, type tmod) 837{ 838 dident wdid; 839 pri *pd; 840 int err; 841 842 Check_Module(tmod, vmod); 843 Get_Proc_Did(vpred, tpred, wdid); 844 845 pd = visible_procedure(wdid, vmod.did, tmod, PRI_CREATE); 846 if (!pd) 847 { 848 Get_Bip_Error(err); 849 Bip_Error(err); 850 } 851 err = pri_compatible_flags(pd, CODETYPE|EXTERN, VMCODE|EXTERN); 852 if (err != PSUCCEED) 853 { 854 Bip_Error(err); 855 } 856 pri_init_code(pd, VMCODE); 857 pri_change_flags(pd, EXTERN, EXTERN); 858 Succeed_; 859} 860 861#else 862Not_Available_Built_In(p_external) 863Not_Available_Built_In(p_b_external) 864Not_Available_Built_In(p_external_body) 865#endif 866 867 868/* 869 * Lazily materialise call/n etc 870 */ 871 872static int 873p_create_call_n(value vn, type tn, value va, type ta) 874{ 875 Check_Atom(tn) 876 Check_Integer(ta) 877 return ec_create_call_n(add_dict(vn.did, va.nint)); 878} 879 880 881/* ******************************************************************** 882 DYNAMIC CODE 883 * ******************************************************************* */ 884 885 886/* How to get the source-record pointer from the code or pri */ 887#define DynCodeSrcHandle(code) ((pword *)((code)[2])) 888#define DynCodeSrcRecord(code) ((t_ext_ptr)ExternalData(DynCodeSrcHandle(code))) 889 890static vmcode * 891_init_dynamic1(pri *pd, t_ext_ptr source_record) 892{ 893 vmcode *code, *start; 894 pword *pw; 895 pri_code_t pricode; 896 897 Allocate_Default_Procedure((word) (4/*code*/ + 4/*anchor*/), PriDid(pd)); 898 pw = (pword *)(code + 4); 899 /* commented out 2008-04 -- does not seem to be needed 900 if ((uword)pw % sizeof(pword) != 0) 901 ec_panic("code block insufficiently aligned", "ec_make_dyn_proc()"); 902 */ 903 start = code; 904 905 Store_3(Call_dynamic, pd, pw) 906 Store_i(Code_end) 907 908 /* handle anchor for the source record */ 909 pw[0].val.ptr = (pword *) &heap_rec_header_tid; 910 pw[0].tag.kernel = TEXTERN; 911 pw[1].val.ptr = (pword *) source_record; 912 pw[1].tag.kernel = TPTR; 913 914 return start; 915} 916 917 918void 919ec_free_dyn_code(vmcode *code) 920{ 921 heap_rec_header_tid.free(DynCodeSrcRecord(code)); 922 reclaim_procedure(ProcHeader(code)); 923} 924 925 926void 927ec_mark_dids_dyn_code(vmcode *code) 928{ 929 heap_rec_header_tid.mark_dids(DynCodeSrcRecord(code)); 930} 931 932 933 934/* 935 is_dynamic/2 non standard 936 test whether a predicate (Name/Arity) is dynamic 937*/ 938static int 939p_is_dynamic(value v1, type t1, value v2, type t2, value vm, type tm) 940{ 941 dident wdid; 942 pri *procindex; 943 int err; 944 945 Check_Module(tm, vm); 946 Get_Did(v1, t1, v2, t2, wdid); 947 if (wdid == D_UNKNOWN) 948 { 949 Fail_; 950 } 951 procindex = visible_procedure(wdid, vm.did, tm, PRI_DONTWARN); 952 if (!procindex) 953 { 954 Get_Bip_Error(err); 955 Bip_Error(err); 956 } 957 Succeed_If(DynamicProc(procindex)); 958} 959 960/* 961 * is_built_in_/3 non standard 962 * test whether a predicate (Name/Arity) is a built_in 963 */ 964static int 965p_is_built_in(value val, type tag, value vm, type tm) 966{ 967 dident d; 968 pri *procindex; 969 int err; 970 971 Check_Module(tm, vm); 972 Get_Proc_Did(val, tag, d); 973 procindex = visible_procedure(d, vm.did, tm, PRI_DONTWARN); 974 if (!procindex) 975 { 976 Get_Bip_Error(err); 977 Bip_Error(err); 978 } 979 Succeed_If(procindex->flags & SYSTEM); 980} 981 982 983/* 984 * proc_flags(Name/Arity, Code, Value, Module, Private) 985 * Return the corresponding property of the procedure so that it 986 * can be processed in Prolog. System use only. 987 */ 988static int 989p_proc_flags(value vn, type tn, value vc, type tc, value vf, type tf, value vm, type tm, value vp, type tp) 990{ 991 dident wd; 992 uint32 flags; 993 pri *proc; 994 vmcode *code; 995 int source; 996 int err; 997 pword *s; 998 pword result; 999 type tt; 1000 uword brk_table_offset; 1001 uword brk_filter = 0; 1002 Prepare_Requests; 1003 1004#ifdef lint 1005 Check_Integer(tc); 1006#endif 1007 Check_Module(tm, vm); 1008 Get_Proc_Did(vn, tn, wd); 1009 tt.all = ModuleTag(vm.did); 1010 proc = visible_procedure(wd, vm.did, tt, PRI_DONTWARN); 1011 if (! proc) 1012 { 1013 Set_Bip_Error(0); 1014 Fail_; 1015 } 1016 flags = PriFlags(proc); 1017 if (PriScope(proc) == DEFAULT && !PriReferenced(proc)) 1018 { 1019 Set_Bip_Error(0); 1020 Fail_; 1021 } 1022 if (vc.nint == 7 || UnauthorizedAccess(vm.did, tm) && !PriExported(proc)) 1023 { 1024 Request_Unify_Atom(vp, tp, d_.local0) 1025 } else { 1026 Request_Unify_Atom(vp, tp, d_.global0) 1027 } 1028 1029 /* do we have information about the source? */ 1030 code = PriCode(proc); 1031 source = 1032 (!(proc->flags & EXTERN) 1033 && 1034 !DynamicProc(proc) 1035 && 1036 proc->flags & CODE_DEFINED 1037 && 1038 ProcFid(code) != D_UNKNOWN); 1039 1040 switch (vc.nint) 1041 { 1042 case 0: /* definition module */ 1043 if (proc->module_ref == D_UNKNOWN) { 1044 Fail_; 1045 } 1046 Request_Unify_Atom(vf, tf, proc->module_ref); 1047 break; 1048 1049 case 1: /* PriFlags */ 1050 Request_Unify_Integer(vf, tf, proc->flags); 1051 break; 1052 1053 case 2: /* statistics (obsolete) */ 1054 Fail_; 1055 1056 case 3: /* source file */ 1057 if (source) { 1058 Request_Unify_Atom(vf, tf, (dident) ProcFid(code)) 1059 } 1060 else { 1061 Fail_; 1062 } 1063 break; 1064 1065 case 4: /* source line */ 1066 /* line == 0 indicates no source line&offset information */ 1067 if (source && ProcLid(code)) { 1068 Request_Unify_Integer(vf, tf, ProcLid(code)); 1069 } 1070 else { 1071 Fail_; 1072 } 1073 break; 1074 1075 case 5: /* source offset */ 1076 /* line == 0 indicates no source line&offset information */ 1077 if (source && ProcLid(code)) { 1078 Request_Unify_Integer(vf, tf, ProcBid(code)); 1079 } 1080 else { 1081 Fail_; 1082 } 1083 break; 1084 1085 case 6: /* mode */ 1086 s = Gbl_Tg; 1087 if ((err = get_mode(PriMode(proc), wd)) < 0) { 1088 Bip_Error(err); 1089 } 1090 Request_Unify_Pw(vf, tf, s->val, s->tag); 1091 break; 1092 1093 case 7: /* code start */ 1094 Request_Unify_Integer(vf, tf, (word) code); 1095 break; 1096 1097 case 8: /* inlining predicate (goal macro) */ 1098 if (!proc->trans_function) { 1099 Fail_; 1100 } 1101 s = TG; 1102 Push_Struct_Frame(d_.quotient); 1103 Make_Atom(&s[1], add_dict(proc->trans_function, 0)); 1104 Make_Integer(&s[2], DidArity(proc->trans_function)); 1105 Request_Unify_Structure(vf, tf, s); 1106 break; 1107 1108 case 9: /* auxiliary */ 1109 Request_Unify_Atom(vf, tf, flags & PROC_AUXILIARY? d_.on: d_.off); 1110 break; 1111 case 10: /* call_type */ 1112 /* This flag should have more (and more appropriately named) values, 1113 * taking into account both the setting of CODETYPE and ARGPASSING. 1114 */ 1115 Request_Unify_Atom(vf, tf, (flags & ARGPASSING) == ARGFIXEDWAM ? d_.prolog: d_.external); 1116 break; 1117 case 11: /* debugged */ 1118 Request_Unify_Atom(vf, tf, flags & DEBUG_DB? d_.on: d_.off); 1119 break; 1120 case 12: /* declared */ 1121 Request_Unify_Atom(vf, tf, PriScope(proc)!=DEFAULT? d_.on: d_.off); 1122 break; 1123 case 13: /* autoload */ 1124 Request_Unify_Atom(vf, tf, flags & AUTOLOAD? d_.on: d_.off); 1125 break; 1126 case 14: /* defined */ 1127 Request_Unify_Atom(vf, tf, flags & CODE_DEFINED? d_.on: d_.off); 1128 break; 1129 case 15: /* leash */ 1130 Request_Unify_Atom(vf, tf, flags & DEBUG_TR? d_.stop: d_.notrace); 1131 break; 1132 case 16: /* deprecated */ 1133 Request_Unify_Atom(vf, tf, flags & PROC_DEPRECATED? d_.on: d_.off); 1134 break; 1135 case 17: /* skip */ 1136 Request_Unify_Atom(vf, tf, flags & DEBUG_SK? d_.on: d_.off); 1137 break; 1138 case 18: /* spy */ 1139 Request_Unify_Atom(vf, tf, flags & DEBUG_SP? d_.on: d_.off); 1140 break; 1141 case 19: /* start_tracing */ 1142 Request_Unify_Atom(vf, tf, flags & DEBUG_ST? d_.on: d_.off); 1143 break; 1144 case 20: /* stability */ 1145 Request_Unify_Atom(vf, tf, flags & PROC_DYNAMIC? d_dynamic_: d_static_); 1146 break; 1147 case 21: /* tool */ 1148 Request_Unify_Atom(vf, tf, flags & TOOL? d_.on: d_.off); 1149 break; 1150 case 22: /* type */ 1151 Request_Unify_Atom(vf, tf, flags & SYSTEM? d_.built_in: d_.user); 1152 break; 1153 case 23: /* visibility */ 1154 switch(PriScope(proc)) 1155 { 1156 case LOCAL: wd = d_.local0; break; 1157 case EXPORT: wd = d_exported_; break; 1158 case IMPORT: wd = d_imported_; break; 1159 case IMPEXP: wd = d_reexported_; break; 1160 default: Fail_; 1161 } 1162 Request_Unify_Atom(vf, tf, wd); 1163 break; 1164 case 24: /* priority */ 1165 Request_Unify_Integer(vf, tf, PriPriority(proc)); 1166 break; 1167 case 25: /* demon */ 1168 Request_Unify_Atom(vf, tf, flags & PROC_DEMON? d_.on: d_.off); 1169 break; 1170 case 26: /* parallel */ 1171 Request_Unify_Atom(vf, tf, flags & PROC_PARALLEL? d_.on: d_.off); 1172 break; 1173 case 27: /* invisible */ 1174 if (!(flags & DEBUG_INVISIBLE)) { 1175 Fail_; /* show flag only if set */ 1176 } 1177 Request_Unify_Atom(vf, tf, d_.on); 1178 break; 1179 case 28: /* code_type */ 1180 Request_Unify_Atom(vf, tf, flags & EXTERN ? d_.external: d_.prolog); 1181 break; 1182 1183 case 29: /* code_size */ 1184 if (PriCodeType(proc) != VMCODE) { 1185 Fail_; 1186 } 1187 Request_Unify_Integer(vf, tf, ProcCodeSize(code)); 1188 break; 1189 1190 case 30: /* break_lines */ 1191 brk_filter = BREAKPOINT; 1192 /* fall through */ 1193 1194 case 31: /* port_lines */ 1195 if (!(flags & DEBUG_DB) || PriCodeType(proc) != VMCODE) { 1196 Fail_; 1197 } 1198 s = &result; 1199 brk_table_offset = ProcBrkTableOffset(code); 1200 if (brk_table_offset) 1201 { 1202 for(code += brk_table_offset; *code; ++code) 1203 { 1204 if (((*(vmcode**)code)[0] & brk_filter) == brk_filter) 1205 { 1206 Make_List(s, TG); 1207 s = TG; 1208 Push_List_Frame(); 1209 Make_Struct(&s[0], TG); 1210 Push_Struct_Frame(d_.colon); 1211 /* this relies on the order of words from a break-port word as follows: 1212 break-port word, file path (dident), line (int) 1213 */ 1214 Make_Atom(&s[3], ((dident*)(*(vmcode**)code))[1]); /* file */ 1215 Make_Integer(&s[4], (*(vmcode**)code)[2]); /* line */ 1216 s = &s[1]; 1217 } 1218 } 1219 } 1220 Make_Nil(s); 1221 Request_Unify_Pw(vf, tf, result.val, result.tag); 1222 break; 1223 1224 case 32: /* port_calls */ 1225 if (!(flags & DEBUG_DB) || PriCodeType(proc) != VMCODE) { 1226 Fail_; 1227 } 1228 s = &result; 1229 brk_table_offset = ProcBrkTableOffset(code); 1230 if (brk_table_offset) 1231 { 1232 for(code += brk_table_offset; *code; ++code) 1233 { 1234 if (((*(vmcode**)code)[0] & brk_filter) == brk_filter) 1235 { 1236 dident lm; 1237 Make_List(s, TG); 1238 s = TG; 1239 Push_List_Frame(); 1240 Make_Struct(&s[0], TG); 1241 Push_Struct_Frame(d_.colon); 1242 /* this relies on the order of words from a break-port word as follows: 1243 Proc, break-port word 1244 */ 1245 /* module:name/arity */ 1246 lm = PriHomeModule((pri*)(*(vmcode**)code)[-1]); 1247 Make_Atom(&s[3], lm == D_UNKNOWN ? vm.did : lm); 1248 Make_Struct(&s[4], TG); 1249 Push_Struct_Frame(d_.quotient); 1250 Make_Atom(&s[6], add_dict(PriDid((pri*)(*(vmcode**)code)[-1]),0)); 1251 Make_Integer(&s[7], DidArity(PriDid((pri*)(*(vmcode**)code)[-1]))); 1252 s = &s[1]; 1253 } 1254 } 1255 } 1256 Make_Nil(s); 1257 Request_Unify_Pw(vf, tf, result.val, result.tag); 1258 break; 1259 1260 case 33: /* trace_meta */ 1261 Request_Unify_Atom(vf, tf, flags & DEBUG_TRMETA? d_.on: d_.off); 1262 break; 1263 1264 case 34: /* run_priority */ 1265 Request_Unify_Integer(vf, tf, PriRunPriority(proc)); 1266 break; 1267 1268 default: 1269 Bip_Error(RANGE_ERROR); 1270 } 1271 Return_Unify; 1272} 1273 1274/* 1275 * FUNCTION NAME: p_mode(pv, pt, mv, mt) 1276 * 1277 * PARAMETERS: -the mode declaration in the form pred(+, -, ?, ++, ...) 1278 * -module 1279 * 1280 * DESCRIPTION: The Prolog built-in predicate mode_/2, body of the 1281 * tool mode/1. 1282 * 1283 */ 1284static int 1285p_mode(value pv, type pt, value mv, type mt) 1286{ 1287 int arity, i, err, mode; 1288 uint32 mode_decl; 1289 pword *arg, *term, *pred; 1290 pri *proc; 1291 dident wd; 1292 pword pd; 1293 1294 1295 Check_Module(mt, mv); 1296 pd.val = pv; 1297 pd.tag = pt; 1298 pred = &pd; 1299 do 1300 { 1301 Error_If_Ref(pred->tag); 1302 if (IsStructure(pred->tag)) { 1303 pred = pred->val.ptr; 1304 wd = pred->val.did; 1305 pred++; 1306 } 1307 else if (IsList(pred->tag)) { 1308 wd = d_.list; 1309 pred = pred->val.ptr; 1310 } 1311 else if (IsAtom(pred->tag)) { 1312 wd = pred->val.did; 1313 pred = 0; 1314 } 1315 else { 1316 Bip_Error(TYPE_ERROR); 1317 } 1318 if (wd == d_.comma) 1319 { 1320 term = pred; 1321 pred++; 1322 Dereference_(term); 1323 Dereference_(pred); 1324 Error_If_Ref(term->tag); 1325 if (IsStructure(term->tag)) { 1326 term = term->val.ptr; 1327 wd = term->val.did; 1328 term++; 1329 } 1330 else if (IsList(term->tag)) { 1331 wd = d_.list; 1332 term = term->val.ptr; 1333 } 1334 else if (IsAtom(term->tag)) { 1335 wd = term->val.did; 1336 term = 0; 1337 } 1338 else { 1339 Bip_Error(TYPE_ERROR); 1340 } 1341 } 1342 else 1343 { 1344 term = pred; 1345 pred = 0; 1346 } 1347 proc = local_procedure(wd, mv.did, mt, PRI_CREATE); 1348 if (!proc) 1349 { 1350 Get_Bip_Error(err); 1351 Bip_Error(err); 1352 } 1353 arity = DidArity(wd); 1354 /* initialize with previous modes so that builtin bindings 1355 are not erased */ 1356 mode_decl = PriMode(proc); 1357 for (i = 1; i <= arity; i++) 1358 { 1359 arg = term++; 1360 Dereference_(arg); 1361 Check_Atom(arg->tag); 1362 if (arg->val.did == d_.plus0) 1363 mode = NONVAR; 1364 else if (arg->val.did == d_.plusplus) 1365 mode = GROUND; 1366 else if (arg->val.did == d_.minus0) 1367 mode = OUTPUT; 1368 else if (arg->val.did == d_.question) 1369 mode = ANY; 1370#ifdef EXTENDED_MODES 1371 else if (arg->val.did == d_plusminus) 1372 mode = NOALIAS_INST; 1373 else if (arg->val.did == d_minusplus) 1374 mode = NOALIAS; 1375#endif 1376 else 1377 { 1378 Bip_Error(RANGE_ERROR); 1379 } 1380 Set_Mode(i, mode_decl, mode); 1381 } 1382 err = pri_change_mode(proc, mode_decl); 1383 if (err != PSUCCEED) { Bip_Error(err); } 1384 } 1385 while (pred); 1386 Succeed_; 1387} 1388 1389 1390/*---------------------------------------------------------------------- 1391 * Builtins related to macros 1392 *----------------------------------------------------------------------*/ 1393 1394static int 1395_macro_options(value vprop, type tprop, int *pmtype, int *pflag) 1396{ 1397 *pmtype = TRANS_PROP; 1398 *pflag = 0; 1399 1400 if (IsRef(tprop)) /* we need at least one */ 1401 { 1402 Bip_Error(INSTANTIATION_FAULT); 1403 } 1404 else if (IsList(tprop)) 1405 { 1406 pword *pw; 1407 dident arg; 1408 pword *list = vprop.ptr; 1409 for(;;) /* loop through the list */ 1410 { 1411 pw = list++; 1412 Dereference_(pw); /* get the list element */ 1413 Check_Atom(pw->tag); 1414 arg = pw->val.did; 1415 if (arg == d_.top_only) 1416 *pflag |= TR_TOP; 1417 else if (arg == d_.protect_arg) 1418 *pflag |= TR_PROTECT; 1419 else if (arg == d_.clause0) { 1420 *pflag |= TR_CLAUSE; 1421 *pmtype = CLAUSE_TRANS_PROP; 1422 } 1423 else if (arg == d_.term) 1424 ; 1425 else if (arg == d_.goal) { 1426 *pflag |= TR_GOAL; 1427 *pmtype = GOAL_TRANS_PROP; 1428 } 1429 else if (arg == d_.write) 1430 *pflag |= TR_WRITE; 1431 else if (arg == d_.read) 1432 ; 1433 else if (arg == d_.global0) 1434 *pflag |= TR_GLOBAL; 1435 else if (arg == d_.local0) 1436 ; 1437 else 1438 { 1439 Bip_Error(RANGE_ERROR); 1440 } 1441 Dereference_(list); /* get the list tail */ 1442 if (IsRef(list->tag)) 1443 { 1444 Bip_Error(INSTANTIATION_FAULT); 1445 } 1446 else if (IsList(list->tag)) 1447 list = list->val.ptr; 1448 else if (IsNil(list->tag)) 1449 break; /* end of the list */ 1450 else 1451 { 1452 Bip_Error(TYPE_ERROR); 1453 } 1454 } 1455 } 1456 else if (!IsNil(tprop)) 1457 { 1458 Bip_Error(TYPE_ERROR); 1459 } 1460 if (*pflag & TR_WRITE) 1461 *pmtype += 1; 1462 Succeed_; 1463} 1464 1465 1466/* 1467 * Define a goal macro for a procedure proc 1468 * - proc must be defined in m 1469 * - if not, a local proc is created in m 1470 * - the transformation trans will later be looked up in 1471 * the definition module of proc 1472 */ 1473 1474static int 1475_define_goal_macro(dident proc_did, dident trans_did, value vm, type tm) 1476{ 1477 pri *proc_pri; 1478 int err; 1479 1480 if (!((2 <= DidArity(trans_did) && DidArity(trans_did) <= 5) 1481 || trans_did == d_unfold6_)) 1482 { 1483 Bip_Error(RANGE_ERROR); 1484 } 1485 1486 /* 1487 * First look up the predicate proc in module m 1488 1489 */ 1490 proc_pri = local_procedure(proc_did, vm.did, tm, PRI_CREATE); 1491 if (!proc_pri) 1492 { 1493 Get_Bip_Error(err); 1494 Bip_Error(err); 1495 } 1496 1497 /* 1498 * Setting to =/2 erases the goal macro 1499 */ 1500 if (trans_did == d_.unify) 1501 trans_did = D_UNKNOWN; 1502 1503 /* 1504 * set the transformation fields in all descriptors 1505 */ 1506 err = pri_change_trans_function(proc_pri, trans_did); 1507 if (err != PSUCCEED) { Bip_Error(err); } 1508 1509 /* this is needed to force the compiler to call the transformations */ 1510 if (trans_did != D_UNKNOWN) 1511 DidMacro(proc_pri->did) = 1; 1512 1513 Succeed_; 1514} 1515 1516static int 1517_erase_goal_macro(dident proc_did, value vm, type tm) 1518{ 1519 pri *proc_pri; 1520 1521 /* 1522 * First look up the predicate proc in module m 1523 */ 1524 proc_pri = local_procedure(proc_did, vm.did, tm, 0); 1525 if (!proc_pri) 1526 { 1527 int err; 1528 Get_Bip_Error(err); 1529 Bip_Error(err); 1530 } 1531 1532 /* 1533 * clear the transformation fields in all descriptors 1534 */ 1535 return pri_change_trans_function(proc_pri, D_UNKNOWN); 1536 1537 /* don't know whether we can clear the DidMacro flag */ 1538} 1539 1540 1541static int 1542p_define_macro(value vproc, type tproc, value vtrans, type ttrans, value vprop, type tprop, value vmod, type tmod) 1543{ 1544 dident dp, dt, lookup_module; 1545 int flag, mtype, err; 1546 pword *list; 1547 macro_desc *md; 1548 pword *prop; 1549 1550 Get_Macro_Did(vproc, tproc, dp) 1551 if (IsStructure(ttrans) && vtrans.ptr[0].val.did == d_.colon) 1552 { 1553 pword *pw = &vtrans.ptr[1]; 1554 Dereference_(pw); 1555 Check_Atom(pw->tag); 1556 lookup_module = pw->val.did; 1557 pw = &vtrans.ptr[2]; 1558 Dereference_(pw); 1559 vtrans.all = pw->val.all; 1560 ttrans.all = pw->tag.all; 1561 } 1562 else 1563 { 1564 lookup_module = vmod.did; 1565 } 1566 Get_Proc_Did(vtrans, ttrans, dt) 1567 err = _macro_options(vprop, tprop, &mtype, &flag); 1568 if (err != PSUCCEED) 1569 { 1570 Bip_Error(err); 1571 } 1572 1573 /* multiple combinations not allowed */ 1574 if ((flag & (TR_GOAL|TR_CLAUSE)) == (TR_GOAL|TR_CLAUSE)) { 1575 Bip_Error(RANGE_ERROR); 1576 } 1577 /* write macros currently compatible with top_only, goal and protect */ 1578 if ((flag & TR_WRITE) && 1579 (flag & ~(TR_GLOBAL|TR_TOP|TR_GOAL|TR_CLAUSE|TR_WRITE|TR_PROTECT))) 1580 { 1581 Bip_Error(RANGE_ERROR); 1582 } 1583 if ((flag & (TR_GOAL|TR_WRITE)) == TR_GOAL) 1584 { 1585 if (flag & TR_GLOBAL) 1586 { 1587 Bip_Error(RANGE_ERROR); 1588 } 1589 /* goal macros are treated specially */ 1590 return _define_goal_macro(dp, dt, vmod, tmod); 1591 } 1592 else 1593 { 1594 if (DidArity(dt) < 2 || DidArity(dt) > 5) 1595 { 1596 Bip_Error(RANGE_ERROR); 1597 } 1598 /* we define the source transformation */ 1599 prop = set_modular_property(dp, mtype, 1600 vmod.did, tmod, 1601 flag & TR_GLOBAL ? GLOBAL_PROP : LOCAL_PROP, &err); 1602 if (prop == (pword *) NULL) 1603 { 1604 if (err != PERROR) 1605 { 1606 Bip_Error(err); 1607 } 1608 if (flag & TR_GLOBAL) 1609 { 1610 Bip_Error(GLOBAL_TR_EXISTS); 1611 } 1612 else 1613 { 1614 Bip_Error(TR_IN_MOD); 1615 } 1616 } 1617 DidMacro(dp) = 1; 1618 md = (macro_desc *) hg_alloc(sizeof(macro_desc)); 1619 prop->tag.kernel = TPTR; 1620 prop->val.ptr = (pword *) md; 1621 1622 md->trans_function = dt; 1623 md->module = lookup_module; 1624 md->flags = flag; 1625 } 1626 1627 Succeed_; 1628} 1629 1630 1631static int 1632p_erase_macro (value vproc, type tproc, value vmod, type tmod) 1633{ 1634 dident dp; 1635 int i; 1636 int err1, err2 = NO_TR, rem = 1; 1637 1638 Get_Macro_Did(vproc, tproc, dp); 1639 1640 /* If all return PFAIL or PERROR, the macro bit can be cleared */ 1641 for (i = TRANS_PROP; i <= WRITE_CLAUSE_TRANS_PROP; i++) { 1642 err1 = erase_modular_property(dp, i, vmod.did, tmod, VISIBLE_PROP); 1643 if (err1 == PSUCCEED) { 1644 err2 = PSUCCEED; 1645 rem = 0; 1646 } 1647 else if (err1 >= PERROR) { 1648 err2 = PSUCCEED; 1649 } 1650 else { 1651 Bip_Error(err1) 1652 } 1653 } 1654 /* this is no longer possible because the DidMacro bit indicates also 1655 * the presence of goal transformations in the procedure descriptors 1656 if (rem) 1657 DidMacro(dp) = 0; 1658 */ 1659 Bip_Error(err2); 1660} 1661 1662static int 1663p_erase_macro3(value vproc, type tproc, value vprop, type tprop, value vmod, type tmod) 1664{ 1665 dident wdid; 1666 int propid, flag, err; 1667 1668 Get_Macro_Did(vproc, tproc, wdid); 1669 err = _macro_options(vprop, tprop, &propid, &flag); 1670 if (err != PSUCCEED) 1671 { 1672 Bip_Error(err); 1673 } 1674 1675 if ((flag & (TR_GOAL|TR_WRITE)) == TR_GOAL) 1676 { 1677 return _erase_goal_macro(wdid, vmod, tmod); 1678 } 1679 else /* erase the property */ 1680 { 1681 err = erase_modular_property(wdid, propid, vmod.did, tmod, 1682 flag & TR_GLOBAL ? GLOBAL_PROP : LOCAL_PROP); 1683 if (err < PERROR) { 1684 Bip_Error(err) 1685 } 1686 /* don't know whether we can clear the DidMacro flag here */ 1687 } 1688 Succeed_; 1689} 1690 1691 1692static int 1693_type_did(pword *pw, dident *pd) 1694{ 1695 int i; 1696 Dereference_(pw); 1697 Check_Atom_Or_Nil(pw->val, pw->tag); 1698 for (i=0; i<= NTYPES; i++) 1699 { 1700 if (i != TPTR && pw->val.did == tag_desc[i].type_name) { 1701 *pd = TransfDid(i); 1702 Succeed_; 1703 } 1704 } 1705 Bip_Error(RANGE_ERROR); 1706} 1707 1708/* Check the arguments of current_macro_body/5 1709 illegal_macro(Functor, Pred, List, PredModule, Error) 1710 */ 1711/*ARGSUSED*/ 1712static int 1713p_illegal_macro(value v1, type t1, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5) 1714{ 1715/* 1 */ 1716 if (IsStructure(t1) && v1.ptr->val.did == d_.quotient) 1717 { 1718 pword *pw; 1719 1720 pw = v1.ptr + 1; 1721 Dereference_(pw) 1722 if (!IsRef(pw->tag) && !IsAtom(pw->tag)) { 1723 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1724 } 1725 pw = v1.ptr + 2; 1726 Dereference_(pw) 1727 if (!IsRef(pw->tag) && !IsInteger(pw->tag)) { 1728 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1729 } 1730 } 1731 else if (IsStructure(t1) && v1.ptr->val.did == d_type_) 1732 { 1733 pword *pw; 1734 1735 pw = v1.ptr + 1; 1736 Dereference_(pw) 1737 if (!IsRef(pw->tag) && !IsAtom(pw->tag) && !IsNil(pw->tag)) { 1738 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1739 } 1740 } 1741 else if (!IsRef(t1)) { 1742 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1743 } 1744/* 2 */ 1745 if (IsStructure(t2) && v2.ptr->val.did == d_.quotient) 1746 { 1747 pword *pw; 1748 1749 pw = v2.ptr + 1; 1750 Dereference_(pw) 1751 if (!IsRef(pw->tag) && !IsAtom(pw->tag)) { 1752 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1753 } 1754 pw = v2.ptr + 2; 1755 Dereference_(pw) 1756 if (!IsRef(pw->tag) && !IsInteger(pw->tag)) { 1757 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1758 } 1759 } 1760 else if (!IsRef(t2)) { 1761 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1762 } 1763/* 3 */ 1764 if (!IsRef(t3) && !IsList(t3) && !IsNil(t3)) { 1765 Return_Unify_Integer(v5, t5, -(TYPE_ERROR)) 1766 } 1767/* 4 */ 1768 if (!IsRef(t4)) { 1769 if (!IsAtom(t4) || !IsModule(v4.did)) { 1770 Return_Unify_Integer(v5, t5, -(MODULENAME)) 1771 } 1772 } 1773 Fail_; 1774} 1775 1776 1777/* 1778 * Macro lookup function, two variants: 1779 * 1780 * is_macro(+Functor, -Pred, -OptionList, -PredModule, +Module, +Type) 1781 * Functor is N/A or type(T), specifying which macro to look up. 1782 * 1783 * visible_term_macro(+Term, -Pred, -OptionList, -PredModule, +Module, +Type) 1784 * Term is arbitrary term, for which we try to find a macro. 1785 * 1786 * Type is an integer specifying the property type, see property.h 1787 */ 1788 1789static int 1790_is_macro(dident wdid, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5, value v6, type t6) 1791{ 1792 pword *pwd; 1793 pword *p; 1794 macro_desc *md; 1795 dident trans_lookup_mod; 1796 pri *proc; 1797 type tmod; 1798 int err; 1799 int flags; 1800 Prepare_Requests; 1801 1802 Check_Integer(t6); 1803 pwd = get_modular_property(wdid, v6.nint, v5.did, t5, VISIBLE_PROP, &err); 1804 if (!pwd) { 1805 if (err != PERROR) { 1806 Bip_Error(err) 1807 } 1808 Fail_; 1809 } 1810 1811 md = (macro_desc *) pwd->val.ptr; 1812 pwd = Gbl_Tg; 1813 Gbl_Tg += 3; 1814 Check_Gc; 1815 pwd[0].val.did = d_.quotient; 1816 pwd[0].tag.kernel = TDICT; 1817 pwd[1].val.did = add_dict(md->trans_function, 0); 1818 pwd[1].tag.kernel = TDICT; 1819 pwd[2].val.nint = DidArity(md->trans_function); 1820 pwd[2].tag.kernel = TINT; 1821 Request_Unify_Structure(v2, t2, pwd); 1822 1823 /* find trans_function's definition module (needed for qualified call) */ 1824 tmod.all = ModuleTag(md->module); 1825 proc = visible_procedure(md->trans_function, md->module, tmod, PRI_DONTWARN); 1826 if (!proc || PriScope(proc) == DEFAULT) 1827 { 1828 Set_Bip_Error(0); 1829 Request_Unify_Atom(v4, t4, md->module); 1830 } 1831 else 1832 { 1833 Request_Unify_Atom(v4, t4, proc->module_ref); 1834 } 1835 1836 /* build an option list from the flags */ 1837 flags = md->flags; 1838 pwd = Gbl_Tg; 1839 1840 p = Gbl_Tg; 1841 Gbl_Tg += 2; 1842 p[0].val.did = flags & TR_GLOBAL ? d_.global0 : d_.local0; 1843 p[0].tag.kernel = TDICT; 1844 p[1].val.ptr = Gbl_Tg; 1845 p[1].tag.kernel = TLIST; 1846 1847 if (flags & TR_PROTECT) { 1848 p = Gbl_Tg; 1849 Gbl_Tg += 2; 1850 p[0].val.did = d_.protect_arg; 1851 p[0].tag.kernel = TDICT; 1852 p[1].val.ptr = Gbl_Tg; 1853 p[1].tag.kernel = TLIST; 1854 } 1855 if (flags & TR_TOP) { 1856 p = Gbl_Tg; 1857 Gbl_Tg += 2; 1858 p[0].val.did = d_.top_only; 1859 p[0].tag.kernel = TDICT; 1860 p[1].val.ptr = Gbl_Tg; 1861 p[1].tag.kernel = TLIST; 1862 } 1863 if (flags & TR_WRITE) { 1864 p = Gbl_Tg; 1865 Gbl_Tg += 2; 1866 p[0].val.did = d_.write; 1867 p[0].tag.kernel = TDICT; 1868 p[1].val.ptr = Gbl_Tg; 1869 p[1].tag.kernel = TLIST; 1870 } 1871 if (flags & TR_CLAUSE) { 1872 p = Gbl_Tg; 1873 Gbl_Tg += 2; 1874 p[0].val.did = d_.clause0; 1875 p[0].tag.kernel = TDICT; 1876 p[1].val.ptr = Gbl_Tg; 1877 p[1].tag.kernel = TLIST; 1878 } 1879 if (flags & TR_GOAL) { 1880 p = Gbl_Tg; 1881 Gbl_Tg += 2; 1882 p[0].val.did = d_.goal; 1883 p[0].tag.kernel = TDICT; 1884 p[1].val.ptr = Gbl_Tg; 1885 p[1].tag.kernel = TLIST; 1886 } 1887 p[1].tag.kernel = TNIL; 1888 Check_Gc; 1889 Request_Unify_List(v3, t3, pwd); 1890 Return_Unify; 1891} 1892 1893/*ARGSUSED*/ 1894static int 1895p_is_macro(value v1, type t1, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5, value v6, type t6) 1896{ 1897 dident wdid; 1898 Get_Macro_Did(v1, t1, wdid); 1899 return _is_macro(wdid, v2, t2, v3, t3, v4, t4, v5, t5, v6, t6); 1900} 1901 1902static int 1903p_visible_term_macro(value v1, type t1, value v2, type t2, value v3, type t3, value v4, type t4, value v5, type t5, value v6, type t6) 1904{ 1905 int res; 1906 dident wdid; 1907 1908 /* first look for a functor-specific macro */ 1909 switch (TagType(t1)) { 1910 case TDICT: wdid = v1.did; break; 1911 case TNIL: wdid = d_.nil; break; 1912 case TLIST: wdid = d_.list; break; 1913 case TCOMP: wdid = v1.ptr->val.did; break; 1914 default: wdid = D_UNKNOWN; 1915 } 1916 if (wdid != D_UNKNOWN) 1917 { 1918 res = _is_macro(wdid, v2, t2, v3, t3, v4, t4, v5, t5, v6, t6); 1919 if (res != PFAIL) 1920 return res; /* PSUCCEED or error */ 1921 } 1922 1923 /* if none, look for a type macro */ 1924 return _is_macro(TransfDid(t1.kernel), v2, t2, v3, t3, v4, t4, v5, t5, v6, t6); 1925} 1926 1927 1928/* 1929 * visible_goal_macro(+Goal, -TransPred, -TransLookupMod, +LookupMod) 1930 * 1931 * Lookup a goal macro (inine transformation) for Goal. If there is none, fail. 1932 */ 1933 1934static int 1935p_visible_goal_macro(value vgoal, type tgoal, value vtrans, type ttrans, value vtlm, type ttlm, value vlm, type tlm) 1936{ 1937 1938 dident proc_did; 1939 pri *proc_pri; 1940 pword *pw; 1941 Prepare_Requests; 1942 1943 switch (TagType(tgoal)) { 1944 case TDICT: proc_did = vgoal.did; break; 1945 case TNIL: proc_did = d_.nil; break; 1946 case TLIST: proc_did = d_.list; break; 1947 case TCOMP: proc_did = vgoal.ptr->val.did; break; 1948 default: Fail_; 1949 } 1950 1951 /* 1952 * Check whether there is a visible procedure with a transformation. 1953 */ 1954 if (!DidMacro(proc_did) || !IsAtom(tlm) || !IsModule(vlm.did) /*this can happen!*/) { 1955 Fail_; 1956 } 1957 proc_pri = visible_procedure(proc_did, vlm.did, tlm, 0); 1958 if (!proc_pri) { 1959 Set_Bip_Error(0); /* reset error code from visible_procedure() */ 1960 Fail_; 1961 } 1962 if (!proc_pri->trans_function) { 1963 Fail_; 1964 } 1965 1966 /* 1967 * We treat the transformation like a call to the predicate itself. 1968 * That may help to detect errors due to later redefinition. 1969 */ 1970 Pri_Set_Reference(proc_pri); 1971 1972 /* 1973 * Return transformation functor and lookup module 1974 */ 1975 pw = TG; 1976 Push_Struct_Frame(d_.quotient); 1977 Make_Atom(&pw[1], add_dict(proc_pri->trans_function, 0)); 1978 Make_Integer(&pw[2], DidArity(proc_pri->trans_function)); 1979 Request_Unify_Structure(vtrans, ttrans, pw); 1980 Request_Unify_Atom(vtlm, ttlm, proc_pri->module_ref); 1981 Return_Unify; 1982} 1983 1984 1985/* The following builtins use the global error variable ! */ 1986#undef Bip_Error 1987#define Bip_Error(N) Bip_Error_Fail(N) 1988 1989 1990 1991/* 1992 * dynamic_create_(+Name, +Arity, +SrcHandle, +Module) 1993 * create a dynamic predicate Name/Arity, whose source is stored in SrcHandle 1994 * fails on error with bip_error 1995 */ 1996 1997static int 1998p_dynamic_create(value v1, type t1, value v2, type t2, value vm, type tm) 1999{ 2000 dident wdid; 2001 pri *proc; 2002 int ndebug; /* current dbg mode */ 2003 int err; 2004 pri_code_t pricode; 2005 extern t_ext_ptr ec_record_create(void); 2006 2007 Check_Module(tm, vm); 2008 Add_Did(v1, t1, v2, t2, wdid); 2009 if (DidArity(wdid) < 0 || DidArity(wdid) > MAXARITY) 2010 { 2011 Bip_Error(RANGE_ERROR) 2012 } 2013 ndebug = (GlobalFlags & DBGCOMP) ? 0 : DEBUG_DB; 2014 2015 a_mutex_lock(&ProcedureLock); 2016 proc = local_procedure(wdid, vm.did, tm, PRI_CREATE); 2017 if (!proc) 2018 { 2019 a_mutex_unlock(&ProcedureLock); 2020 Get_Bip_Error(err); 2021 Bip_Error(err); 2022 } 2023 /* we redefine a procedure defined in the module */ 2024 if (DynamicProc(proc)) 2025 { 2026 a_mutex_unlock(&ProcedureLock); 2027 Bip_Error(ALREADY_DYNAMIC); 2028 } 2029 if (proc->flags & CODE_DEFINED) 2030 { 2031 a_mutex_unlock(&ProcedureLock); 2032 Bip_Error(ALREADY_DEFINED); 2033 } 2034 err = pri_compatible_flags(proc, ARGPASSING|PROC_DYNAMIC|EXTERN|TOOL|PROC_PARALLEL|DEBUG_DB, ARGFIXEDWAM|PROC_DYNAMIC|ndebug); 2035 if (err != PSUCCEED) 2036 { 2037 a_mutex_unlock(&ProcedureLock); 2038 Bip_Error(err); 2039 } 2040 pri_change_flags(proc, ARGPASSING|PROC_DYNAMIC|EXTERN|TOOL|PROC_PARALLEL|DEBUG_DB, ARGFIXEDWAM|PROC_DYNAMIC|ndebug); 2041 pricode.vmc = _init_dynamic1(proc, ec_record_create()); 2042 pri_define_code(proc, VMCODE, pricode); 2043 a_mutex_unlock(&ProcedureLock); 2044 Succeed_; 2045} 2046 2047 2048/* 2049 * dynamic_source_(+Name, +Arity, -SrcHandle, +Module) 2050 * retrieve the record handle under which the source is stored 2051 */ 2052 2053static int 2054p_dynamic_source(value v1, type t1, value v2, type t2, value vsrc, type tsrc, value vm, type tm) 2055{ 2056 dident wdid; 2057 pri *proc; 2058 pword ref_pw; 2059 2060 Check_Module(tm, vm); 2061 Add_Did(v1, t1, v2, t2, wdid); 2062 proc = visible_procedure(wdid, vm.did, tm, 0); 2063 if (!proc) { 2064 int err; 2065 Get_Bip_Error(err); 2066 if (err == NOENTRY) 2067 err = ACCESSING_UNDEF_DYN_PROC; 2068 Bip_Error(err); 2069 } 2070 if (PriScope(proc) != DEFAULT && PriModule(proc) != PriHomeModule(proc)) 2071 { 2072 Bip_Error(ACCESSING_NON_LOCAL); 2073 } 2074 if (!DynamicProc(proc)) 2075 { 2076 if (PriFlags(proc) & CODE_DEFINED) 2077 { 2078 Bip_Error(NOT_DYNAMIC); 2079 } 2080 else 2081 { 2082 Bip_Error(ACCESSING_UNDEF_DYN_PROC); 2083 } 2084 } 2085 2086 /* Create a THANDLE pointer to the anchor inside the code block 2087 * (taken from the 2nd * parameter of the [Call_dynamic proc handle] 2088 * instruction). This is only legal if it is guaranteed that the 2089 * pointer does not live longer than the code block (otherwise we 2090 * have to use ec_handle() to create a global stack anchor. 2091 */ 2092 2093 ref_pw.val.ptr = DynCodeSrcHandle(PriCode(proc)); 2094 ref_pw.tag.kernel = THANDLE; 2095 Return_Unify_Pw(vsrc, tsrc, ref_pw.val, ref_pw.tag); 2096} 2097 2098 2099/* 2100 abolish_(Name, Arity, Module) 2101 Remove a predicate from the procedure table if the predicate 2102 is at least declared. 2103 Error checking MUST already have been done (with p_check_abolish). 2104 Reports error INCONSISTENCY by failing (use get_bip_error()). 2105*/ 2106/*ARGSUSED*/ 2107static int 2108p_abolish(value n, type tn, value a, type ta, value vm, type tm) 2109{ 2110 dident d; 2111 pri *proc, *global; 2112 int err; 2113 2114 Check_Integer(ta); 2115 Check_Atom(tn); 2116 Check_Module(tm, vm); 2117 if(a.nint < 0) 2118 { 2119 Bip_Error(RANGE_ERROR); 2120 } 2121 d = check_did(n.did, (int) a.nint); 2122 if (d == D_UNKNOWN) 2123 { 2124 Bip_Error(NOENTRY); 2125 } 2126 a_mutex_lock(&ProcedureLock); 2127 proc = local_procedure(d, vm.did, tm, 0); 2128 if (!proc) 2129 { 2130 a_mutex_unlock(&ProcedureLock); 2131 Get_Bip_Error(err); 2132 Bip_Error(err); 2133 } 2134 pri_abolish(proc); 2135 a_mutex_unlock(&ProcedureLock); 2136 Succeed_; 2137} 2138 2139/* 2140 * set_proc_flags(Name/Arity, Flag, Value, Module) 2141 * set the specified flag of the procedure 2142 * fail when error (get_bip_error/1 may then returns NOENTRY if 2143 * functor/arity is not a defined procedure or LOCKED if 2144 * module is locked, RANGE_ERROR if wrong flags or flags value. 2145 * Type checking is made on the modules and flags. 2146 */ 2147static int 2148p_set_proc_flags(value vproc, type tproc, value vf, type tf, value vv, type tv, value vm, type tm) 2149{ 2150 uint32 new_flags = 0, changed_flags = 0; 2151 dident wdid; 2152 pri *proc; 2153 int err; 2154 int use_local_procedure = 0; 2155 int change_code_block = 0; 2156 2157 Check_Module(tm, vm); 2158 Get_Proc_Did(vproc, tproc, wdid); 2159 Check_Atom(tf); 2160 2161 if (vf.did == d_.leash) 2162 { 2163 Check_Atom(tv); 2164 changed_flags = DEBUG_TR; 2165 if (vv.did == d_.stop) 2166 new_flags = DEBUG_TR; 2167 else if (vv.did == d_.print) 2168 new_flags = DEBUG_TR; 2169 else if (vv.did == d_.notrace) 2170 new_flags = 0; 2171 else 2172 { 2173 Bip_Error(RANGE_ERROR); 2174 } 2175 } 2176 else if (vf.did == d_.priority) 2177 { 2178 Check_Integer(tv); 2179 if (vv.nint < 1 || vv.nint > SUSP_MAX_PRIO) 2180 { 2181 Bip_Error(RANGE_ERROR); 2182 } 2183 /* we allow changing from anywhere (useful?) */ 2184 } 2185 else if (vf.did == d_run_priority_) 2186 { 2187 Check_Integer(tv); 2188 if (vv.nint < 1 || vv.nint > SUSP_MAX_PRIO) 2189 { 2190 Bip_Error(RANGE_ERROR); 2191 } 2192 /* only changeable from definition module */ 2193 use_local_procedure = 1; 2194 } 2195 else if (vf.did == d_.spy) 2196 { 2197 Check_Atom(tv); 2198 if (vv.did == d_.on) { 2199 changed_flags = new_flags = DEBUG_SP|DEBUG_TR; 2200 } else if (vv.did == d_.off) { 2201 changed_flags = DEBUG_SP; 2202 new_flags = 0; 2203 } else { 2204 Bip_Error(RANGE_ERROR); 2205 } 2206 } 2207 else if (vf.did == d_type0_) /* set the system-flag */ 2208 { 2209 Check_Atom(tv) 2210 if (vv.did != d_.built_in) { 2211 Bip_Error(RANGE_ERROR); 2212 } 2213 use_local_procedure = 1; 2214 changed_flags = new_flags = SYSTEM; 2215 } 2216 else if (vf.did == d_source_file_) 2217 { 2218 Check_Atom(tv) 2219 use_local_procedure = 1; 2220 change_code_block = 1; 2221 } 2222 else if (vf.did == d_source_line_ || vf.did == d_source_offset_) 2223 { 2224 Check_Integer(tv) 2225 if (vv.nint < 0) 2226 { 2227 Bip_Error(RANGE_ERROR); 2228 } 2229 use_local_procedure = 1; 2230 change_code_block = 1; 2231 } 2232 else if (vf.did == d_.break0) 2233 { 2234 Check_Integer(tv); 2235 if (vv.nint < 0) 2236 { 2237 Bip_Error(RANGE_ERROR); 2238 } 2239 change_code_block = 1; 2240 } 2241 else 2242 { 2243 /* 2244 * all the others are simple on/off flags 2245 */ 2246 Check_Atom(tv); 2247 if (vf.did == d_.skip) { 2248 changed_flags = DEBUG_SK; 2249 } else if (vf.did == d_start_tracing_) { 2250 changed_flags = DEBUG_ST; 2251 } else if (vf.did == d_.system) { 2252 changed_flags = SYSTEM; 2253 use_local_procedure = 1; 2254 } else if (vf.did == d_invisible_) { 2255 changed_flags = DEBUG_INVISIBLE; 2256 use_local_procedure = 1; 2257 } else if (vf.did == d_.debug) { 2258 changed_flags = DEBUG_DB; 2259 use_local_procedure = 1; 2260 } else if (vf.did == d_trace_meta_) { 2261 changed_flags = DEBUG_TRMETA; 2262 use_local_procedure = 1; 2263 } else if (vf.did == d_autoload_) { 2264 changed_flags = AUTOLOAD; 2265 use_local_procedure = 1; 2266 } else if (vf.did == d_auxiliary_) { 2267 changed_flags = PROC_AUXILIARY; 2268 use_local_procedure = 1; 2269 } else if (vf.did == d_parallel_) { 2270 changed_flags = PROC_PARALLEL; 2271 use_local_procedure = 1; 2272 } else if (vf.did == d_demon_) { 2273 changed_flags = PROC_DEMON; 2274 use_local_procedure = 1; 2275 } else if (vf.did == d_deprecated_) { 2276 changed_flags = PROC_DEPRECATED; 2277 use_local_procedure = 1; 2278 } 2279 else 2280 { 2281 Bip_Error(RANGE_ERROR); 2282 } 2283 if (vv.did == d_.on) 2284 new_flags = changed_flags; 2285 else if (vv.did == d_.off) 2286 new_flags = 0; 2287 else 2288 { 2289 Bip_Error(RANGE_ERROR); 2290 } 2291 } 2292 2293 /* 2294 * Now get the procedure descriptor that needs to be changed 2295 */ 2296 a_mutex_lock(&ProcedureLock); 2297 proc = visible_procedure(wdid, vm.did, tm, 0); 2298 if (!proc) 2299 { 2300 Get_Bip_Error(err); 2301 goto _unlock_return_err_; 2302 } 2303 2304 if (proc->module_ref != vm.did) 2305 { 2306 /* Some flags should only be changeable from the 2307 * procedure's definition module */ 2308 if (use_local_procedure) 2309 { 2310 err = ACCESSING_NON_LOCAL; 2311 goto _unlock_return_err_; 2312 } 2313 /* Try to get the definition module descriptor */ 2314 proc = pri_home(proc); 2315 if (!proc) 2316 { 2317 Get_Bip_Error(err); 2318 goto _unlock_return_err_; 2319 } 2320 } 2321 2322 if (changed_flags) 2323 { 2324 /* 2325 * Some additional restrictions on flag changes 2326 */ 2327 if (DynamicProc(proc) && (new_flags & PROC_PARALLEL)) 2328 { 2329 err = ALREADY_DYNAMIC; 2330 goto _unlock_return_err_; 2331 } 2332 /* disallow clearing skip-flag in locked modules */ 2333 if ((DEBUG_SK & PriFlags(proc) & changed_flags & ~new_flags) 2334 && IsLocked(proc->module_def) 2335 && (proc->module_def != vm.did || !IsModuleTag(vm.did,tm))) 2336 { 2337 err = LOCKED; 2338 goto _unlock_return_err_; 2339 } 2340 err = pri_compatible_flags(proc, changed_flags, new_flags); 2341 if (err != PSUCCEED) 2342 goto _unlock_return_err_; 2343 2344 pri_change_flags(proc, changed_flags, new_flags); 2345 } 2346 else if (change_code_block) 2347 { 2348 /* changing information stored in code header or breakport */ 2349 if (!(PriFlags(proc) & CODE_DEFINED)) 2350 { 2351 err = NOENTRY; 2352 goto _unlock_return_err_; 2353 } 2354 if (vf.did == d_source_file_) 2355 { 2356 ProcFid(PriCode(proc)) = vv.did; 2357 } 2358 else if (vf.did == d_source_line_) 2359 { 2360 ProcLid(PriCode(proc)) = vv.nint; 2361 } 2362 else if (vf.did == d_source_offset_) 2363 { 2364 ProcBid(PriCode(proc)) = vv.nint; 2365 } 2366 else if (vf.did == d_.break0) 2367 {/* toggle the breakpoint flag of the port word in a debug_scall, pointed to by 2368 the port table */ 2369 vmcode * code; 2370 uword offset; 2371 char found = 0; 2372 2373 code = PriCode(proc); 2374 offset = ProcBrkTableOffset(code); 2375 if (offset == 0) 2376 { 2377 err = RANGE_ERROR; 2378 goto _unlock_return_err_; 2379 } 2380 code += ProcBrkTableOffset(code); 2381 while (*code != 0) 2382 { 2383 /* this relies on the order of words from a break-port word as follows: 2384 break-port word, file path (dident), line (int) 2385 */ 2386 if (*(((vmcode *)(*code))+2)/* breakport line */ == vv.nint) 2387 { 2388 **((vmcode **)code) ^= BREAKPOINT; 2389 found = 1; 2390 } 2391 code++; 2392 } 2393 if (found == 0) /* no match found */ 2394 { 2395 err = RANGE_ERROR; 2396 goto _unlock_return_err_; 2397 } 2398 } 2399 } 2400 else if (vf.did == d_.priority) 2401 { 2402 pri_change_prio(proc, vv.nint); 2403 } 2404 else if (vf.did == d_run_priority_) 2405 { 2406 pri_change_run_prio(proc, vv.nint); 2407 } 2408 else /* should not happen */ 2409 { 2410 err = RANGE_ERROR; 2411 goto _unlock_return_err_; 2412 } 2413 2414 a_mutex_unlock(&ProcedureLock); 2415 Succeed_; 2416 2417_unlock_return_err_: 2418 a_mutex_unlock(&ProcedureLock); 2419 Set_Bip_Error(err); 2420 Fail_; 2421} 2422 2423#undef Bip_Error 2424#define Bip_Error(err) return(err); 2425 2426/* 2427 * store_pred(+PredSpec, +CodeListOrArray, +Size, +BTablePos, +FlagBits, +File, +Line, +Offset, +Module) 2428 * 2429 * Create the predicate PredSpec with the VM-code specified in CodeList. 2430 * Size is the code size in units of vmcode. BTable is the offset to the start of the 2431 * port/break table, which are addresses to the port words in the predicate for setting 2432 * breakpoints (=0 if no table). File, Line and Offset gives source information: 2433 * the source file path (atom), the first line for the predicate, and the offset in 2434 * bytes to the predicate. These should all be set to 0 if there is no source info 2435 */ 2436 2437 2438#define Store_Ref(pw1, base) \ 2439 if (IsInteger(pw1->tag)) \ 2440 { \ 2441 Store_d(base + pw1->val.nint) \ 2442 } \ 2443 else \ 2444 { \ 2445 Check_Atom(pw1->tag); \ 2446 if (pw1->val.did == d_.fail) \ 2447 { \ 2448 Store_d(&fail_code_[0]); \ 2449 } \ 2450 else if (pw1->val.did == d_par_fail) \ 2451 { \ 2452 Store_d(&par_fail_code_[0]); \ 2453 } \ 2454 else \ 2455 { \ 2456 Bip_Error(RANGE_ERROR); \ 2457 } \ 2458 } 2459 2460 2461#ifdef DONT_USE_GROUND_CONSTANT_TABLE 2462/* auxiliary function to give all DIDs in a ground term the stability setting */ 2463 2464static int 2465_set_did_stability( 2466 value v, type t, /* expects a dereferenced argument */ 2467 int stability) 2468{ 2469 int arity; 2470 pword *arg_i; 2471 2472 for (;;) 2473 { 2474 if (IsRef(t)) 2475 return INSTANTIATION_FAULT; 2476 else if (IsAtom(t)) 2477 { 2478 Set_Did_Stability(v.did, stability); 2479 return PSUCCEED; 2480 } 2481 else if (IsString(t) && StringInDictionary(v)) 2482 { 2483 dident a = check_did_n(StringStart(v), StringLength(v), 0); 2484 if (a != D_UNKNOWN) 2485 { 2486 Set_Did_Stability(a, stability); 2487 } 2488 else 2489 { 2490 Print_Err("No atom corresponding to persistent string"); 2491 } 2492 return PSUCCEED; 2493 } 2494 else if (IsList(t)) 2495 arity = 2; 2496 else if (IsStructure(t)) 2497 { 2498 Set_Did_Stability(v.ptr->val.did, stability); 2499 arity = DidArity(v.ptr->val.did); 2500 v.ptr++; 2501 } 2502 else 2503 return PSUCCEED; 2504 2505 for(;arity > 1; arity--) 2506 { 2507 int res; 2508 arg_i = v.ptr++; 2509 Dereference_(arg_i); 2510 res = _set_did_stability(arg_i->val, arg_i->tag, stability); 2511 if (res != PSUCCEED) 2512 return res; 2513 } 2514 arg_i = v.ptr; /* tail recursion */ 2515 Dereference_(arg_i); 2516 v.all = arg_i->val.all; 2517 t.all = arg_i->tag.all; 2518 } 2519} 2520#endif 2521 2522 2523static int 2524p_store_pred(value vproc, type tproc, value vcode, type tcode, value vsize, type tsize, value vbrktable, type tbrktable, value vflags, type tflags, value vfid, type tfid, value vlid, type tlid, value vbid, type tbid, value vm, type tm) 2525{ 2526 dident wdid; 2527 register pword *codeptr, *pw1; 2528 vmcode *base, *code, *top; 2529 uint32 flags; 2530 int err; 2531 pri *proc; 2532 pri_code_t pricode; 2533 word codetype, codelen; 2534 2535 codelen = 0; 2536 Check_Integer(tsize); 2537 Check_Integer(tbrktable); 2538 Error_If_Ref(tcode); 2539 if (IsList(tcode)) { 2540 codetype = TLIST; 2541 codeptr = vcode.ptr; 2542 } else if (IsStructure(tcode)) { 2543 codetype = TCOMP; 2544 codelen = DidArity(vcode.ptr->val.did); 2545 codeptr = vcode.ptr + 1; 2546 } else { 2547 Bip_Error(TYPE_ERROR); 2548 } 2549 Check_Module(tm, vm); 2550 /* 2551 Check_Module_And_Access(vm, tm); 2552 */ 2553 Get_Proc_Did(vproc, tproc, wdid); 2554 Check_Integer(tflags); 2555 2556 if (IsInteger(tfid)) { 2557 /* fid set to 0 if there is no source information */ 2558 Allocate_Default_ProcedureBTable(vsize.nint, wdid, vbrktable.nint); 2559 } else { 2560 Check_Atom(tfid); 2561 Check_Integer(tlid); 2562 Check_Integer(tbid); 2563 code = AllocateCodeBlockBTable(vsize.nint, vbrktable.nint, 0, vbid.nint, vfid.did, vlid.nint, Cid(WSUF(-1), wdid)); 2564 Set_Did_Stability(vfid.did, DICT_CODE_REF); 2565 } 2566 2567 /* 2568 * Traverse the code list, convert the elements and store them away 2569 */ 2570 2571 base = code; 2572 top = base + vsize.nint; 2573 2574 for(;;) /* loop through the code list/array */ 2575 { 2576 if (code > top) 2577 { 2578 Bip_Error(RANGE_ERROR); 2579 } 2580 2581 pw1 = codeptr++; 2582 Dereference_(pw1); /* get the list element */ 2583 if (IsRef(pw1->tag)) /* check it */ 2584 { 2585 Bip_Error(INSTANTIATION_FAULT); 2586 } 2587 else if (IsSimple(pw1->tag)) /* atom, integer, float: store value */ 2588 { 2589 if (IsAtom(pw1->tag)) 2590 { Set_Did_Stability(pw1->val.did, DICT_CODE_REF); } 2591 Store_d(pw1->val.nint) 2592 } 2593 else if (IsString(pw1->tag)) /* string: store pointer to heap copy */ 2594 { 2595 value heap_string; 2596 heap_string.ptr = enter_string_n(StringStart(pw1->val), 2597 StringLength(pw1->val), DICT_CODE_REF); 2598 Store_d(heap_string.nint) 2599 } 2600 else if (IsStructure(pw1->tag)) 2601 { 2602 dident d; 2603 2604 pw1 = pw1->val.ptr; 2605 d = pw1++->val.did; 2606 Dereference_(pw1); 2607 2608 if (d == d_opc1) /* o(N) */ 2609 { 2610 Check_Integer(pw1->tag); 2611 Store_i(pw1->val.nint) 2612 } 2613 else if (d == d_a1) /* a(N) */ 2614 { 2615 Check_Integer(pw1->tag); 2616 Store_d(Address(pw1->val.nint)) 2617 } 2618 else if (d == d_t1 || d == d_pw1) /* t/pw(N) */ 2619 { 2620 Check_Integer(pw1->tag); 2621 Store_d(Esize(pw1->val.nint)) 2622 } 2623 else if (d == d_y1) /* y(N) */ 2624 { 2625 { 2626 Check_Integer(pw1->tag); 2627 Store_d(Esize(pw1->val.nint)) 2628 } 2629 } 2630 else if (d == d_ymask) /* ymask(IntList) */ 2631 { 2632 word i, firsti; 2633 uword mask = 0; 2634 pword *elem; 2635 Check_List(pw1->tag); /* require ordered list of integers */ 2636 pw1 = pw1->val.ptr; 2637 elem = pw1++; 2638 Dereference_(elem); 2639 Check_Integer(elem->tag); 2640 firsti = elem->val.nint; 2641 Dereference_(pw1); 2642 while (IsList(pw1->tag)) 2643 { 2644 pw1 = pw1->val.ptr; 2645 elem = pw1++; 2646 Dereference_(elem); 2647 Check_Integer(elem->tag); 2648 i = elem->val.nint; 2649 /* 32 is the maximum number of extra consecutive slots 2650 * that can be initialised with a single instruction. 2651 * (the first slot's bit is implicit) 2652 */ 2653 if (i <= firsti || i > firsti+32) 2654 { 2655 Bip_Error(RANGE_ERROR); 2656 } 2657 /* make sure 1 is of the right length */ 2658 mask |= ((uword) 1) << (i-firsti-1); 2659 Dereference_(pw1); 2660 } 2661 Check_Nil(pw1->tag); 2662 Store_d(mask); /* store the init-mask */ 2663 } 2664 else if (d == d_w1) /* w(N) */ 2665 { 2666 Check_Integer(pw1->tag); 2667 Store_d(pw1->val.nint * sizeof(word)) 2668 } 2669 else if (d == d_nv1) /* nv(Word) */ 2670 { 2671 Check_Atom(pw1->tag); 2672 Set_Did_Stability(pw1->val.did, DICT_CODE_REF); 2673 Store_d(DidTag(TNAME, pw1->val.did)); 2674 } 2675 else if (d == d_mv1) /* mv(Word) */ 2676 { 2677 Check_Atom(pw1->tag); 2678 Set_Did_Stability(pw1->val.did, DICT_CODE_REF); 2679 Store_d(DidTag(TMETA, pw1->val.did)); 2680 } 2681 else if (d == d_an1) /* an(Atom) */ 2682 { 2683 word i; 2684 Check_Atom(pw1->tag); 2685 i = (word) meta_index(pw1->val.did); 2686 Store_d(Esize(i)); 2687 } 2688#ifdef DONT_USE_GROUND_CONSTANT_TABLE 2689 else if (d == d_tag1) /* tag(GroundTerm) */ 2690 2691 { 2692 if (IsAtom(pw1->tag) && pw1->val.did == vm.did) { 2693 Store_d(ModuleTag(pw1->val.did)); 2694 } else { 2695 Store_d(pw1->tag.all); 2696 } 2697 } 2698 else if (d == d_val1) /* val(GroundTerm) */ 2699 { 2700 int res; 2701 pword ground_copy; 2702 res = _set_did_stability(pw1->val, pw1->tag, DICT_CODE_REF); 2703 if (res != PSUCCEED) { Bip_Error(res); } 2704 res = create_heapterm(&ground_copy, pw1->val, pw1->tag); 2705 if (res != PSUCCEED) { Bip_Error(res); } 2706 Store_d(ground_copy.val.all); 2707 } 2708#else 2709 else if (d == d_tag1) /* tag(GroundTerm) */ 2710 { 2711 pword ground_copy; 2712 err = ec_constant_table_enter(pw1->val, pw1->tag, &ground_copy); 2713 if (err == PSUCCEED) { 2714 if (IsAtom(ground_copy.tag) && ground_copy.val.did == vm.did) { 2715 Store_d(ModuleTag(ground_copy.val.did)); 2716 } else { 2717 Store_d(ground_copy.tag.all); 2718 } 2719 } else if (err == PFAIL) { 2720 Store_d(pw1->tag.all); 2721 } else { 2722 Bip_Error(err) 2723 } 2724 } 2725 else if (d == d_val1) /* val(GroundTerm) */ 2726 { 2727 pword ground_copy; 2728 err = ec_constant_table_enter(pw1->val, pw1->tag, &ground_copy); 2729 if (err == PSUCCEED) { 2730 Store_d(ground_copy.val.all); 2731 } else if (err == PFAIL) { 2732 int res = create_heapterm(&ground_copy, pw1->val, pw1->tag); 2733 if (res != PSUCCEED) { Bip_Error(res); } 2734 Store_d(ground_copy.val.all); 2735 } else { 2736 Bip_Error(err) 2737 } 2738 } 2739#endif 2740 else if (d == d_proc1) /* proc(N/A) or proc(M:N/A) */ 2741 { 2742 dident pdid; 2743 if (IsStructure(pw1->tag) && pw1->val.ptr[0].val.did == d_.colon) 2744 { 2745 pword *pmod, *pproc; 2746 pmod = &pw1->val.ptr[1]; 2747 pproc = &pw1->val.ptr[2]; 2748 Dereference_(pmod); 2749 Check_Atom(pmod->tag); 2750 Dereference_(pproc); 2751 Get_Proc_Did(pproc->val, pproc->tag, pdid); 2752 Store_d(qualified_procedure(pdid, pmod->val.did, vm.did, tm)); 2753 } 2754 else 2755 { 2756 Get_Proc_Did(pw1->val, pw1->tag, pdid); 2757 Store_d(visible_procedure(pdid, vm.did, tm, PRI_CREATE|PRI_REFER)); 2758 } 2759 } 2760 else if (d == d_functor1) /* functor(N/A) */ 2761 { 2762 dident pdid; 2763 Get_Functor_Did(pw1->val, pw1->tag, pdid); 2764 Set_Did_Stability(pdid, DICT_CODE_REF); 2765 Store_d(pdid); 2766 } 2767 else if (d == d_ref1) /* ref(atom or displacement) */ 2768 { 2769 Store_Ref(pw1, base); 2770 } 2771 else if (d == d_refm) /* refm(displacement,marker) */ 2772 { 2773 /* Temporary hack to create pointers with one of their 2774 * low bits set for marking purposes. */ 2775 Store_d((word)(base + pw1[0].val.nint) + pw1[1].val.nint) 2776 } 2777 else if (d == d_align) /* align(multiple of words) */ 2778 { 2779 int i; 2780 if (pw1->val.nint < 1 || pw1->val.nint > 2 /*arbitrary*/) 2781 { 2782 Bip_Error(RANGE_ERROR); 2783 } 2784 while ((code - (vmcode*)0) % pw1->val.nint) 2785 { 2786 Store_i(Nop) 2787 } 2788 } 2789 else if (d == d_table2) /* table(Table,Size) Size in words */ 2790 { 2791 pword *elem, *pw; 2792 pword result; 2793 int err; 2794 2795 Check_List(pw1->tag); 2796 pw = &result; 2797 while (IsList(pw1->tag)) /* list of Key-ref(Ref) pairs */ 2798 { 2799 pw1 = pw1->val.ptr; 2800 elem = pw1++; 2801 Dereference_(elem); 2802 if (IsStructure(elem->tag) && (elem->val.ptr->val.did == d_.minus)) 2803 { 2804 value key; 2805 2806 elem = elem->val.ptr + 1; 2807 Dereference_(elem); 2808 Get_Functor_Did(elem->val, elem->tag, key.did); 2809 Set_Did_Stability(key.did, DICT_CODE_REF); 2810 Make_List(pw, TG); 2811 pw = TG; 2812 Push_List_Frame(); 2813 Make_Struct(&pw[0], TG); 2814 Push_Struct_Frame(d_.minus); 2815 Make_Integer(&pw[3], key.nint); 2816 pw[4] = *(++elem); /* value */ 2817 pw = &pw[1]; 2818 Dereference_(pw1); 2819 } 2820 } 2821 Make_Nil(pw); 2822 if (!IsNil(result.tag)) 2823 { 2824 pword key; 2825 2826 key.val.nint = 1; 2827 key.tag.kernel = TINT; 2828 result.val.ptr = ec_keysort(result.val, key.val, key.tag, 0, 1, 0, &err); 2829 if (!result.val.ptr) 2830 { 2831 Bip_Error(err); 2832 } 2833 } 2834 pw1 = &result; 2835 while (IsList(pw1->tag)) /* list of Key-ref(Ref) pairs */ 2836 { 2837 pw1 = pw1->val.ptr; 2838 elem = pw1++; 2839 Dereference_(elem); 2840 elem = elem->val.ptr + 1; 2841 Store_d(elem->val.nint); /* store key */ 2842 elem++; 2843 Dereference_(elem); 2844 if (IsStructure(elem->tag) && (elem->val.ptr->val.did == d_ref1)) 2845 { 2846 elem = elem->val.ptr + 1; 2847 Dereference_(elem); 2848 Store_Ref(elem, base); /* store value */ 2849 } 2850 else 2851 { 2852 Bip_Error(TYPE_ERROR); 2853 } 2854 Dereference_(pw1); 2855 } 2856 } 2857 else { Bip_Error(RANGE_ERROR); } 2858 } 2859 else { Bip_Error(TYPE_ERROR); } 2860 2861 if (codetype == TLIST) { 2862 Dereference_(codeptr); /* get the list tail */ 2863 if (IsRef(codeptr->tag)) 2864 { Bip_Error(INSTANTIATION_FAULT); } 2865 else if (IsList(codeptr->tag)) 2866 codeptr = codeptr->val.ptr; 2867 else if (IsNil(codeptr->tag)) 2868 break; /* end of the list */ 2869 else { Bip_Error(TYPE_ERROR); } 2870 } else { /* codetype == TCOMP */ 2871 if (--codelen == 0) 2872 break; 2873 } 2874 } 2875 2876 a_mutex_lock(&ProcedureLock); 2877 2878 proc = local_procedure(wdid, vm.did, tm, PRI_CREATE); 2879 if (!proc) 2880 { 2881 a_mutex_unlock(&ProcedureLock); 2882 Get_Bip_Error(err); 2883 Bip_Error(err); 2884 } 2885 /* Set ECO_FLAGS according to flags argument. 2886 * Keep DEBUG_SK if set, because it was probably done by a preceding skipped-directive. 2887 * Always clear TOOL flag. 2888 */ 2889 flags = (uint32)((vflags.nint & ECO_FLAGS) | (PriFlags(proc) & (DEBUG_SK))); 2890 err = pri_compatible_flags(proc, CODETYPE|TOOL|ECO_FLAGS, VMCODE|flags); 2891 if (err != PSUCCEED) 2892 { 2893 a_mutex_unlock(&ProcedureLock); 2894 Bip_Error(err); 2895 } 2896 pri_change_flags(proc, TOOL|ECO_FLAGS, flags); 2897 pricode.vmc = base; 2898 pri_define_code(proc, VMCODE, pricode); 2899 a_mutex_unlock(&ProcedureLock); 2900 2901 Succeed_; 2902} 2903 2904 2905static int 2906p_decode_code(value vcode, type tcode, value v, type t) 2907{ 2908 dident d; 2909 word w; 2910 pword *pw1; 2911 2912 if (IsAtom(tcode) && vcode.did == d_tags) /* tags -> tags/NTYPES */ 2913 { 2914 int i; 2915 pword *pw = TG; 2916 Push_Struct_Frame(add_dict(d_tags,NTYPES)); 2917 for (i = 0; i < NTYPES; i++) 2918 { 2919 if (tag_desc[i].tag_name == d_.nil) 2920 { 2921 Make_Nil(&pw[i+1]); 2922 } 2923 else 2924 { 2925 Make_Atom(&pw[i+1], tag_desc[i].tag_name); 2926 } 2927 } 2928 Return_Unify_Structure(v, t, pw); 2929 } 2930 Check_Structure(tcode); 2931 2932 pw1 = vcode.ptr; 2933 d = pw1++->val.did; 2934 if (d == d_constant2) /* constant(Tag,Val) -> Term */ 2935 { 2936 pword c; 2937 pword *pw2 = pw1+1; 2938 Dereference_(pw1); 2939 Check_Integer(pw1->tag); 2940 c.val.nint = pw1->val.nint; 2941 Dereference_(pw2); 2942 Check_Integer(pw2->tag); 2943 c.tag.kernel = pw2->val.nint; 2944 Return_Unify_Pw(v, t, c.val, c.tag); 2945 } 2946 else if (d == d_init2) /* init(word,word) -> IntList */ 2947 { 2948 int slot; 2949 uword mask; 2950 pword *pw, result; 2951 2952 pw = pw1+1; 2953 Dereference_(pw1); 2954 Check_Integer(pw1->tag); 2955 slot = pw1->val.nint / (word) sizeof(pword); 2956 Dereference_(pw); 2957 Check_Integer(pw->tag); 2958 /* only the lower 32 bits of the mask are significant */ 2959 mask = (uword) (pw->val.nint & (unsigned) 0xffffffff); 2960 2961 Make_List(&result,TG); 2962 pw = TG; 2963 Push_List_Frame(); 2964 Make_Integer(&pw[0],slot); 2965 while (mask) 2966 { 2967 ++slot; 2968 if (mask & 1) 2969 { 2970 Make_List(&pw[1], TG); 2971 pw = TG; 2972 Push_List_Frame(); 2973 Make_Integer(&pw[0],slot); 2974 } 2975 mask >>= 1; 2976 } 2977 Make_Nil(&pw[1]); 2978 Return_Unify_Pw(v, t, result.val, result.tag); 2979 } 2980 else if (d == d_edesc) /* edesc(Edesc) -> Size or BitList */ 2981 { 2982 uword edesc; 2983 Dereference_(pw1); 2984 Check_Integer(pw1->tag); 2985 edesc = pw1->val.nint; 2986 if (EdescIsSize(edesc)) 2987 { 2988 /* it's an environment size, positive or -1 */ 2989 Return_Unify_Integer(v, t, (word)edesc/(word)sizeof(pword)); 2990 } 2991 else 2992 { 2993 /* decode environment activity map into a list of slot numbers */ 2994 pword result; 2995 pword *pw = &result; 2996 uword pos = 1; 2997 uword *eam_ptr = EdescEamPtr(edesc); 2998 do { 2999 int i = EAM_CHUNK_SZ; 3000 uword eam = EamPtrEam(eam_ptr); 3001 for(;eam;--i) { 3002 if (eam & 1) { 3003 Make_List(pw, TG); 3004 pw = TG; 3005 Push_List_Frame(); 3006 Make_Integer(&pw[0], pos); 3007 pw = &pw[1]; 3008 } 3009 eam >>= 1; 3010 pos++; 3011 } 3012 pos += i; 3013 } while (EamPtrNext(eam_ptr)); 3014 Make_Nil(pw); 3015 Return_Unify_Pw(v, t, result.val, result.tag); 3016 } 3017 } 3018 else if (d == d_table2) /* table(Address,Size) -> ListOfPairs */ 3019 { 3020 int i; 3021 pword result; 3022 pword *pw, *ptable; 3023 3024 ptable = pw1++; 3025 Dereference_(ptable); 3026 Check_Integer(ptable->tag); /* table address */ 3027 ptable = ptable->val.ptr; 3028 Dereference_(pw1); 3029 Check_Integer(pw1->tag); /* number of entries */ 3030 3031 pw = &result; 3032 for (i=0; i<pw1->val.nint; ++i) 3033 { 3034 Make_List(pw, TG); 3035 pw = TG; 3036 Push_List_Frame(); 3037 Make_Struct(&pw[0], TG); 3038 Push_Struct_Frame(d_.minus); 3039 Make_Integer(&pw[3], ptable[i].val.nint); 3040 Make_Integer(&pw[4], ptable[i].tag.kernel); 3041 pw = &pw[1]; 3042 } 3043 Make_Nil(pw); 3044 Return_Unify_Pw(v, t, result.val, result.tag); 3045 } 3046 else if (d == d_try_table2) /* try_table(Word,Word) -> ListOfIntegers */ 3047 { 3048 int i; 3049 pword result; 3050 pword *pw, *ptable; 3051 3052 ptable = pw1++; 3053 Dereference_(ptable); 3054 Check_Integer(ptable->tag); /* table address */ 3055 Dereference_(pw1); 3056 Check_Integer(pw1->tag); /* number of entries - 1 */ 3057 3058 pw = &result; 3059 for (i=0; i<=pw1->val.nint; ++i) 3060 { 3061 Make_List(pw, TG); 3062 pw = TG; 3063 Push_List_Frame(); 3064 Make_Integer(pw, ptable->val.wptr[i]); 3065 pw = &pw[1]; 3066 } 3067 Make_Nil(pw); 3068 Return_Unify_Pw(v, t, result.val, result.tag); 3069 } 3070 else if (d == d_ref2) /* ref(Address,Base) -> atom or displacement */ 3071 { 3072 pword *base; 3073 3074 base = pw1+1; 3075 Dereference_(pw1); 3076 Check_Integer(pw1->tag); /* absolute address of reference */ 3077 if (pw1->val.wptr == (uword *) &fail_code_[0]) 3078 { 3079 Return_Unify_Atom(v, t, d_.fail); 3080 } 3081 else if (pw1->val.wptr == (uword *) &par_fail_code_[0]) 3082 { 3083 Return_Unify_Atom(v, t, d_par_fail); 3084 } 3085 3086 Dereference_(base); 3087 Check_Integer(base->tag); /* base address of predicate */ 3088 Return_Unify_Integer(v, t, pw1->val.wptr - base->val.wptr); 3089 3090 } 3091 if (DidArity(d) != 1) 3092 { Bip_Error(RANGE_ERROR); } 3093 Dereference_(pw1); 3094 Check_Integer(pw1->tag); 3095 if (d == d_opc1) /* o(Word) -> Number */ 3096 { 3097 Return_Unify_Integer(v, t, Get_Int_Opcode(&(pw1->val.nint))); 3098 } 3099 else if (d == d_w1) /* w(Word) -> Number */ 3100 { 3101 Return_Unify_Integer(v, t, pw1->val.nint / (word) sizeof(word)); 3102 } 3103 else if (d == d_a1) /* a(Word) -> Number */ 3104 { 3105 Return_Unify_Integer(v, t, pw1->val.ptr - &A[0]); 3106 } 3107 else if (d == d_y1 || d == d_t1 || d == d_pw1) /* y/t/pw(Word) -> Number */ 3108 { 3109 Return_Unify_Integer(v, t, pw1->val.nint / (word) sizeof(pword)); 3110 } 3111 else if (d == d_proc1) /* proc(Word) -> N/A or M:N/A */ 3112 { 3113 pword *pw = TG; 3114 dident pdid = PriDid(pw1->val.priptr); 3115 Push_Struct_Frame(d_.quotient); 3116 Make_Atom(&pw[1], add_dict(pdid, 0)); 3117 Make_Integer(&pw[2], DidArity(pdid)); 3118 if (PriScope(pw1->val.priptr) == QUALI) 3119 { 3120 Push_Struct_Frame(d_.colon); 3121 Make_Atom(&pw[4], pw1->val.priptr->module_ref); 3122 Make_Struct(&pw[5], pw); 3123 pw = &pw[3]; 3124 } 3125 Return_Unify_Structure(v, t, pw); 3126 } 3127 else if (d == d_functor1) /* functor(Word) -> N/A */ 3128 { 3129 pword *pw = TG; 3130 Push_Struct_Frame(d_.quotient); 3131 Make_Atom(&pw[1], add_dict(pw1->val.did, 0)); 3132 Make_Integer(&pw[2], DidArity(pw1->val.did)); 3133 Return_Unify_Structure(v, t, pw); 3134 } 3135 else if (d == d_.atom) /* atom(Word) -> '...' */ 3136 { 3137 if (DidArity(pw1->val.did) != 0) 3138 { Bip_Error(RANGE_ERROR); } 3139 Return_Unify_Atom(v, t, pw1->val.did); 3140 } 3141 else if (d == d_.string) /* string(Word) -> "..." */ 3142 { 3143 Return_Unify_String(v, t, pw1->val.ptr); 3144 } 3145#ifdef TFLOAT 3146 else if (d == d_.float1) /* float(Word) -> x.y */ 3147 { 3148 Return_Unify_Float(v, t, pw1->val.real); 3149 } 3150#endif 3151 else if (d == d_nv1 || d == d_mv1) /* nv(Word) -> 'VarName' */ 3152 { 3153 Return_Unify_Atom(v, t, TagDid(pw1->val.nint)); 3154 } 3155 Bip_Error(RANGE_ERROR); 3156} 3157 3158 3159static int 3160p_functor_did(value vspec, type tspec, value v, type t) 3161{ 3162 dident d; 3163 Get_Functor_Did(vspec, tspec, d); 3164 Return_Unify_Integer(v, t, (word) d); 3165} 3166 3167 3168static int 3169p_retrieve_code(value vproc, type tproc, value vcode, type tcode, value vm, type tm) 3170{ 3171 dident wdid; 3172 vmcode *code_block, *code; 3173 int err; 3174 pri *proc; 3175 pword block_list; 3176 pword *p_block_list, *pcode; 3177 word size; 3178 3179 Check_Output_List(tcode); 3180 Check_Module(tm, vm); 3181 Get_Proc_Did(vproc, tproc, wdid); 3182 3183 proc = visible_procedure(wdid, vm.did, tm, 0); 3184 if (!proc) 3185 { 3186 Get_Bip_Error(err); 3187 Bip_Error(err); 3188 } 3189 3190 p_block_list = &block_list; 3191 code_block = ProcHeader(PriCode(proc)); 3192 while (code_block) 3193 { 3194 pword *p_struct; 3195 word i; 3196 3197 code = CodeStart(code_block); 3198 switch(BlockType(code_block)) 3199 { 3200 case GROUND_TERM: 3201#if 0 3202 Make_List(p_block_list, TG); /* new list element */ 3203 p_block_list = TG; 3204 Push_List_Frame(); 3205 Make_Struct(p_block_list, TG); 3206 ++p_block_list; 3207 p_struct = TG; 3208 3209 Push_Struct_Frame(in_dict("term",2)); 3210 pcode = ProcStruct(code); 3211 /* we return pcode->val.ptr instead if pcode because that's 3212 * the address that occurs in the ..._constant instructions */ 3213 Make_Integer(&p_struct[1], pcode->val.ptr); 3214 p_struct[2] = *pcode; 3215#endif 3216 break; 3217 3218 case PARALLEL_TABLE: 3219 break; 3220 3221 case HASH_TABLE: 3222 case UNDEFINED_PROC: 3223 case DYNAMIC_PROC: 3224 p_fprintf(current_err_, 3225 "retrieve_code/3: can't handle block type %d (ignoring)\n", 3226 BlockType(code_block)); 3227 ec_flush(current_err_); 3228 break; 3229 3230 default: /* normal code block */ 3231 Make_List(p_block_list, TG); /* new list element */ 3232 p_block_list = TG; 3233 Push_List_Frame(); 3234 Make_Struct(p_block_list, TG); 3235 ++p_block_list; 3236 p_struct = TG; 3237 3238 Push_Struct_Frame(in_dict("code",2)); 3239 Make_Integer(&p_struct[1],code); 3240 pcode = &p_struct[2]; 3241 size = ProcCodeSize(code); 3242 for (i=0; i<size; ++i) 3243 { 3244 Make_List(pcode, TG); 3245 pcode = TG; 3246 Push_List_Frame(); 3247 Make_Integer(pcode, code[i]); 3248 ++pcode; 3249 } 3250 Make_Nil(pcode); 3251 break; 3252 } 3253 code_block = * (vmcode **) code_block; 3254 } 3255 Make_Nil(p_block_list); 3256 3257 Return_Unify_Pw(vcode, tcode, block_list.val, block_list.tag); 3258} 3259 3260 3261/* 3262 * Clean up all memory areas whre there might be some unused stuff. 3263 */ 3264static int 3265p_trimcore(void) 3266{ 3267 reclaim_abolished_procedures(); 3268 (void) trim_global_trail(TG_SEG); 3269 (void) trim_control_local(); 3270 Succeed_; 3271} 3272 3273int 3274get_mode(uint32 mode_decl, dident wd) 3275{ 3276 int arity; 3277 int mode; 3278 pword *p = TG++; 3279 3280 arity = DidArity(wd); 3281 3282 if (arity == 0) 3283 { 3284 Check_Gc; 3285 Make_Atom(p, wd) 3286 return PSUCCEED; 3287 } 3288 else if (wd == d_.list) 3289 { 3290 Make_List(p,TG); 3291 p = TG; 3292 Push_List_Frame(); 3293 } 3294 else 3295 { 3296 Make_Struct(p,TG); 3297 p = TG+1; 3298 Push_Struct_Frame(wd); 3299 } 3300 3301 while (arity--) 3302 { 3303 p->tag.kernel = TDICT; 3304 Next_Mode(mode_decl, mode); 3305 switch (mode) 3306 { 3307 case NONVAR: 3308 p->val.did = d_.plus0; 3309 break; 3310 3311 case GROUND: 3312 p->val.did = d_.plusplus; 3313 break; 3314 3315 case OUTPUT: 3316 p->val.did = d_.minus0; 3317 break; 3318 3319#ifdef EXTENDED_MODES 3320 case NOALIAS_INST: 3321 p->val.did = d_plusminus; 3322 break; 3323 3324 case NOALIAS: 3325 p->val.did = d_minusplus; 3326 break; 3327#endif 3328 3329 default: 3330 p->val.did = d_.question; 3331 } 3332 p++; 3333 } 3334 return PSUCCEED; 3335} 3336/* Bip_Error() redefined to return() !! */ 3337