1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 #include "pl-incl.h"
38 #include "pl-comp.h"
39 #undef LD
40 #define LD LOCAL_LD
41
42 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
43 Definition of modules. A module consists of a set of predicates. A
44 predicate can be private or public. By default predicates are private.
45 A module contains two hash tables. One that holds all predicates and
46 one that holds the public predicates of the module.
47
48 On trapping undefined predicates SWI-Prolog attempts to import the
49 predicate from the super module of the module. The module `system'
50 holds all system predicates and has no super module. Module `user' is
51 the global module for the user and imports from `system' all other
52 modules import from `user' (and indirect from `system').
53 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
54
55 static int addSuperModule_no_lock(Module m, Module s, int where);
56 static void unallocModule(Module m);
57 static void unlinkSourceFilesModule(Module m);
58
59 static void
unallocProcedureSymbol(void * name,void * value)60 unallocProcedureSymbol(void *name, void *value)
61 { DEBUG(MSG_CLEANUP,
62 Sdprintf("unallocProcedure(%s)\n", functorName((functor_t)name)));
63 unallocProcedure(value);
64 }
65
66
67 static Module
_lookupModule(atom_t name ARG_LD)68 _lookupModule(atom_t name ARG_LD)
69 { Module m, super;
70
71 if ( (m = lookupHTable(GD->tables.modules, (void*)name)) )
72 return m;
73
74 DEBUG(MSG_CREATE_MODULE,
75 { Sdprintf("Creating module %s:\n%s",
76 PL_atom_chars(name),
77 PL_backtrace_string(10,0));
78 });
79
80 m = allocHeapOrHalt(sizeof(struct module));
81 memset(m, 0, sizeof(*m));
82
83 m->name = name;
84 #ifdef O_PLMT
85 m->mutex = allocSimpleMutex(PL_atom_chars(m->name));
86 #endif
87 set(m, M_CHARESCAPE);
88 if ( !GD->options.traditional )
89 set(m, DBLQ_STRING|BQ_CODES|O_RATIONAL_SYNTAX);
90
91 if ( name == ATOM_user || name == ATOM_system )
92 m->procedures = newHTable(PROCEDUREHASHSIZE);
93 else
94 m->procedures = newHTable(MODULEPROCEDUREHASHSIZE);
95 m->procedures->free_symbol = unallocProcedureSymbol;
96
97 m->public = newHTable(PUBLICHASHSIZE);
98 m->class = ATOM_user;
99
100 if ( name == ATOM_user )
101 { super = MODULE_system;
102 } else if ( name == ATOM_system )
103 { set(m, M_SYSTEM|UNKNOWN_ERROR);
104 super = NULL;
105 m->class = ATOM_system;
106 } else if ( stringAtom(name)[0] == '$' )
107 { set(m, M_SYSTEM);
108 super = MODULE_system;
109 m->class = ATOM_system;
110 } else
111 { super = MODULE_user;
112 }
113
114 if ( super ) /* TBD: Better error-handling */
115 { if ( !addSuperModule_no_lock(m, super, 'A') )
116 PL_warning("Could not add super-module");
117 }
118
119 addNewHTable(GD->tables.modules, (void *)name, m);
120 GD->statistics.modules++;
121 PL_register_atom(name);
122
123 return m;
124 }
125
126
127 Module
lookupModule__LD(atom_t name ARG_LD)128 lookupModule__LD(atom_t name ARG_LD)
129 { Module m;
130
131 if ( (m = lookupHTable(GD->tables.modules, (void*)name)) )
132 return m;
133
134 PL_LOCK(L_MODULE);
135 m = _lookupModule(name PASS_LD);
136 PL_UNLOCK(L_MODULE);
137
138 return m;
139 }
140
141
142 Module
isCurrentModule__LD(atom_t name ARG_LD)143 isCurrentModule__LD(atom_t name ARG_LD)
144 { return lookupHTable(GD->tables.modules, (void*)name);
145 }
146
147
148 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
149 acquireModule()/releaseModule() must be used for module pointers that
150 may refer to a temporary module from a thread that is not the temporary
151 module thread ifself. These functions cooperate with destroyModule() to
152 ensure the module is not destroyed prematurely.
153
154 Currently this is used for the following. Ultimately we need module GC
155 or more comprehensive usage of this interface to safely support
156 temporary modules.
157
158 - current_op/3 to facilitate using the Pengine operators for
159 rendering results.
160 - current_predicate/1, which no longer enumerates through
161 temporary modules.
162 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
163
164 Module
acquireModule__LD(atom_t name ARG_LD)165 acquireModule__LD(atom_t name ARG_LD)
166 { Module m;
167
168 PL_LOCK(L_MODULE);
169 m = lookupHTable(GD->tables.modules, (void*)name);
170 if ( m && m->class == ATOM_temporary )
171 m->references++;
172 PL_UNLOCK(L_MODULE);
173
174 return m;
175 }
176
177 void
releaseModule(Module m)178 releaseModule(Module m)
179 { if ( m->class == ATOM_temporary )
180 { PL_LOCK(L_MODULE);
181 if ( --m->references == 0 &&
182 true(m, M_DESTROYED) )
183 { unlinkSourceFilesModule(m);
184 GD->statistics.modules--;
185 PL_unregister_atom(m->name);
186 unallocModule(m);
187 }
188 PL_UNLOCK(L_MODULE);
189 }
190 }
191
192
193 ModuleEnum
newModuleEnum(int flags)194 newModuleEnum(int flags)
195 { ModuleEnum en = malloc(sizeof(*en));
196
197 if ( en )
198 { if ( (en->tenum = newTableEnum(GD->tables.modules)) )
199 { en->current = NULL;
200 en->flags = flags;
201 } else
202 { free(en);
203 en = NULL;
204 }
205 }
206
207 return en;
208 }
209
210 Module
advanceModuleEnum(ModuleEnum en)211 advanceModuleEnum(ModuleEnum en)
212 { void *v;
213 Module m = NULL;
214
215 PL_LOCK(L_MODULE);
216 for(;;)
217 { if ( advanceTableEnum(en->tenum, NULL, &v) )
218 m = v;
219 else
220 m = NULL;
221
222 if ( m && m->class == ATOM_temporary )
223 { if ( (en->flags&MENUM_TEMP) )
224 { m->references++;
225 if ( en->current )
226 releaseModule(en->current);
227 en->current = m;
228 } else
229 continue;
230 }
231
232 break;
233 }
234 PL_UNLOCK(L_MODULE);
235
236 return m;
237 }
238
239 void
freeModuleEnum(ModuleEnum en)240 freeModuleEnum(ModuleEnum en)
241 { freeTableEnum(en->tenum);
242 if ( en->current )
243 releaseModule(en->current);
244 free(en);
245 }
246
247
248 static void
unallocModuleSymbol(void * name,void * value)249 unallocModuleSymbol(void *name, void *value)
250 { unallocModule(value);
251 }
252
253
254 void
initModules(void)255 initModules(void)
256 { GET_LD
257 PL_LOCK(L_MODULE);
258 if ( !GD->tables.modules )
259 {
260 #ifdef O_PLMT
261 initPrologThreads();
262 #endif
263 initFunctors();
264
265 GD->tables.modules = newHTable(MODULEHASHSIZE);
266 GD->tables.modules->free_symbol = unallocModuleSymbol;
267 GD->modules.system = _lookupModule(ATOM_system PASS_LD);
268 GD->modules.user = _lookupModule(ATOM_user PASS_LD);
269 }
270 PL_UNLOCK(L_MODULE);
271 }
272
273
274 static void
unallocList(ListCell c)275 unallocList(ListCell c)
276 { ListCell n;
277
278 for(; c; c=n)
279 { n = c->next;
280
281 freeHeap(c, sizeof(*c));
282 }
283 }
284
285
286 static void
freeLingeringDefinitions(ListCell c)287 freeLingeringDefinitions(ListCell c)
288 { ListCell n;
289
290 for(; c; c=n)
291 { Definition def = c->value;
292
293 n = c->next;
294 freeHeap(def, sizeof(*def));
295 freeHeap(c, sizeof(*c));
296 }
297 }
298
299
300 static void
unallocModule(Module m)301 unallocModule(Module m)
302 { GET_LD
303
304 #ifdef O_PLMT
305 if ( LD )
306 #endif
307 { if ( LD->modules.source == m ) LD->modules.source = MODULE_user;
308 if ( LD->modules.typein == m ) LD->modules.typein = MODULE_user;
309 }
310
311 if ( m->public ) destroyHTable(m->public);
312 if ( m->procedures ) destroyHTable(m->procedures);
313 if ( m->operators ) destroyHTable(m->operators);
314 if ( m->supers ) unallocList(m->supers);
315 #ifdef O_PLMT
316 if ( m->mutex ) freeSimpleMutex(m->mutex);
317 #endif
318 if ( m->lingering ) freeLingeringDefinitions(m->lingering);
319
320 freeHeap(m, sizeof(*m));
321 }
322
323
324 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
325 Remove all links from the source file administration to the given
326 module. Such links are added by addProcedureSourceFile(). In theory, the
327 relation between procedure and source file is many-to-many, but most of
328 the time it is one-to-one. In that case, proc->source_no points to the
329 one source file. Otherwise (multiple files), PROC_MULTISOURCE is set and
330 we need to scan all source files to find the references.
331
332 This is fine for the current schema of destroying temporary modules,
333 which are typically not supposed to use constructs such as multifile
334 anyway. The alternative is for procedures to maintain a list of
335 back-links to the source files.
336 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
337
338 static void
markSourceFilesProcedure(Procedure proc,struct bit_vector * v)339 markSourceFilesProcedure(Procedure proc, struct bit_vector *v)
340 { if ( false(proc, PROC_MULTISOURCE) )
341 set_bit(v, proc->source_no);
342 else
343 setall_bitvector(v);
344 }
345
346
347 static void
unlinkSourceFilesModule(Module m)348 unlinkSourceFilesModule(Module m)
349 { size_t i, high = highSourceFileIndex();
350 struct bit_vector *vec = new_bitvector(high+1);
351 SourceFile sf;
352
353 for_table(m->procedures, name, value,
354 markSourceFilesProcedure(value, vec));
355
356 for(i=1; i<=high; i++)
357 { if ( true_bit(vec, i) )
358 { SourceFile sf = indexToSourceFile(i);
359
360 if ( sf )
361 unlinkSourceFileModule(sf, m);
362 }
363 }
364
365 free_bitvector(vec);
366
367 if ( (sf = m->file) )
368 { m->file = NULL;
369 releaseSourceFile(sf);
370 }
371 }
372
373
374 static int
destroyModule(Module m)375 destroyModule(Module m)
376 { if ( !(m->class != ATOM_temporary ||
377 m->references > 0) )
378 Sdprintf("Module %s: class %s; refs %d\n",
379 PL_atom_chars(m->name), PL_atom_chars(m->class), m->references);
380
381 PL_LOCK(L_MODULE);
382 if ( deleteHTable(GD->tables.modules, (void*)m->name) == m )
383 set(m, M_DESTROYED);
384 #ifndef NDEBUG
385 { GET_LD
386 assert(!lookupHTable(GD->tables.modules, (void*)m->name));
387 }
388 #endif
389 PL_UNLOCK(L_MODULE);
390
391 releaseModule(m);
392 return TRUE;
393 }
394
395
396 static void
emptyModule(Module m)397 emptyModule(Module m)
398 { DEBUG(MSG_CLEANUP, Sdprintf("emptyModule(%s)\n", PL_atom_chars(m->name)));
399 if ( m->procedures ) clearHTable(m->procedures);
400 }
401
402
403 void
cleanupModules(void)404 cleanupModules(void)
405 { Table t;
406
407 if ( (t=GD->tables.modules) )
408 { for_table(t, name, value, emptyModule(value));
409
410 GD->tables.modules = NULL;
411 destroyHTable(t);
412 }
413 }
414
415
416 int
isSuperModule(Module s,Module m)417 isSuperModule(Module s, Module m) /* s is a super-module of m */
418 { ListCell c;
419
420 next:
421 if ( m == s )
422 succeed;
423
424 for(c=m->supers; c; c=c->next)
425 { if ( c->next )
426 { if ( isSuperModule(s, c->value) )
427 succeed;
428 } else
429 { m = c->value;
430 goto next;
431 }
432 }
433 fail;
434 }
435
436
437 /* MT: Must be locked by caller
438 */
439
440 /* The `level' of a module is the shortest path to the root of the
441 module-tree. The level information is used by pl-arith.c.
442
443 TBD: We should check for cycles when adding super-modules!
444 */
445
446 static void
updateLevelModule(Module m)447 updateLevelModule(Module m)
448 { int l = -1;
449 ListCell c;
450
451 for(c=m->supers; c; c=c->next)
452 { Module m2 = c->value;
453
454 if ( m2->level > l )
455 l = m2->level;
456 }
457
458 m->level = l+1;
459 }
460
461
462 static int
cannotSetSuperModule(Module m,Module s)463 cannotSetSuperModule(Module m, Module s)
464 { GET_LD
465 term_t t = PL_new_term_ref();
466 (void)s; /* would be nice to add to message */
467
468 PL_put_atom(t, m->name);
469
470 return PL_error(NULL, 0, "would create a cycle",
471 ERR_PERMISSION,
472 ATOM_add_import,
473 ATOM_module,
474 t);
475 }
476
477
478 static int
reachableModule(Module here,Module end)479 reachableModule(Module here, Module end)
480 { if ( here != end )
481 { ListCell c;
482
483 for(c=here->supers; c; c=c->next)
484 { if ( reachableModule(c->value, end) )
485 succeed;
486 }
487
488 fail;
489 }
490
491 succeed;
492 }
493
494
495
496 static int
addSuperModule_no_lock(Module m,Module s,int where)497 addSuperModule_no_lock(Module m, Module s, int where)
498 { ListCell c;
499
500 if ( reachableModule(s, m) )
501 return cannotSetSuperModule(m, s);
502
503 for(c=m->supers; c; c=c->next)
504 { if ( c->value == s )
505 return TRUE; /* already a super-module */
506 }
507
508 c = allocHeapOrHalt(sizeof(*c));
509 c->value = s;
510
511 if ( where == 'A' )
512 { c->next = m->supers;
513 m->supers = c;
514 } else
515 { ListCell *p = &m->supers;
516
517 while(*p)
518 { p = &(*p)->next;
519 }
520 c->next = NULL;
521 *p = c;
522 }
523
524 updateLevelModule(m);
525 succeed;
526 }
527
528
529 int
addSuperModule(Module m,Module s,int where)530 addSuperModule(Module m, Module s, int where)
531 { int rc;
532
533 PL_LOCK(L_MODULE);
534 rc = addSuperModule_no_lock(m, s, where);
535 PL_UNLOCK(L_MODULE);
536
537 return rc;
538 }
539
540
541 static int
delSuperModule(Module m,Module s)542 delSuperModule(Module m, Module s)
543 { ListCell *p;
544
545 for(p = &m->supers; *p; p = &(*p)->next)
546 { ListCell c = *p;
547
548 if ( c->value == s )
549 { *p = c->next;
550 freeHeap(c, sizeof(*c));
551
552 updateLevelModule(m);
553 succeed;
554 }
555 }
556
557 fail;
558 }
559
560
561 static void
clearSupersModule_no_lock(Module m)562 clearSupersModule_no_lock(Module m)
563 { ListCell c = m->supers;
564 ListCell next;
565
566 m->supers = NULL;
567 for(; c; c=next)
568 { next = c->next;
569 freeHeap(c, sizeof(*c));
570 }
571
572 m->level = 0;
573 }
574
575 void
clearSupersModule(Module m)576 clearSupersModule(Module m)
577 { PL_LOCK(L_MODULE);
578 clearSupersModule_no_lock(m);
579 PL_UNLOCK(L_MODULE);
580 }
581
582
583 int
setSuperModule(Module m,Module s)584 setSuperModule(Module m, Module s)
585 { if ( s == m )
586 cannotSetSuperModule(m, s);
587
588 if ( m->supers && !m->supers->next )
589 { if ( (Module)m->supers->value != s )
590 { m->supers->value = s;
591 m->level = s->level+1;
592
593 succeed;
594 }
595 }
596 clearSupersModule_no_lock(m);
597
598 return addSuperModule_no_lock(m, s, 'A');
599 }
600
601
602 static int
set_module(Module m,term_t prop ARG_LD)603 set_module(Module m, term_t prop ARG_LD)
604 { atom_t pname;
605 size_t arity;
606
607 if ( PL_get_name_arity(prop, &pname, &arity) && arity == 1 )
608 { term_t arg = PL_new_term_ref();
609
610 _PL_get_arg(1, prop, arg);
611
612 if ( pname == ATOM_base )
613 { atom_t mname;
614
615 if ( !PL_get_atom_ex(arg, &mname) )
616 return FALSE;
617
618 return setSuperModule(m, _lookupModule(mname PASS_LD));
619 } else if ( pname == ATOM_class )
620 { atom_t class;
621
622 if ( !PL_get_atom_ex(arg, &class) )
623 return FALSE;
624 if ( class == ATOM_user ||
625 class == ATOM_system ||
626 class == ATOM_library ||
627 class == ATOM_test ||
628 class == ATOM_development )
629 { m->class = class;
630 return TRUE;
631 } else if ( class == ATOM_temporary )
632 { Table procs;
633
634 if ( m->class == ATOM_user &&
635 !((procs=m->procedures) && procs->size != 0) )
636 { m->class = class;
637 } else
638 { return PL_error(NULL, 0,
639 m->class != ATOM_user ? "Not a user module" :
640 "module is not empty",
641 ERR_PERMISSION, ATOM_module_property, ATOM_class, arg);
642 }
643 return TRUE;
644 } else
645 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_module_class, arg);
646 } else if ( pname == ATOM_program_space )
647 { size_t limit;
648
649 if ( !PL_get_size_ex(arg, &limit) )
650 return FALSE;
651 if ( limit && limit < m->code_size )
652 { term_t ex = PL_new_term_ref();
653
654 PL_put_atom(ex, m->name);
655 return PL_error(NULL, 0, "Used exceeds limit", ERR_PERMISSION,
656 ATOM_limit, ATOM_program_space, ex);
657 }
658 m->code_limit = limit;
659 return TRUE;
660 } else
661 { return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_module_property, prop);
662 }
663 } else
664 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_module_property, prop);
665 }
666
667
668 static
669 PRED_IMPL("set_module", 1, set_module, PL_FA_TRANSPARENT)
670 { PRED_LD
671 Module m;
672 term_t prop = PL_new_term_ref();
673 atom_t mname = 0;
674 Word p;
675 int rc;
676
677 if ( !(p=stripModuleName(valTermRef(A1), &mname PASS_LD)) )
678 return FALSE;
679 *valTermRef(prop) = linkVal(p);
680
681 PL_LOCK(L_MODULE);
682 m = mname ? _lookupModule(mname PASS_LD) : MODULE_parse;
683 rc = set_module(m, prop PASS_LD);
684 PL_UNLOCK(L_MODULE);
685
686 return rc;
687 }
688
689
690 static int
inheritUnknown(Module m)691 inheritUnknown(Module m)
692 { int u;
693 ListCell c;
694
695 if ( (u = (m->flags & UNKNOWN_MASK)) )
696 return u;
697
698 for(c = m->supers; c; c=c->next)
699 { if ( (u = getUnknownModule(c->value)) )
700 return u;
701 }
702
703 return 0;
704 }
705
706
707 int /* one of UNKNOWN_ERROR, UNKNOWN_WARNING, UNKNOWN_FAIL */
getUnknownModule(Module m)708 getUnknownModule(Module m)
709 { int u = inheritUnknown(m);
710
711 if ( !u )
712 u = UNKNOWN_ERROR;
713
714 return u;
715 }
716
717 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
718 stripModuleName() takes an atom or term, possible embedded in the :/2
719 module term. It assigns *name with the associated module names. The
720 return value is the plain term or NULL if `term` is cyclic.
721 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
722
723 Word
stripModuleName(Word term,atom_t * name ARG_LD)724 stripModuleName(Word term, atom_t *name ARG_LD)
725 { int depth = 100;
726 deRef(term);
727 atom_t nm = 0;
728
729 while( hasFunctor(*term, FUNCTOR_colon2) )
730 { Word mp;
731 mp = argTermP(*term, 0);
732 deRef(mp);
733 if ( !isTextAtom(*mp) )
734 break;
735 nm = *mp;
736 term = argTermP(*term, 1);
737 deRef(term);
738 if ( --depth == 0 && !is_acyclic(term PASS_LD) )
739 { term_t t = pushWordAsTermRef(term);
740 PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_acyclic_term, t);
741 popTermRef();
742 return NULL;
743 }
744 }
745
746 if ( nm )
747 *name = nm;
748
749 return term;
750 }
751
752
753 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
754 stripModule() takes an atom or term, possible embedded in the :/2 module
755 term. It will assign *module with the associated module and return the
756 remaining term.
757 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
758
759 Word
stripModule(Word term,Module * module,int flags ARG_LD)760 stripModule(Word term, Module *module, int flags ARG_LD)
761 { atom_t mname = 0;
762 Word rc;
763
764 if ( (rc=stripModuleName(term, &mname PASS_LD)) )
765 { if ( mname )
766 { if ( unlikely(flags&SM_NOCREATE) )
767 { Module m;
768
769 if ( (m=isCurrentModule(mname)) )
770 *module = m;
771 else
772 return NULL;
773 } else
774 { *module = lookupModule(mname);
775 }
776 } else
777 { *module = (environment_frame ? contextModule(environment_frame)
778 : MODULE_user);
779 }
780 }
781
782 return rc;
783 }
784
785
786 bool
isPublicModule(Module module,Procedure proc)787 isPublicModule(Module module, Procedure proc)
788 { GET_LD
789 if ( lookupHTable(module->public,
790 (void *)proc->definition->functor->functor) )
791 succeed;
792
793 fail;
794 }
795
796
797 /********************************
798 * PROLOG CONNECTION *
799 *********************************/
800
801 static int
get_module(term_t t,Module * m,int create)802 get_module(term_t t, Module *m, int create)
803 { GET_LD
804 atom_t name;
805
806 if ( !PL_get_atom_ex(t, &name) )
807 fail;
808 if ( create )
809 { *m = lookupModule(name);
810 succeed;
811 }
812 if ( (*m = isCurrentModule(name)) )
813 succeed;
814 fail;
815 }
816
817 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
818 Note that this predicate uses integers to avoid crashes due to changes
819 to the linked list while processing. This leads to quadratic behaviour,
820 but given the low number of supers this shouldn't be too bad.
821
822 import_module
823 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
824
825 static
826 PRED_IMPL("import_module", 2, import_module,
827 PL_FA_NONDETERMINISTIC)
828 { PRED_LD
829 int i, n;
830 ListCell c;
831 Module m;
832
833 switch(ForeignControl(PL__ctx))
834 { case FRG_FIRST_CALL:
835 i = 0;
836 break;
837 case FRG_REDO:
838 i = (int)ForeignContextInt(PL__ctx);
839 break;
840 default:
841 succeed;
842 }
843
844 if ( !get_module(A1, &m, TRUE) )
845 fail;
846
847 for(n=0, c=m->supers; c; c=c->next, n++)
848 { Module s = c->value;
849
850 if ( n == i )
851 { int ndet = c->next != NULL && PL_is_variable(A2);
852
853 if ( PL_unify_atom(A2, s->name) )
854 { if ( ndet )
855 ForeignRedoInt(i+1);
856 else
857 succeed;
858 }
859 }
860 }
861
862 fail;
863 }
864
865
866 static
867 PRED_IMPL("add_import_module", 3, add_import_module, 0)
868 { PRED_LD
869 Module me, super;
870 atom_t where;
871
872 if ( !get_module(A1, &me, TRUE) ||
873 !get_module(A2, &super, TRUE) ||
874 !PL_get_atom_ex(A3, &where) )
875 fail;
876
877 return addSuperModule(me, super, where == ATOM_start ? 'A' : 'Z');
878 }
879
880
881 static
882 PRED_IMPL("delete_import_module", 2, delete_import_module, 0)
883 { Module me, super;
884 int rval;
885
886 if ( !get_module(A1, &me, TRUE) ||
887 !get_module(A2, &super, TRUE) )
888 fail;
889
890 PL_LOCK(L_MODULE);
891 rval = delSuperModule(me, super);
892 PL_UNLOCK(L_MODULE);
893
894 return rval;
895 }
896
897
898 static int
get_existing_source_file(term_t file,SourceFile * sfp ARG_LD)899 get_existing_source_file(term_t file, SourceFile *sfp ARG_LD)
900 { SourceFile sf;
901 atom_t a;
902
903 if ( PL_get_atom(file, &a) )
904 { if ( (sf = lookupSourceFile(a, FALSE)) )
905 { *sfp = sf;
906 return TRUE;
907 }
908
909 return FALSE;
910 }
911
912 *sfp = NULL;
913 return TRUE;
914 }
915
916
917 /** '$current_module'(+Module, -File) is semidet.
918 '$current_module'(-ModuleOrList, +File) is semidet.
919 '$current_module'(-Module, -File) is nondet.
920
921 Query module<->file association. This association is N:1 in SWI-Prolog.
922 Think e.g., of test-units that are mapped to modules. When used in mode
923 (-, +), this predicate unifies Module with a non-empty list if the file
924 is associated to multiple modules.
925 */
926
927 static
928 PRED_IMPL("$current_module", 2, current_module, PL_FA_NONDETERMINISTIC)
929 { PRED_LD
930 ModuleEnum e;
931 Module m;
932 atom_t name;
933 SourceFile sf = NULL;
934
935 term_t module = A1;
936 term_t file = A2;
937
938 switch(CTX_CNTRL)
939 { case FRG_FIRST_CALL:
940 /* deterministic case: module --> file */
941 if ( PL_get_atom(module, &name) )
942 { Module m;
943
944 if ( (m=isCurrentModule(name)) )
945 { atom_t f = (!m->file ? ATOM_nil : m->file->name);
946 return PL_unify_atom(file, f);
947 }
948
949 return FALSE;
950 }
951
952 if ( !get_existing_source_file(file, &sf PASS_LD) )
953 return FALSE; /* given, but non-existing file */
954
955 if ( sf )
956 { int rc = FALSE;
957
958 if ( sf->modules )
959 { PL_LOCK(L_PREDICATE);
960 if ( sf->modules->next )
961 { term_t tail = PL_copy_term_ref(module);
962 term_t head = PL_new_term_ref();
963 ListCell c;
964
965 for(c=sf->modules; c; c=c->next)
966 { Module m = c->value;
967
968 if ( !(PL_unify_list(tail, head, tail) &&
969 PL_unify_atom(head, m->name)) )
970 goto out;
971 }
972 rc = PL_unify_nil(tail);
973 } else
974 { Module m = sf->modules->value;
975 rc = PL_unify_atom(module, m->name);
976 }
977
978 out:
979 PL_UNLOCK(L_PREDICATE);
980 }
981 releaseSourceFile(sf);
982
983 return rc; /* source-file has no modules */
984 }
985
986 if ( !(e = newModuleEnum(0)) )
987 return PL_no_memory();
988 break;
989 case FRG_REDO:
990 e = CTX_PTR;
991 break;
992 case FRG_CUTTED:
993 e = CTX_PTR;
994 freeModuleEnum(e);
995 succeed;
996 default:
997 assert(0);
998 return FALSE;
999 }
1000
1001 /* mode (-,-) */
1002
1003 while( (m=advanceModuleEnum(e)) )
1004 { atom_t f = ( !m->file ? ATOM_nil : m->file->name);
1005
1006 if ( m->class == ATOM_system && m->name != ATOM_system &&
1007 !SYSTEM_MODE && PL_is_variable(module) )
1008 continue;
1009
1010 if ( PL_unify_atom(module, m->name) &&
1011 PL_unify_atom(file, f) )
1012 ForeignRedoPtr(e);
1013
1014 break; /* must be an error */
1015 }
1016
1017 freeModuleEnum(e);
1018 return FALSE;
1019 }
1020
1021
1022 static
1023 PRED_IMPL("strip_module", 3, strip_module, PL_FA_TRANSPARENT)
1024 { GET_LD
1025 Module m = (Module) NULL;
1026 term_t plain;
1027
1028 if ( (plain = PL_new_term_ref()) &&
1029 PL_strip_module(A1, &m, plain) &&
1030 PL_unify_atom(A2, m->name) &&
1031 PL_unify(A3, plain) )
1032 succeed;
1033
1034 fail;
1035 }
1036
1037
1038 static
1039 PRED_IMPL("$current_typein_module", 1, current_typein_module, 0)
1040 { PRED_LD
1041
1042 return PL_unify_atom(A1, LD->modules.typein->name);
1043 }
1044
1045 static
1046 PRED_IMPL("$set_typein_module", 1, set_typein_module, 0)
1047 { PRED_LD
1048 atom_t name;
1049
1050 if ( !PL_get_atom_ex(A1, &name) )
1051 return FALSE;
1052
1053 LD->modules.typein = lookupModule(name);
1054 return TRUE;
1055 }
1056
1057 static
1058 PRED_IMPL("$current_source_module", 1, current_source_module, 0)
1059 { PRED_LD
1060
1061 return PL_unify_atom(A1, LD->modules.source->name);
1062 }
1063
1064
1065 PRED_IMPL("$set_source_module", 1, set_source_module, 0)
1066 { PRED_LD
1067 atom_t name;
1068
1069 if ( !PL_get_atom_ex(A1, &name) )
1070 return FALSE;
1071
1072 LD->modules.source = lookupModule(name);
1073 return TRUE;
1074 }
1075
1076
1077 #ifdef O_PROLOG_HOOK
1078 word
pl_set_prolog_hook(term_t module,term_t old,term_t new)1079 pl_set_prolog_hook(term_t module, term_t old, term_t new)
1080 { Module m;
1081 atom_t mname;
1082
1083 if ( !PL_get_atom(module, &mname) )
1084 PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, module);
1085 m = lookupModule(mname);
1086
1087 if ( m->hook )
1088 { if ( !unify_definition(MODULE_user, old, m->hook->definition, 0, GP_HIDESYSTEM) )
1089 return FALSE;
1090 } else
1091 { if ( !PL_unify_nil(old) )
1092 return FALSE;
1093 }
1094
1095 if ( PL_get_nil(new) )
1096 { m->hook = NULL;
1097 return TRUE;
1098 } else
1099 return get_procedure(new, &m->hook, 0, GP_NAMEARITY|GP_CREATE);
1100 }
1101 #endif
1102
1103
1104 typedef struct defm_target
1105 { term_t pi; /* user supplied predicate indicator */
1106 functor_t functor; /* functor associated to the above */
1107 } defm_target;
1108
1109
1110 static int
find_modules_with_defs(Module m,int count,defm_target targets[],term_t tmp,term_t mlist,int l ARG_LD)1111 find_modules_with_defs(Module m, int count, defm_target targets[],
1112 term_t tmp, term_t mlist,
1113 int l ARG_LD)
1114 { ListCell c;
1115 int i;
1116 int found = FALSE;
1117 term_t mhead = tmp+0;
1118 term_t plist = tmp+1;
1119 term_t phead = tmp+2;
1120
1121 DEBUG(9, Sdprintf("Trying %s\n", PL_atom_chars(m->name)));
1122
1123 if ( l < 0 )
1124 { sysError("OOPS loop in default modules???\n");
1125 return FALSE;
1126 }
1127
1128 for(i=0; i<count; i++)
1129 { Procedure proc;
1130
1131 if ( (proc = isCurrentProcedure(targets[i].functor, m)) &&
1132 proc->definition->impl.any.defined )
1133 { if ( !found )
1134 { found = TRUE;
1135 PL_put_variable(plist);
1136 if ( !PL_unify_list(mlist, mhead, mlist) ||
1137 !PL_unify_term(mhead, PL_FUNCTOR, FUNCTOR_minus2,
1138 PL_ATOM, m->name,
1139 PL_TERM, plist) )
1140 return FALSE;
1141 }
1142
1143 if ( !PL_unify_list(plist, phead, plist) ||
1144 !PL_unify(phead, targets[i].pi) )
1145 return FALSE;
1146 }
1147 }
1148 if ( found && !PL_unify_nil(plist) )
1149 return FALSE;
1150
1151 for(c = m->supers; c; c=c->next)
1152 { Module s = c->value;
1153
1154 if ( !find_modules_with_defs(s, count, targets, tmp, mlist, l-1 PASS_LD) )
1155 return FALSE;
1156 }
1157
1158 return TRUE;
1159 }
1160
1161
1162 /** '$def_modules'(:list(PI), -list(Pair)) is det.
1163
1164 Each Pair is a pair Module-list(PI), where Module:PI is a defined
1165 predicate in the starting module or a default module thereof. If the
1166 first argument is qualified, this is the starting module. Else, the
1167 default source module is the starting module. Only modules in which PI
1168 has a real definition are returned (i.e., _not_ modules where PI is only
1169 defined as dynamic or multifile.
1170
1171 @see boot/expand.pl uses this to find relevant modules that define
1172 term_expansion/2,4 and/or goal_expansion/2,4 definitions.
1173 */
1174
1175 #define MAX_TARGETS 10
1176
1177 static
1178 PRED_IMPL("$def_modules", 2, def_modules, PL_FA_TRANSPARENT)
1179 { PRED_LD
1180 Module m = LD->modules.source;
1181 defm_target targets[MAX_TARGETS];
1182 int tcount = 0;
1183 term_t ttail = PL_new_term_ref();
1184 term_t tmp = PL_new_term_refs(3);
1185 term_t tail = PL_copy_term_ref(A2);
1186 term_t thead = tmp+0;
1187 atom_t mname = 0;
1188 Word mp;
1189
1190 if ( !(mp=stripModuleName(valTermRef(A1), &mname PASS_LD)) )
1191 return FALSE;
1192 *valTermRef(ttail) = linkVal(mp);
1193
1194 if ( mname )
1195 { Module m2;
1196
1197 if ( (m2 = isCurrentModule(mname)) )
1198 m = m2;
1199 else if ( stringAtom(mname)[0] == '$' )
1200 m = MODULE_system;
1201 else
1202 m = MODULE_user;
1203 }
1204
1205 while( PL_get_list_ex(ttail, thead, ttail) )
1206 { if ( tcount >= MAX_TARGETS )
1207 return PL_resource_error("target_predicates");
1208 if ( !get_functor(thead, &targets[tcount].functor,
1209 NULL, 0, GF_PROCEDURE|GP_NOT_QUALIFIED) )
1210 return FALSE;
1211 targets[tcount].pi = PL_copy_term_ref(thead);
1212 tcount++;
1213 }
1214 if ( !PL_get_nil_ex(ttail) )
1215 return FALSE;
1216
1217 if ( !find_modules_with_defs(m, tcount, targets, tmp, tail, 100 PASS_LD) )
1218 return FALSE;
1219
1220 return PL_unify_nil(tail);
1221 }
1222
1223
1224 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1225 Declare `name' to be a module with `file' as its source file. If the
1226 module was already loaded its public table is cleared and all procedures
1227 in it are abolished.
1228 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1229
1230 int
declareModule(atom_t name,atom_t class,atom_t super,SourceFile sf,int line,int allow_newfile)1231 declareModule(atom_t name, atom_t class, atom_t super,
1232 SourceFile sf, int line,
1233 int allow_newfile)
1234 { GET_LD
1235 Module module = lookupModule(name);
1236 term_t tmp = 0, rdef = 0, rtail = 0;
1237 int rc = TRUE;
1238
1239 PL_LOCK(L_MODULE);
1240 if ( class )
1241 module->class = class;
1242
1243 if ( !allow_newfile && module->file && module->file != sf)
1244 { term_t obj;
1245 char msg[256];
1246 PL_UNLOCK(L_MODULE);
1247
1248 obj = PL_new_term_ref();
1249 PL_put_atom(obj, name);
1250 Ssprintf(msg, "Already loaded from %s",
1251 atom_summary(module->file->name, 100));
1252 return PL_error("module", 2, msg, ERR_PERMISSION,
1253 ATOM_redefine, ATOM_module, obj);
1254 }
1255
1256 if ( module->file != sf )
1257 { module->file = sf;
1258 addModuleSourceFile(sf, module);
1259 }
1260 module->line_no = line;
1261 LD->modules.source = module;
1262
1263 if ( sf->reload )
1264 { registerReloadModule(sf, module);
1265 } else
1266 { for_table(module->procedures, name, value,
1267 { Procedure proc = value;
1268 Definition def = proc->definition;
1269 if ( !true(def, P_DYNAMIC|P_MULTIFILE|P_FOREIGN) )
1270 { if ( def->module == module &&
1271 hasClausesDefinition(def) )
1272 { if ( !rdef )
1273 { rdef = PL_new_term_ref();
1274 rtail = PL_copy_term_ref(rdef);
1275 tmp = PL_new_term_ref();
1276 }
1277
1278 PL_unify_list(rtail, tmp, rtail);
1279 unify_definition(MODULE_user, tmp, def, 0, GP_NAMEARITY);
1280 }
1281 abolishProcedure(proc, module);
1282 }
1283 })
1284 clearHTable(module->public);
1285 }
1286 if ( super )
1287 setSuperModule(module, _lookupModule(super PASS_LD));
1288
1289 PL_UNLOCK(L_MODULE);
1290
1291 if ( rdef )
1292 { if ( !PL_unify_nil(rtail) )
1293 return FALSE;
1294
1295 rc = printMessage(ATOM_warning,
1296 PL_FUNCTOR_CHARS, "declare_module", 2,
1297 PL_ATOM, name,
1298 PL_FUNCTOR_CHARS, "abolish", 1,
1299 PL_TERM, rdef);
1300 }
1301
1302 return rc;
1303 }
1304
1305
1306 /** '$declare_module'(+Module, +Class, +Super, +File, +Line, +Redefine) is det.
1307
1308 Start a new (source-)module
1309
1310 @param Module is the name of the module to declare
1311 @param File is the canonical name of the file from which the module
1312 is loaded
1313 @param Line is the line-number of the :- module/2 directive.
1314 @param Redefine If =true=, allow associating the module to a new file
1315 */
1316
1317 static
1318 PRED_IMPL("$declare_module", 6, declare_module, 0)
1319 { PRED_LD
1320 SourceFile sf;
1321 atom_t mname, cname, sname, fname;
1322 int line_no, rdef;
1323
1324 term_t module = A1;
1325 term_t class = A2;
1326 term_t super = A3;
1327 term_t file = A4;
1328 term_t line = A5;
1329 term_t redefine = A6;
1330
1331 if ( !PL_get_atom_ex(module, &mname) ||
1332 !PL_get_atom_ex(class, &cname) ||
1333 !PL_get_atom_ex(super, &sname) ||
1334 !PL_get_atom_ex(file, &fname) ||
1335 !PL_get_integer_ex(line, &line_no) ||
1336 !PL_get_bool_ex(redefine, &rdef) )
1337 fail;
1338
1339 sf = lookupSourceFile(fname, TRUE);
1340 return declareModule(mname, cname, sname, sf, line_no, rdef);
1341 }
1342
1343
1344 static int
unify_export_list(term_t public,Module module ARG_LD)1345 unify_export_list(term_t public, Module module ARG_LD)
1346 { term_t head = PL_new_term_ref();
1347 term_t list = PL_copy_term_ref(public);
1348 int rval = TRUE;
1349
1350 for_table(module->public, name, value,
1351 { if ( !PL_unify_list(list, head, list) ||
1352 !unify_functor(head, (functor_t)name, GP_NAMEARITY) )
1353 { rval = FALSE;
1354 break;
1355 }
1356 })
1357 if ( rval )
1358 return PL_unify_nil(list);
1359
1360 fail;
1361 }
1362
1363
1364 static size_t
sizeof_module(Module m)1365 sizeof_module(Module m)
1366 { GET_LD
1367 size_t size = sizeof(*m);
1368
1369 if ( m->public) size += sizeofTable(m->public);
1370 if ( m->procedures) size += sizeofTable(m->procedures);
1371 if ( m->operators) size += sizeofTable(m->operators);
1372
1373 for_table(m->procedures, name, value,
1374 { Procedure proc = value;
1375 Definition def = proc->definition;
1376
1377 size += sizeof(*proc);
1378
1379 if ( def->module == m && false(def, P_FOREIGN) )
1380 { Definition def = getProcDefinition(proc);
1381 size += sizeof_predicate(def);
1382 }
1383 });
1384
1385 return size;
1386 }
1387
1388
1389
1390 static
1391 PRED_IMPL("$module_property", 2, module_property, 0)
1392 { PRED_LD
1393 Module m;
1394 term_t a = PL_new_term_ref();
1395 atom_t pname;
1396 size_t parity;
1397
1398 if ( !get_module(A1, &m, FALSE) )
1399 fail;
1400
1401 if ( !PL_get_name_arity(A2, &pname, &parity) ||
1402 parity != 1 )
1403 return PL_error(NULL, 0, NULL, ERR_TYPE,
1404 ATOM_module_property, A2);
1405
1406 _PL_get_arg(1, A2, a);
1407
1408 if ( pname == ATOM_line_count )
1409 { if ( m->line_no > 0 )
1410 return PL_unify_integer(a, m->line_no);
1411 else
1412 fail;
1413 } else if ( pname == ATOM_file )
1414 { if ( m->file )
1415 return PL_unify_atom(a, m->file->name);
1416 else
1417 fail;
1418 } else if ( pname == ATOM_exports )
1419 { return unify_export_list(a, m PASS_LD);
1420 } else if ( pname == ATOM_class )
1421 { return PL_unify_atom(a, m->class);
1422 } else if ( pname == ATOM_size )
1423 { return PL_unify_int64(a, sizeof_module(m));
1424 } else if ( pname == ATOM_program_size )
1425 { return PL_unify_int64(a, m->code_size);
1426 } else if ( pname == ATOM_last_modified_generation )
1427 { return PL_unify_int64(a, m->last_modified);
1428 } else if ( pname == ATOM_program_space )
1429 { if ( m->code_limit )
1430 return PL_unify_int64(a, m->code_limit);
1431 return FALSE;
1432 } else
1433 return PL_error(NULL, 0, NULL, ERR_DOMAIN,
1434 ATOM_module_property, A2);
1435 }
1436
1437
1438 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1439 export/1 exports a procedure specified by its name and arity or
1440 head from the context module.
1441 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1442
1443 int
exportProcedure(Module module,Procedure proc)1444 exportProcedure(Module module, Procedure proc)
1445 { LOCKMODULE(module);
1446 updateHTable(module->public,
1447 (void *)proc->definition->functor->functor,
1448 proc);
1449 UNLOCKMODULE(module);
1450
1451 return TRUE;
1452 }
1453
1454 static int
export_pi1(term_t pi,Module module ARG_LD)1455 export_pi1(term_t pi, Module module ARG_LD)
1456 { functor_t fd;
1457 Procedure proc;
1458
1459 if ( !get_functor(pi, &fd, &module, 0, GF_PROCEDURE|GF_NAMEARITY) )
1460 return FALSE;
1461
1462 if ( (proc = isStaticSystemProcedure(fd)) && true(proc->definition, P_ISO) )
1463 return TRUE;
1464 proc = lookupProcedure(fd, module);
1465
1466 if ( ReadingSource )
1467 { SourceFile sf = lookupSourceFile(source_file_name, TRUE);
1468 int rc = exportProcedureSource(sf, module, proc);
1469 releaseSourceFile(sf);
1470 return rc;
1471 } else
1472 { return exportProcedure(module, proc);
1473 }
1474 }
1475
1476 static int
export_pi(term_t pi,Module module,int depth ARG_LD)1477 export_pi(term_t pi, Module module, int depth ARG_LD)
1478 { if ( !PL_strip_module(pi, &module, pi) )
1479 return FALSE;
1480
1481 while ( PL_is_functor(pi, FUNCTOR_comma2) )
1482 { term_t a1 = PL_new_term_ref();
1483
1484 if ( ++depth == 100 && !PL_is_acyclic(pi) )
1485 return PL_type_error("acyclic_term", pi);
1486
1487 _PL_get_arg(1, pi, a1);
1488 if ( !export_pi(a1, module, depth PASS_LD) )
1489 return FALSE;
1490 PL_reset_term_refs(a1);
1491 _PL_get_arg(2, pi, pi);
1492 }
1493
1494 return export_pi1(pi, module PASS_LD);
1495 }
1496
1497
1498
1499 static
1500 PRED_IMPL("export", 1, export, PL_FA_TRANSPARENT)
1501 { PRED_LD
1502 Module module = NULL;
1503
1504 return export_pi(A1, module, 0 PASS_LD);
1505 }
1506
1507
1508 /** '$undefined_export'(+Module, -UndefExport:list(pi)) is det.
1509
1510 Unify UndefExport with predicate indicators of undefined predicates in
1511 Module.
1512 */
1513
1514 static
1515 PRED_IMPL("$undefined_export", 2, undefined_export, 0)
1516 { PRED_LD
1517 atom_t mname;
1518 Module module;
1519 TableEnum e;
1520 Procedure proc;
1521 term_t tail = PL_copy_term_ref(A2);
1522 term_t head = PL_new_term_ref();
1523
1524 if ( !PL_get_atom_ex(A1, &mname) )
1525 return FALSE;
1526 if ( !(module = isCurrentModule(mname)) )
1527 return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_module, A1);
1528
1529 e = newTableEnum(module->public);
1530
1531 while( advanceTableEnum(e, NULL, (void**)&proc) )
1532 { Definition def = proc->definition;
1533 FunctorDef fd = def->functor;
1534
1535 if ( !isDefinedProcedure(proc) && /* not defined */
1536 def->module == module && /* not imported */
1537 !autoImport(fd->functor, module) )
1538 { if ( !PL_unify_list(tail, head, tail) ||
1539 !unify_definition(MODULE_user, head, proc->definition,
1540 0, GP_QUALIFY|GP_NAMEARITY) )
1541 { freeTableEnum(e);
1542 return FALSE;
1543 }
1544 }
1545 }
1546
1547 freeTableEnum(e);
1548 return PL_unify_nil(tail);
1549 }
1550
1551
1552 word
pl_context_module(term_t module)1553 pl_context_module(term_t module)
1554 { GET_LD
1555 return PL_unify_atom(module, contextModule(environment_frame)->name);
1556 }
1557
1558 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1559 pl_import() imports the predicate specified with its argument into the
1560 current context module. If the predicate is already defined in the
1561 context a warning is displayed and the predicate is NOT imported. If
1562 the predicate is not on the public list of the exporting module a
1563 warning is displayed, but the predicate is imported nevertheless.
1564
1565 A particulary nasty problem happens if a procedure is exported from
1566 module A to B and then to C, while C loads B before B loads A. In this
1567 case C will share the definition of B, which is subsequently overwritten
1568 when B imports A. The fixExport() stuff deals with this situation. It is
1569 considered very rare and probably scanning all predicate definitions is
1570 fine.
1571 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1572
1573 static inline void
fixExportModule(Module m,Definition old,Definition new)1574 fixExportModule(Module m, Definition old, Definition new)
1575 { LOCKMODULE(m);
1576
1577 for_table(m->procedures, name, value,
1578 { Procedure proc = value;
1579
1580 if ( proc->definition == old )
1581 { DEBUG(1, Sdprintf("Patched def of %s\n",
1582 procedureName(proc)));
1583 shareDefinition(new);
1584 proc->definition = new;
1585 if ( unshareDefinition(old) == 0 )
1586 lingerDefinition(old);
1587 }
1588 });
1589
1590 UNLOCKMODULE(m);
1591 }
1592
1593
1594 static void
fixExport(Definition old,Definition new)1595 fixExport(Definition old, Definition new)
1596 { PL_LOCK(L_MODULE);
1597 for_table(GD->tables.modules, name, value,
1598 fixExportModule(value, old, new));
1599 PL_UNLOCK(L_MODULE);
1600 }
1601
1602
1603 int
atomToImportStrength(atom_t a)1604 atomToImportStrength(atom_t a)
1605 { if ( a == ATOM_weak )
1606 return PROC_WEAK;
1607 else if ( a == ATOM_strong )
1608 return 0;
1609 else
1610 return -1; /* domain error */
1611 }
1612
1613
1614 static int
import(term_t pred,term_t strength ARG_LD)1615 import(term_t pred, term_t strength ARG_LD)
1616 { Module source = NULL;
1617 Module destination = contextModule(environment_frame);
1618 functor_t fd;
1619 Procedure proc, old;
1620 int pflags = 0;
1621
1622 if ( !get_functor(pred, &fd, &source, 0, GF_PROCEDURE) )
1623 return FALSE;
1624 if ( strength )
1625 { atom_t a;
1626
1627 if ( !PL_get_atom_ex(strength, &a) )
1628 return FALSE;
1629 if ( (pflags=atomToImportStrength(a)) < 0 )
1630 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_import_type, strength);
1631 }
1632
1633 if ( !(proc = lookupProcedure(fd, source)) )
1634 return FALSE;
1635
1636 if ( !isDefinedProcedure(proc) )
1637 autoImport(proc->definition->functor->functor, proc->definition->module);
1638
1639 retry:
1640 if ( (old = isCurrentProcedure(proc->definition->functor->functor,
1641 destination)) )
1642 { if ( old->definition == proc->definition )
1643 succeed; /* already done this! */
1644
1645 if ( !isDefinedProcedure(old) )
1646 { Definition odef = old->definition;
1647
1648 old->definition = proc->definition;
1649 shareDefinition(proc->definition);
1650 if ( unshareDefinition(odef) > 0 )
1651 { fixExport(odef, proc->definition);
1652 } else
1653 { lingerDefinition(odef);
1654 }
1655 set(old, pflags|PROC_IMPORTED);
1656
1657 succeed;
1658 }
1659
1660 if ( old->definition->module == destination )
1661 { if ( (pflags & PROC_WEAK) )
1662 { if ( truePrologFlag(PLFLAG_WARN_OVERRIDE_IMPLICIT_IMPORT) )
1663 { term_t pi = PL_new_term_ref();
1664
1665 if ( !PL_unify_predicate(pi, proc, GP_NAMEARITY) )
1666 return FALSE;
1667
1668 if ( !printMessage(ATOM_warning,
1669 PL_FUNCTOR_CHARS, "ignored_weak_import", 2,
1670 PL_ATOM, destination->name,
1671 PL_TERM, pi) )
1672 return FALSE;
1673 }
1674
1675 return TRUE;
1676 } else
1677 return PL_error("import", 1, "name clash", ERR_IMPORT_PROC,
1678 proc, destination->name, 0);
1679 }
1680
1681 if ( old->definition->module != source ) /* already imported */
1682 { return PL_error("import", 1, NULL, ERR_IMPORT_PROC,
1683 proc, destination->name,
1684 old->definition->module->name);
1685 }
1686
1687 sysError("Unknown problem importing %s into module %s",
1688 procedureName(proc),
1689 stringAtom(destination->name));
1690 fail;
1691 }
1692
1693 if ( !isPublicModule(source, proc) )
1694 { term_t pi = PL_new_term_ref();
1695
1696 if ( !PL_unify_predicate(pi, proc, GP_NAMEARITY) )
1697 return FALSE;
1698 if ( !printMessage(ATOM_warning,
1699 PL_FUNCTOR_CHARS, "import_private", 2,
1700 PL_ATOM, destination->name,
1701 PL_TERM, pi) )
1702 return FALSE;
1703 }
1704
1705 { Procedure nproc = (Procedure) allocHeapOrHalt(sizeof(struct procedure));
1706 void *old;
1707
1708 nproc->flags = pflags;
1709 nproc->source_no = 0;
1710 shareDefinition(proc->definition);
1711 nproc->definition = proc->definition;
1712
1713 LOCKMODULE(destination);
1714 old = addHTable(destination->procedures,
1715 (void *)proc->definition->functor->functor, nproc);
1716 UNLOCKMODULE(destination);
1717 if ( old != nproc )
1718 { int shared = unshareDefinition(proc->definition);
1719 assert(shared > 0);
1720 (void)shared;
1721 freeHeap(nproc, sizeof(*nproc));
1722 goto retry;
1723 }
1724 }
1725
1726 return TRUE;
1727 }
1728
1729 static
1730 PRED_IMPL("import", 1, import, PL_FA_TRANSPARENT)
1731 { PRED_LD
1732
1733 return import(A1, 0 PASS_LD);
1734 }
1735
1736 static
1737 PRED_IMPL("$import", 2, import, PL_FA_TRANSPARENT)
1738 { PRED_LD
1739
1740 return import(A1, A2 PASS_LD);
1741 }
1742
1743 /** '$destroy_module'(+Module) is det.
1744
1745 Destroy all traces of the named module. This is only safe if no
1746 procedure in Module is executing and there are no predicates outside
1747 this module that link to predicates of this module.
1748 */
1749
1750 static
1751 PRED_IMPL("$destroy_module", 1, destroy_module, 0)
1752 { PRED_LD
1753 atom_t name;
1754
1755 if ( PL_get_atom_ex(A1, &name) )
1756 { Module m;
1757
1758 if ( (m=acquireModule(name)) )
1759 { if ( m->class == ATOM_temporary )
1760 { return destroyModule(m);
1761 } else
1762 { releaseModule(m);
1763 return PL_error(NULL, 0,
1764 "module is not temporary",
1765 ERR_PERMISSION, ATOM_destroy, ATOM_module, A1);
1766 }
1767 }
1768
1769 return TRUE; /* non-existing */
1770 }
1771
1772 return FALSE;
1773 }
1774
1775 /*******************************
1776 * PUBLISH PREDICATES *
1777 *******************************/
1778
1779 BeginPredDefs(module)
1780 PRED_DEF("import_module", 2, import_module,
1781 PL_FA_NONDETERMINISTIC)
1782 PRED_DEF("$def_modules", 2, def_modules, PL_FA_TRANSPARENT)
1783 PRED_DEF("$declare_module", 6, declare_module, 0)
1784 PRED_DEF("add_import_module", 3, add_import_module, 0)
1785 PRED_DEF("delete_import_module", 2, delete_import_module, 0)
1786 PRED_DEF("set_module", 1, set_module, PL_FA_TRANSPARENT)
1787 PRED_DEF("$current_module", 2, current_module, PL_FA_NONDETERMINISTIC)
1788 PRED_DEF("$module_property", 2, module_property, 0)
1789 PRED_DEF("strip_module", 3, strip_module, PL_FA_TRANSPARENT)
1790 PRED_DEF("import", 1, import, PL_FA_TRANSPARENT)
1791 PRED_DEF("$import", 2, import, PL_FA_TRANSPARENT)
1792 PRED_DEF("export", 1, export, PL_FA_TRANSPARENT)
1793 PRED_DEF("$undefined_export", 2, undefined_export, 0)
1794 PRED_DEF("$destroy_module", 1, destroy_module, 0)
1795 PRED_DEF("$current_source_module", 1, current_source_module, 0)
1796 PRED_DEF("$set_source_module", 1, set_source_module, 0)
1797 PRED_DEF("$current_typein_module", 1, current_typein_module, 0)
1798 PRED_DEF("$set_typein_module", 1, set_typein_module, 0)
1799 EndPredDefs
1800