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