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 * SEPIA C SOURCE MODULE 25 * 26 * VERSION $Id: bip_module.c,v 1.12 2015/01/14 01:31:09 jschimpf Exp $ 27 */ 28 29/* 30 * File: bip_module.c 31 * Author: dominic 32 */ 33 34#include "config.h" 35#include "sepia.h" 36#include "types.h" 37#include "embed.h" 38#include "mem.h" 39#include "error.h" 40#include "ec_io.h" 41#include "dict.h" 42#include "database.h" 43#include "emu_export.h" 44#include "debug.h" 45#include "gencode.h" 46#include "module.h" 47#include "opcode.h" 48#include "property.h" 49 50extern syntax_desc 51 *copy_syntax_desc(syntax_desc *sd); 52 53static int 54 p_is_module(value v, type t), 55 p_is_locked(value v, type t), 56 p_authorized_module(value v, type t), 57 p_lock1(value v, type t), 58 p_lock2(value v, type t, value vl, type tl), 59 p_lock_pass_(value v, type t, value vl, type tl), 60 p_unlock2(value v, type t, value vl, type tl), 61 p_tool1(value vi, type ti, value vm, type tm), 62 p_tool2(value vi, type ti, value vb, type tb, value vm, type tm), 63 p_tool_body(value vi, type ti, value vb, type tb, value vmb, type tmb, value vm, type tm), 64 p_local(value v, type t, value vm, type tm), 65 p_implicit_local(value v, type t, value vm, type tm), 66 p_export(value v, type t, value vm, type tm), 67 p_reexport_from(value vim, type tim, value v, type t, value vm, type tm), 68 p_import_from(value vim, type tim, value v, type t, value vm, type tm), 69 p_import(value library, type tlib, value import_mod, type tim), 70 p_pr(value v, type t), 71 p_erase_module(value module, type module_tag, value from_mod, type tfrom_mod), 72 p_create_module(value v, type t), 73 p_begin_module(value v, type t), 74 p_default_module(value v, type t), 75 p_module_tag(value vm, type tm, value vs, type ts); 76 77 78void 79module_init(int flags) 80{ 81 if (flags & INIT_SHARED) 82 { 83 value v1; 84 85 v1.did = d_.kernel_sepia; 86 (void) p_create_module(v1,tdict); 87 88 v1.did = d_.default_module; /* needed while -b option is in C */ 89 (void) p_create_module(v1,tdict); 90 91#ifdef DFID 92 v1.did = in_dict("dfid", 0); /* to initialize global vars */ 93 (void) p_create_module(v1,tdict); 94#endif 95 96 97 AbolishedProcedures = 0; 98 AbolishedDynProcedures = 0; 99 CompiledStructures = 0; 100 AbolishedProcedures = 0; 101 } 102} 103 104 105void 106bip_module_init(int flags) 107{ 108 if (!(flags & INIT_SHARED)) 109 return; 110 (void) local_built_in(in_dict("erase_module_", 2), p_erase_module, B_SAFE); 111 (void) local_built_in(in_dict("is_a_module", 1), p_is_module, B_SAFE); 112 (void) local_built_in(in_dict("authorized_module", 1), p_authorized_module, B_SAFE); 113 (void) built_in(in_dict("is_locked", 1), p_is_locked, B_SAFE); 114 (void) built_in(in_dict("begin_module", 1), p_begin_module, B_SAFE); 115 (void) local_built_in(in_dict("begin_module", 2), p_begin_module, B_SAFE); 116 (void) local_built_in(in_dict("create_module_", 1), p_create_module, B_SAFE); 117 (void) built_in(d_.lock, p_lock1, B_SAFE); 118 (void) built_in(in_dict("lock", 2), p_lock2, B_SAFE); 119 (void) built_in(in_dict("lock_pass_", 2), p_lock_pass_, B_SAFE); 120 (void) built_in(in_dict("unlock", 2), p_unlock2, B_SAFE); 121 (void) exported_built_in(in_dict("tool_", 2), p_tool1, B_UNSAFE); 122 (void) exported_built_in(in_dict("tool_", 3), p_tool2, B_UNSAFE); 123 exported_built_in(in_dict("tool_body_", 4), p_tool_body, B_UNSAFE|U_GROUND) 124 -> mode = BoundArg(2, GROUND) | BoundArg(3, CONSTANT); 125 (void) local_built_in(d_.localb, p_local, B_UNSAFE); 126 (void) exported_built_in(in_dict("implicit_local",2), p_implicit_local, B_UNSAFE); 127 (void) local_built_in(d_.exportb, p_export, B_UNSAFE); 128 (void) local_built_in(in_dict("reexport_from_",3), p_reexport_from, B_UNSAFE); 129 (void) local_built_in(d_.import_fromb, p_import_from, B_UNSAFE); 130 (void) local_built_in(in_dict("import_", 2), p_import, B_UNSAFE); 131 (void) local_built_in(in_dict("module_tag", 2), p_module_tag, B_UNSAFE); 132 (void) exported_built_in(in_dict("default_module", 1), p_default_module, 133 B_UNSAFE|U_SIMPLE); 134 (void) exported_built_in(in_dict("pr", 1), p_pr, B_SAFE); 135 136} 137 138 139/* 140 tool_body_(Name1/Arity1, Name2/Arity2, BodyModule, SourceModule) 141 returns the body procedure to a specified tool procedure 142*/ 143 144static int 145_tool_body(pri *proci, dident *pdid, int *parity, dident *pmodule) 146{ 147 pri *procb; 148 int flags; 149 vmcode *code; 150 151 flags = proci->flags; 152 code = proci->code.vmc; 153 154 if (!(flags & CODE_DEFINED)) 155 { 156 if (flags & AUTOLOAD) 157 { Set_Bip_Error(NOT_LOADED); } 158 else 159 { Set_Bip_Error(NOENTRY); } 160 return 0; 161 } 162 if (!(flags & TOOL)) 163 { 164 Set_Bip_Error(NO_TOOL); 165 return 0; 166 } 167 if (PriCodeType(proci) == VMCODE) 168 { 169 if (DebugProc(proci)) 170 procb = (pri *) *(code + DEBUG_LENGTH + 1); 171 else 172 procb = (pri *) *(code + 1); 173 *pdid = procb->did; 174 *parity = DidArity(procb->did); 175 *pmodule = procb->module_def; 176 } 177 else /* don't know how to get the tool body */ 178 { 179 Set_Bip_Error(NO_TOOL); 180 return 0; 181 } 182 return 1; 183} 184 185static int 186p_tool_body(value vi, type ti, value vb, type tb, value vmb, type tmb, value vm, type tm) 187{ 188 dident di; 189 pri *procb, *proci; 190 int flags, arity; 191 dident module; 192 dident pdid; 193 pword *ptr = Gbl_Tg; 194 vmcode *code; 195 int err; 196 Prepare_Requests; 197 198 Check_Module(tm, vm); 199 Get_Proc_Did(vi, ti, di); 200 if (!IsRef(tb) 201 && (!IsStructure(tb) 202 || vb.ptr->val.did != d_.quotient)) 203 { 204 Bip_Error(TYPE_ERROR); 205 } 206 Check_Output_Atom_Or_Nil(vmb, tmb); 207 if (!(proci = visible_procedure(di, vm.did, tm, PRI_CREATE))) 208 { 209 Get_Bip_Error(err); 210 Bip_Error(err); 211 } 212 213 if (!_tool_body(proci, &pdid, &arity, &module)) 214 { 215 Get_Bip_Error(err); 216 Bip_Error(err); 217 } 218 219 Gbl_Tg += 3; 220 Check_Gc; 221 ptr[0].tag.kernel = TDICT; 222 ptr[0].val.did = d_.quotient; 223 ptr[1].tag.kernel = TDICT; 224 ptr[1].val.did = add_dict(pdid, 0); 225 ptr[2].tag.kernel = TINT; 226 ptr[2].val.nint = arity; 227 228 Request_Unify_Atom(vmb, tmb, module); 229 Request_Unify_Structure(vb, tb, ptr); 230 Return_Unify; 231} 232 233 234/******************************************************************* 235 * 236 * The functions to handle modules : 237 * 238 * create_module/1 239 * erase_module/1 240 * lock/1 tool body of lock/0 + backward comp. 241 * lock/2 backward compatibility 242 * lock_pass_/2 tool body of lock_pass/1 243 * unlock/2 244 * 245 ******************************************************************* */ 246 247int 248ec_create_module(dident module_did) /* also called from megalog */ 249{ 250 pword *prop; 251 module_item *m; 252 253 /* Not quite right, should be atomic lookup & enter */ 254 a_mutex_lock(&ModuleLock); 255 256 if (IsModule(module_did)) 257 { 258 a_mutex_unlock(&ModuleLock); 259 Bip_Error(MODULE_EXISTS); 260 } 261 262 DidModule(module_did) = UNLOCK_MODULE; 263 prop = (pword *) get_property(module_did, MODULE_PROP); 264 if (!prop) 265 { 266 prop = (pword *) set_property(module_did, MODULE_PROP); 267 /* the module did not exist before, no need to test prop */ 268 m = (module_item *) hg_alloc(sizeof(module_item)); 269 prop->tag.kernel = TPTR; 270 prop->val.ptr = (pword *) m; 271 } 272 else 273 m = (module_item *) prop->val.ptr; 274 275 m->syntax = copy_syntax_desc(default_syntax); 276 m->lock = (char *) 0; 277 m->procedures = 0; 278 m->properties = 0; 279 m->imports = 0; 280 281 a_mutex_unlock(&ModuleLock); 282 Succeed_; 283} 284 285 286static int 287p_create_module(value v, type t) 288{ 289 Check_Atom(t); /* don't allow TNIL because of ModuleTag() problem */ 290 return ec_create_module(v.did); 291} 292 293 294static int 295p_begin_module(value v, type t) 296{ 297 Check_Module_And_Access(v, t); 298 Succeed_; 299} 300 301 302static int 303p_default_module(value v, type t) 304{ 305 if (IsRef(t)) { 306 pword pw; 307 pw.val.did = d_.default_module; 308 pw.tag.kernel = ModuleTag(d_.default_module); 309 Return_Unify_Pw(v, t, pw.val, pw.tag); 310 } 311 Check_Module_And_Access(v, t); 312 d_.default_module = v.did; 313 Succeed_; 314} 315 316 317static int 318p_lock1(value v, type t) 319{ 320 Check_Module_And_Access(v, t); 321 DidModule(v.did) = HARD_LOCK_MODULE; 322 Succeed_; 323} 324 325 326static int 327p_lock_pass_(value vl, type tl, value v, type t) 328{ 329 module_item *m; 330 331 Check_Module_And_Access(v, t); 332 Check_String(tl); 333 334 DidModule(v.did) = SOFT_LOCK_MODULE; 335 m = ModuleItem(v.did); 336 /* the string should be stored crypted */ 337 m->lock = (char *) hg_alloc((int) StringLength(vl) + 1); 338 Copy_Bytes(m->lock, StringStart(vl), StringLength(vl) + 1); 339 340 Succeed_; 341} 342 343 344static int 345p_lock2(value v, type t, value vl, type tl) 346{ 347 return p_lock_pass_(vl, tl, v, t); 348} 349 350 351static int 352p_unlock2(value v, type t, value vl, type tl) 353{ 354 module_item *m; 355 356 Check_Atom_Or_Nil(v, t); 357 Check_String(tl); 358 359 if (!IsModule(v.did)) 360 { 361 Bip_Error(MODULENAME); 362 } 363 if (!IsLocked(v.did)) 364 { 365 Succeed_; 366 } 367 if (DidModule(v.did) == HARD_LOCK_MODULE) 368 { 369 Bip_Error(LOCKED); 370 } 371 m = ModuleItem(v.did); 372 if (!strcmp(m->lock, StringStart(vl))) 373 { 374 hg_free((generic_ptr) m->lock); 375 DidModule(v.did) = UNLOCK_MODULE; 376 m->lock = (char *) 0; 377 Succeed_; 378 } 379 else 380 { 381 Bip_Error(WRONG_UNLOCK_STRING); 382 } 383} 384 385 386static int 387p_is_module(value v, type t) 388{ 389 Check_Atom_Or_Nil(v, t); 390 Succeed_If(IsModule(v.did)); 391} 392 393 394static int 395p_authorized_module(value v, type t) 396{ 397 Check_Atom_Or_Nil(v, t); 398 Succeed_If(IsModule(v.did) && (!IsLocked(v.did) || IsModuleTag(v.did, t))); 399} 400 401 402static int 403p_is_locked(value v, type t) 404{ 405 Check_Atom_Or_Nil(v, t); 406 407 if (!IsModule(v.did)) 408 { 409 Bip_Error(MODULENAME) 410 } 411 if (IsLocked(v.did)) 412 { 413 Succeed_; 414 } 415 else 416 { 417 Fail_; 418 } 419} 420 421 422/******************************************************************* 423 * 424 * Properties functions 425 * 426 ******************************************************************* */ 427 428 429/* 430 pr(Name/Arity) 431 prints on the current_output the properties of a predicate 432 in all modules. 433*/ 434static int 435p_pr(value v, type t) 436{ 437 pri *proc; 438 dident wdid; 439 dident module; 440 int flags; 441 int yes = 0; 442 443 Get_Proc_Did(v, t, wdid); 444 proc = DidPtr(wdid)->procedure; 445 446 while (proc) 447 { 448 module = proc->module_def; 449 if (!module 450#ifndef PRINTAM 451 || (IsLocked(module) && !PriExported(proc)) 452#endif 453 ) 454 { 455 proc = proc->nextproc; 456 continue; 457 } 458 459 yes = 1; 460 p_fprintf(log_output_, "in %s: ", DidName(module)); 461 if (SystemProc(proc)) 462 p_fprintf(log_output_, "system "); 463 if (proc->flags & AUTOLOAD) 464 (void) ec_outfs(log_output_, "autoload "); 465 if (proc->flags & PROC_DYNAMIC) { 466 (void) ec_outfs(log_output_, "dynamic "); 467 } else { 468 (void) ec_outfs(log_output_, "static "); 469 } 470 switch(proc->flags & CODETYPE) { 471 case VMCODE: 472 (void) ec_outfs(log_output_, "vmcode "); 473 break; 474 case FUNPTR: 475 (void) ec_outfs(log_output_, "funptr "); 476 break; 477 default: 478 (void) ec_outfs(log_output_, "code? "); 479 break; 480 } 481 switch(proc->flags & ARGPASSING) { 482 case ARGFIXEDWAM: 483 (void) ec_outfs(log_output_, "argfixedwam "); 484 break; 485 case ARGFLEXWAM: 486 (void) ec_outfs(log_output_, "argflexwam "); 487 break; 488 default: 489 (void) ec_outfs(log_output_, "? "); 490 break; 491 } 492 if (proc->flags & EXTERN) 493 { 494 (void) ec_outfs(log_output_, "external"); 495 switch(proc->flags & UNIFTYPE) { 496 case U_NONE: 497 (void) ec_outfs(log_output_, "_u_none "); 498 break; 499 case U_SIMPLE: 500 (void) ec_outfs(log_output_, "_u_simple "); 501 break; 502 case U_GROUND: 503 (void) ec_outfs(log_output_, "_u_ground "); 504 break; 505 case U_UNIFY: /* equal to fresh */ 506 (void) ec_outfs(log_output_, "_u_unify "); 507 break; 508 case U_GLOBAL: 509 (void) ec_outfs(log_output_, "_u_global "); 510 break; 511 case U_DELAY: 512 (void) ec_outfs(log_output_, "_u_delay "); 513 break; 514 default: 515 (void) ec_outfs(log_output_, "_u_? "); 516 break; 517 } 518 } 519 else 520 { 521 (void) ec_outfs(log_output_, "prolog "); 522 } 523 flags = proc->flags; 524 if (flags & TOOL) 525 (void) ec_outfs(log_output_, "tool "); 526 switch (PriScope(proc)) 527 { 528 case EXPORT: 529 (void) ec_outfs(log_output_, "exported "); break; 530 case LOCAL: 531 (void) ec_outfs(log_output_, "local "); break; 532 case IMPORT: 533 (void) ec_outfs(log_output_, "imported "); break; 534 case DEFAULT: 535 (void) ec_outfs(log_output_, "default "); break; 536 case QUALI: 537 (void) ec_outfs(log_output_, "qualified "); break; 538 } 539 p_fprintf(log_output_, "%s ", DidName(proc->module_ref)); 540 541 if (flags & DEBUG_DB) 542 (void) ec_outfs(log_output_, "debugged "); 543 if (flags & DEBUG_ST) 544 (void) ec_outfs(log_output_, "start_tracing "); 545 if (flags & DEBUG_TR) 546 (void) ec_outfs(log_output_, "traceable "); 547 else 548 (void) ec_outfs(log_output_, "untraceable "); 549 if (flags & DEBUG_SP) 550 (void) ec_outfs(log_output_, "spied "); 551 if (flags & DEBUG_SK) 552 (void) ec_outfs(log_output_, "skipped "); 553 if (!PriReferenced(proc)) 554 (void) ec_outfs(log_output_, "non_referenced "); 555 556 if (flags & CODE_DEFINED) 557 (void) ec_outfs(log_output_, "code_defined "); 558 proc = proc->nextproc; 559 (void) ec_outfs(log_output_, "\n"); 560 } 561 if (yes) 562 { 563 Succeed_; 564 } 565 else 566 { 567 Fail_; 568 } 569} 570 571 572/* ************************************************************** 573 * DECLARATIONS 574 * ************************************************************** */ 575 576/* 577 _tool_code(proc, debug) 578 - makes the code for a tool interface 579*/ 580static vmcode * 581_tool_code(pri *procb, int debug) 582{ 583 vmcode *code; 584 vmcode *save; 585 586 if (PriCodeType(procb) & VMCODE) 587 { 588 Allocate_Default_Procedure(3 + (debug?DEBUG_LENGTH:0), PriDid(procb)); 589 save = code; 590 if (debug) { 591 Store_3(Debug_call, procb, CALL_PORT|FIRST_CALL|LAST_CALL); 592 Store_4d(d_.empty,0,0,0); 593 } 594 Store_i(JmpdP); 595 Store_d(procb); 596 Store_i(Code_end); 597 return save; 598 } 599 else 600 { 601 return procb->code.vmc; /* use the body's code */ 602 } 603} 604 605 606/* 607 tool_(Name/Arity, SourceModule) 608 set the tool flag of Name/Arity in SourceModule. 609*/ 610static int 611p_tool1(value vi, type ti, value vm, type tm) 612{ 613#if 0 614 dident di; 615 pri *proci, *pd; 616 int err; 617 618 Check_Module(tm, vm); 619 Get_Proc_Did(vi, ti, di); 620 621 proci = visible_procedure(di, vm.did, tm, PRI_CREATE); 622 if (!proci) 623 { 624 Get_Bip_Error(err); 625 Bip_Error(err); 626 } 627 if (proci->flags & TOOL) 628 { 629 Succeed_; 630 } 631 err = pri_compatible_flags(proci, TOOL, TOOL); 632 if (err != PSUCCEED) 633 { 634 Bip_Error(err); 635 } 636 pri_change_flags(proci, TOOL, TOOL); 637 if (PriCodeType(proci) == VMCODE) 638 { 639 /* keep the old code, e.g. autoload_code... */ 640 /* update the code header, important for saving the arguments 641 * in the event mechanism */ 642 Incr_Code_Arity(PriCode(proci)); 643 } 644 Succeed_; 645#else 646 Bip_Error(NOT_IMPLEMENTED); 647#endif 648} 649 650 651#define TOOL_INHERIT_FLAGS (CODETYPE|ARGPASSING|EXTERN|UNIFTYPE) 652 653static int 654p_tool2(value vi, type ti, value vb, type tb, value vm, type tm) 655{ 656 dident di, db; 657 pri *procb, *proci; 658 uint32 changed_flags, new_flags; 659 pri_code_t pricode; 660 int err; 661 662 Check_Module(tm, vm); 663 Get_Proc_Did(vi, ti, di); 664 Get_Proc_Did(vb, tb, db); 665 666 if (DidArity(di) + 1 != DidArity(db)) 667 { 668 Bip_Error(RANGE_ERROR); 669 } 670 if (vm.did == d_.kernel_sepia) 671 proci = export_procedure(di, vm.did, tm); 672 else 673 proci = local_procedure(di, vm.did, tm, PRI_CREATE); 674 if (!proci) 675 { 676 Get_Bip_Error(err); 677 Bip_Error(err); 678 } 679 procb = visible_procedure(db, vm.did, tm, PRI_CREATE); 680 if (!procb) 681 { 682 Get_Bip_Error(err); 683 Bip_Error(err); 684 } 685 /* Incompatbilities of being a TOOL */ 686 if (DynamicProc(proci)) 687 { 688 Bip_Error(INCONSISTENCY); 689 } 690 /* Incompatbilities of being a tool body */ 691 if (PriFlags(procb) & TOOL) 692 { 693 Bip_Error(INCONSISTENCY); 694 } 695 changed_flags = TOOL|TOOL_INHERIT_FLAGS|DEBUG_DB|SYSTEM; 696 new_flags = TOOL 697 |(TOOL_INHERIT_FLAGS & procb->flags) 698 |(GlobalFlags & DBGCOMP ? DEBUG_DB : 0) 699 |(vm.did == d_.kernel_sepia ? SYSTEM : 0); 700 err = pri_compatible_flags(proci, changed_flags, new_flags); 701 if (err != PSUCCEED) 702 { 703 Bip_Error(err); 704 } 705 pri_change_flags(proci, changed_flags & ~CODETYPE, new_flags & ~CODETYPE); 706 Pri_Set_Reference(procb); 707 proci->mode = procb->mode; 708 pricode.vmc = _tool_code(procb, GlobalFlags & DBGCOMP); 709 pri_define_code(proci, procb->flags & CODETYPE, pricode); 710 /* make sure the tool body is exported or reexported, so it can 711 * be invoked with a qualified call with lookup module vm */ 712 if (!PriAnyExp(procb) && !PriWillExport(procb)) 713 { 714 if (PriScope(procb) == IMPORT) 715 procb = reexport_procedure(db, vm.did, tm, PriHomeModule(procb)); 716 else 717 procb = export_procedure(db, vm.did, tm); 718 if (!procb) 719 { 720 Get_Bip_Error(err); 721 Bip_Error(err); 722 } 723 } 724 Succeed_; 725} 726 727 728/********************************************************************* 729 V I S I B I L I T Y C H A N G E 730**********************************************************************/ 731 732/* 733 Add 'module' to the chain of module pointed to by '*scan'. 734 The module is added at the beginning of the chain. 735 A reference of '*scan' is passed (**scan) to be able to modify it. 736*/ 737static void 738_add_module(dident module, didlist **start) 739{ 740 didlist *new_mod; 741 742 new_mod = (didlist *) hg_alloc_size(sizeof(didlist)); 743 new_mod->name = module; 744 new_mod->next = *start; 745 *start = new_mod; 746} 747 748 749/* The following builtins use the global error variable ! */ 750#undef Bip_Error 751#define Bip_Error(N) Bip_Error_Fail(N) 752 753 754/* 755 * Implicit local declaration, 756 * used by the compiler to prepare for the subsequent definition of a predicate 757 */ 758 759static int 760p_implicit_local(value v, type t, value vm, type tm) 761{ 762 dident d; 763 764 Check_Module(tm, vm); 765 Get_Proc_Did(v, t, d); 766 767 if (!local_procedure(d, vm.did, tm, PRI_CREATE)) 768 { 769 Fail_; /* with bip_error */ 770 } 771 Succeed_; 772} 773 774 775static int 776p_local(value v, type t, value vm, type tm) 777{ 778 dident d; 779 pri *proc; 780 int err; 781 782 Check_Module(tm, vm); 783 Get_Proc_Did(v, t, d); 784 785 proc = local_procedure(d, vm.did, tm, PRI_CREATE|PRI_DONTWARN); 786 if (!proc) 787 { 788 Get_Bip_Error(err); 789 Bip_Error(err); 790 } 791 Succeed_; 792} 793 794static int 795p_export(value v, type t, value vm, type tm) 796{ 797 dident d; 798 pri *proc; 799 int err; 800 801 Check_Module(tm, vm); 802 Get_Proc_Did(v, t, d); 803 804 proc = export_procedure(d, vm.did, tm); 805 if (!proc) 806 { 807 Get_Bip_Error(err); 808 Bip_Error(err); 809 } 810 Succeed_; 811} 812 813 814static int 815p_import_from(value vim, type tim, value v, type t, value vm, type tm) 816{ 817 dident d; 818 pri *proc, *export; 819 int err; 820 821 Check_Atom_Or_Nil(vim, tim); 822 Check_Module(tm, vm); 823 Get_Proc_Did(v, t, d); 824 825 proc = import_procedure(d, vm.did, tm, vim.did); 826 if (!proc) 827 { 828 Get_Bip_Error(err); 829 Bip_Error(err); 830 } 831 Succeed_; 832} 833 834 835static int 836p_reexport_from(value vim, type tim, value v, type t, value vm, type tm) 837{ 838 dident d; 839 pri *proc, *export; 840 int err; 841 842 Check_Atom_Or_Nil(vim, tim); 843 Check_Module(tm, vm); 844 Get_Proc_Did(v, t, d); 845 846 proc = reexport_procedure(d, vm.did, tm, vim.did); 847 if (!proc) 848 { 849 Get_Bip_Error(err); 850 Bip_Error(err); 851 } 852 Succeed_; 853} 854 855 856/* 857 import_(+Lib, +Import_mod) 858 Put Library in the 'imports' list of Import_mod 859*/ 860 861/*ARGSUSED*/ 862static int 863p_import(value library, type tlib, value import_mod, type tim) 864{ 865 module_item *export_prop, *import_prop; 866 pri *pe, *pi; 867 didlist *lib_scan; 868 869 Check_Module_And_Access(import_mod, tim); 870 Check_Module(tlib, library); 871 872 a_mutex_lock(&ModuleLock); 873 874 export_prop = ModuleItem(library.did); 875 import_prop = ModuleItem(import_mod.did); 876 877 /* check that the module is not already imported */ 878 lib_scan = import_prop->imports; 879 while (lib_scan) 880 { 881 if (lib_scan->name == library.did) 882 { 883 a_mutex_unlock(&ModuleLock); 884 Succeed_; /* the library is already imported */ 885 } 886 lib_scan = lib_scan->next; 887 } 888 889 /* add library to the lists of the mods imported by import_mod */ 890 _add_module(library.did, &(import_prop->imports)); 891 892 /* now perform the pending imports */ 893 resolve_pending_imports(import_prop->procedures); 894 895 a_mutex_unlock(&ModuleLock); 896 Succeed_; 897} 898 899 900void 901delete_duet_from_chain(dident the_name, didlist **chain) 902{ 903 didlist *current_duet; 904 905 current_duet = *chain; 906 while(current_duet) 907 { 908 if (current_duet->name == the_name) 909 { 910 *chain = current_duet->next; 911 hg_free_size((generic_ptr) current_duet, sizeof(didlist)); 912 break; 913 } 914 chain = &(current_duet->next); 915 current_duet = current_duet->next; 916 } 917} 918 919static int 920p_erase_module(value module, type module_tag, value from_mod, type tfrom_mod) 921{ 922 module_item *pm, *import_pm; 923 int i; 924 didlist *lib_scan; 925 pword *prop; 926 927 Check_Module(tfrom_mod, from_mod); 928 929 Check_Atom_Or_Nil(module, module_tag); 930 if (!IsModule(module.did)) 931 { 932 Succeed_; 933 } else if (IsLocked(module.did) 934 && (from_mod.did != d_.kernel_sepia 935 || !IsModuleTag(from_mod.did, tfrom_mod))) 936 { 937 Bip_Error(LOCKED); 938 } 939 940 /* 941 * This is a big mess with respect to locking. The erased module's 942 * descriptor is unprotected. It should be first removed as property 943 * and then cleaned up. 944 */ 945 946 pm = ModuleItem(module.did); 947 948 /* first, clean the procedures, we can reclaim the space */ 949 erase_module_procs(pm->procedures); 950 951 hg_free_size((generic_ptr) pm->syntax, sizeof(syntax_desc)); 952 953 /* reclaim the properties */ 954 955 erase_module_props(pm->properties); 956 957 /* reclaim module descriptor */ 958 959 (void) erase_property(module.did, MODULE_PROP); 960 961 DidPtr(module.did)->module = 0; 962 963 Succeed_; 964} 965 966/* 967 * Return a safe module for use in system predicates. 968 */ 969/*ARGSUSED*/ 970static int 971p_module_tag(value vm, type tm, value vs, type ts) 972{ 973 type t; 974 975 t.kernel = ModuleTag(vm.did); 976 Return_Unify_Pw(vs, ts, vm, t) 977} 978