Wild Life: modules.c Source File

Wild Life 2.29

- Main Page
- Data Structures
- Files

- File List
- Globals

All Data Structures Files Functions Variables Typedefs Macros
modules.c
Go to the documentation of this file.
1 /******************************** MODULES ************************************/
2 /* RM: Jan 7 1993
3
4 This file implements a variation of the LIFE module system as specified by
5 Dinesh Katiyar.
6
7 */
8 /* $Id: modules.c,v 1.3 1994/12/15 22:05:39 duchier Exp $ */
9
10 #include "defs.h"
11
12 ptr_node module_table=NULL; /* The table of modules */
13 ptr_module current_module=NULL; /* The current module for the tokenizer */
14 ptr_module no_module=NULL;
15 ptr_module bi_module=NULL;
16 ptr_module syntax_module=NULL;
17 ptr_module sys_module=NULL;
18
19 // set NULL next 2 DJD
20 ptr_module user_module=NULL;
21 ptr_module x_module= NULL;
22
23 long display_modules=TRUE; /* Should really default to FALSE */
24
25
26 /******** INIT_MODULES()
27 Initialize the module system.
28 */
29
30 void init_modules()
31 {
32 bi_module=create_module("built_ins");
33 no_module=create_module("no_module");
34 x_module=create_module("x");
35 syntax_module=create_module("syntax");
36 user_module=create_module("user"); /* RM: Jan 27 1993 */
37 sys_module=create_module("sys");
38
39 (void)set_current_module(syntax_module);
40 }
41
42
43
44 /******** FIND_MODULE(module)
45 Return a module if it exists.
46 */
47
48 ptr_module find_module(module)
49
50 char * module;
51 {
52 ptr_node nodule;
53
54 nodule=find(FEATCMP,(char *)module,module_table);
55 if(nodule)
56 return (ptr_module)(nodule->data);
57 else
58 return NULL;
59 }
60
61
62
63 /******** CREATE_MODULE(module)
64 Create a new module.
65 */
66
67 ptr_module create_module(module)
68
69 char *module;
70 {
71 ptr_module new;
72
73
74 new=find_module(module);
75 if(!new) {
76 new=HEAP_ALLOC(struct wl_module);
77 new->module_name=(char *)heap_copy_string(module);
78 new->source_file=(char *)heap_copy_string(input_file_name);
79 new->open_modules=NULL;
80 new->inherited_modules=NULL;
81 new->symbol_table=hash_create(16); /* RM: Feb 3 1993 */
82
83 (void)heap_insert(STRCMP,new->module_name,&module_table,(GENERIC)new);
84
85 }
86 return new;
87 }
88
89
90
91 /******** SET_CURRENT_MODULE(module)
92 Set the current module to a given string.
93 */
94
95 ptr_module set_current_module(module)
96
97 ptr_module module;
98 {
99 current_module=module;
100 /* printf("*** Current module: '%s'\n",current_module->module_name); */
101 return current_module;
102 }
103
104
105
106 /******** EXTRACT_MODULE_FROM_NAME
107 Return the module corresponding to "module#symbol".
108 Return NULL if only "#symbol".
109 */
110
111 ptr_module extract_module_from_name(str)
112
113 char *str;
114 {
115 char *s;
116 ptr_module result=NULL;
117
118 s=str;
119 while(legal_in_name(*s))
120 s++;
121 if(s!=str && *s=='#' /* && *(s+1)!=0 */) {
122 *s=0;
123 result=create_module(str);
124 *s='#';
125 /*
126 printf("Extracted module name '%s' from '%s'\n",result->module_name,str);
127 */
128 }
129
130 return result;
131 }
132
133
134
135 /******** STRIP_MODULE_NAME(symbol)
136 Return the sub-string of symbol without the module prefix.
137 */
138
139 char *strip_module_name(str)
140
141 char *str;
142 {
143 char *s=str;
144
145 while(legal_in_name(*s))
146 s++;
147 if(s!=str && *s=='#' /* && *(s+1)!=0 */) {
148 s++;
149 /* printf("Stripped module from '%s' yielding '%s'\n",str,s); */
150 return s;
151 }
152 else
153 return str;
154 }
155
156
157
158 /******** STRING_VAL(term)
159 Return a string defined by a term, that is:
160 if term is a string, return the value,
161 otherwise return the symbol for that term.
162 */
163
164 char *string_val(term)
165
166 ptr_psi_term term;
167 {
168 deref_ptr(term);
169 if(term->value_3 && term->type==quoted_string)
170 return (char *)term->value_3;
171 else
172 return term->type->keyword->symbol;
173 }
174
175
176
177 /******** MAKE_MODULE_TOKEN(module,string)
178 Write 'module#string' in module_buffer.
179 If string is a qualified reference to a given module, then modify the calling
180 module variable to reflect this.
181
182 The result must be immediately stored in a newly allocated string.
183 */
184
185 char *make_module_token(module,str)
186
187 ptr_module module;
188 char *str;
189 {
190 ptr_module explicit;
191
192
193 /* Check if the string already contains a module */
194 explicit=extract_module_from_name(str);
195 if(explicit)
196 strcpy(module_buffer,str);
197 else
198 if(module!=no_module) {
199 strcpy(module_buffer,module->module_name);
200 strcat(module_buffer,"#");
201 strcat(module_buffer,str);
202 }
203 else
204 strcpy(module_buffer,str);
205
206 return module_buffer;
207 }
208
209
210
211 /******** NEW_DEFINITION(key)
212 Create a definition for a key.
213 */
214
215 ptr_definition new_definition(key) /* RM: Feb 22 1993 */
216
217 ptr_keyword key;
218 {
219 ptr_definition result;
220
221
222 /* printf("*** New definition: %s\n",key->combined_name); */
223
224 /* Create a new definition */
225 result=HEAP_ALLOC(struct wl_definition);
226
227 /* RM: Feb 3 1993 */
228 result->next=first_definition; /* Linked list of all definitions */
229 first_definition=result;
230
231 result->keyword=key;
232 result->rule=NULL;
233 result->properties=NULL;
234 result->date=0;
235 result->type_def=(def_type)undef;
236 result->always_check=TRUE;
237 result->protected=TRUE;
238 result->evaluate_args=TRUE;
239 result->already_loaded=FALSE;
240 result->children=NULL;
241 result->parents=NULL;
242 result->code=NOT_CODED;
243 result->op_data=NULL;
244 result->global_value=NULL; /* RM: Feb 8 1993 */
245 result->init_value=NULL; /* RM: Mar 23 1993 */
246 key->definition=result;
247
248 return result;
249 }
250
251
252
253 /******** UPDATE_SYMBOL(m,s)
254 S is a string of characters encountered during parsing, M is the module it
255 belongs too.
256
257 if M is NULL then extract the module name from S. If that fails then use the
258 current module.
259
260 Then, retrieve the keyword for 'module#symbol'. Then find the correct
261 definition by scanning the opened modules.
262 */
263
264 ptr_definition update_symbol(module,symbol) /* RM: Jan 8 1993 */
265 ptr_module module;
266 char *symbol;
267 {
268 ptr_keyword key;
269 ptr_definition result=NULL;
270 ptr_int_list opens;
271 ptr_module opened;
272 ptr_keyword openkey;
273 ptr_keyword tempkey;
274
275 /* First clean up the arguments and find out which module to use */
276
277 if(!module) {
278 module=extract_module_from_name(symbol);
279 if(!module)
280 module=current_module;
281 symbol=strip_module_name(symbol);
282 }
283
284 /* printf("looking up %s#%s\n",module->module_name,symbol); */
285
286 /* Now look up 'module#symbol' in the symbol table */
287 key=hash_lookup(module->symbol_table,symbol);
288
289 if(key)
290 if(key->public || module==current_module)
291 result=key->definition;
292 else {
293 Errorline("qualified call to private symbol '%s'\n",
294 key->combined_name);
295
296 result=error_psi_term->type;
297 }
298 else
299 if(module!=current_module) {
300 Errorline("qualified call to undefined symbol '%s#%s'\n",
301 module->module_name,symbol);
302 result=error_psi_term->type;
303 }
304 else
305 {
306 /* Add 'module#symbol' to the symbol table */
307 key=HEAP_ALLOC(struct wl_keyword);
308 key->module=module;
309 key->symbol=(char *)heap_copy_string(symbol);
310 key->combined_name=heap_copy_string(make_module_token(module,symbol));
311 key->public=FALSE;
312 key->private_feature=FALSE; /* RM: Mar 11 1993 */
313 key->definition=NULL;
314
315 hash_insert(module->symbol_table,key->symbol,key);
316
317
318 /* Search the open modules of 'module' for 'symbol' */
319 opens=module->open_modules;
320 openkey=NULL;
321 while(opens) {
322 opened=(ptr_module)(opens->value_1);
323 if(opened!=module) {
324
325 tempkey=hash_lookup(opened->symbol_table,symbol);
326
327 if(tempkey)
328 if(openkey && openkey->public && tempkey->public) {
329 if(openkey->definition==tempkey->definition) {
330 warningline("benign module name clash: %s and %s\n",
331 openkey->combined_name,
332 tempkey->combined_name);
333 }
334 else {
335 Errorline("serious module name clash: \"%s\" and \"%s\"\n",
336 openkey->combined_name,
337 tempkey->combined_name);
338
339 result=error_psi_term->type;
340 }
341 }
342 else
343 if(!openkey || !openkey->public)
344 openkey=tempkey;
345 }
346
347 opens=opens->next;
348 }
349
350 if(!result) { /* RM: Feb 1 1993 */
351
352 if(openkey && openkey->public) {
353 /* Found the symbol in an open module */
354
355 if(!openkey->public)
356 warningline("implicit reference to non-public symbol: %s\n",
357 openkey->combined_name);
358
359 result=openkey->definition;
360 key->definition=result;
361
362 /*
363 printf("*** Aliasing %s#%s to %s#%s\n",
364 key->module->module_name,
365 key->symbol,
366 openkey->module->module_name,
367 openkey->symbol);
368 */
369
370 }
371 else { /* Didn't find it */
372 result=new_definition(key);
373 }
374 }
375 }
376
377 return result;
378 }
379
380
381
382 /******** GET_FUNCTION_VALUE(module,symbol)
383 Return the value of a function without arguments. This returns a psi-term on
384 the heap which may not be bound etc...
385
386 This routine allows C variables to be stored as LIFE functions.
387 */
388
425 /******** PRINT_SYMBOL(k)
426 Returns the string to be used to display keyword K.
427 */
428
429 char *print_symbol(k)
430
431 ptr_keyword k;
432
433 {
434 k=k->definition->keyword;
435 if(display_modules)
436 return k->combined_name;
437 else
438 return k->symbol;
439 }
440
441
442 /******** PRETTY_SYMBOL(k)
443 Prints the string to be used to display keyword K.
444 */
445
446 void pretty_symbol(k)
447
448 ptr_keyword k;
449 {
450 k=k->definition->keyword;
451 if(display_modules) {
452 prettyf(k->module->module_name);
453 prettyf("#");
454 }
455 prettyf(k->symbol);
456 }
457
458
459
460 /******** PRETTY_QUOTE_SYMBOL(k)
461 Prints the string to be used to display keyword K, with quotes if required.
462 */
463
464 void pretty_quote_symbol(k)
465
466 ptr_keyword k;
467 {
468 k=k->definition->keyword;
469 if(display_modules) {
470 prettyf(k->module->module_name);
471 prettyf("#");
472 }
473 prettyf_quote(k->symbol);
474 }
475
476
477
478 /******** C_SET_MODULE()
479 This routine retrieves the necessary psi-term to determine the current
480 state of the module mechanism from the heap.
481 */
482
483 long c_set_module()
484
485 {
486 ptr_psi_term arg1,arg2;
487 ptr_psi_term call;
488
489 call=aim->aaaa_1;
490 deref_ptr(call);
491 get_two_args(call->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
492
493 if(arg1) {
494 (void)set_current_module(create_module(string_val(arg1)));
495 return TRUE;
496 }
497 else {
498 Errorline("argument missing in '%P'\n",call);
499 return FALSE;
500 }
501 }
502
503
504
505 /******** C_OPEN_MODULE()
506 Open one or more modules, that is, alias all the public words
507 in the current module to the definitions in the argument.
508 An error message is printed for each module that is not successfully
509 opened.
510 If at least one module was not successfully opened, the routine
511 fails.
512 */
513
514 long c_open_module()
515
516 {
517 ptr_psi_term call;
518 int onefailed=FALSE;
519 call=aim->aaaa_1;
520 deref_ptr(call);
521 if (call->attr_list) {
522 open_module_tree(call->attr_list, &onefailed);
523 }
524 else {
525 Errorline("argument missing in '%P'\n",call);
526 }
527
528 return !onefailed;
529 }
530
531
532
533 void open_module_tree(n, onefailed)
534 ptr_node n;
535 int *onefailed;
536 {
537 if (n) {
538 ptr_psi_term t;
539 open_module_tree(n->left,onefailed);
540
541 t=(ptr_psi_term)n->data;
542 open_module_one(t,onefailed);
543
544 open_module_tree(n->right,onefailed);
545 }
546 }
547
548
549
550 void open_module_one(t, onefailed)
551 ptr_psi_term t;
552 int *onefailed;
553 {
554 ptr_module open_module;
555 ptr_int_list opens;
556 ptr_keyword key1,key2;
557 int i;
558 int found=FALSE;
559
560 open_module=find_module(string_val(t));
561 if (open_module) {
562
563 for (opens=current_module->open_modules;opens;opens=opens->next)
564 if (opens->value_1 == (GENERIC)open_module) {
565 /* warningline("module \"%s\" is already open\n",
566 open_module->module_name); */ /* RM: Jan 27 1993 */
567 found=TRUE;
568 }
569
570 if (!found) {
571 opens=HEAP_ALLOC(struct wl_int_list);
572 opens->value_1=(GENERIC)open_module;
573 opens->next=current_module->open_modules;
574 current_module->open_modules=opens;
575
576 /* Check for name conflicts */
577 /* RM: Feb 23 1993 */
578 for (i=0;i<open_module->symbol_table->size;i++)
579 if ((key1=open_module->symbol_table->data[i]) && key1->public) {
580 key2=hash_lookup(current_module->symbol_table,key1->symbol);
581 if (key2 && key1->definition!=key2->definition)
582 Errorline("symbol clash '%s' and '%s'\n",
583 key1->combined_name,
584 key2->combined_name);
585 }
586 }
587 }
588 else {
589 Errorline("module \"%s\" not found\n",string_val(t));
590 *onefailed=TRUE;
591 }
592 }
593
594
595
596 /******** MAKE_PUBLIC(term,bool)
597 Make a term public.
598 */
599
600 long make_public(term,bool) /* RM: Feb 22 1993 Modified */
601
602 ptr_psi_term term;
603 long bool;
604 {
605 int ok=TRUE;
606 ptr_keyword key;
607 ptr_definition def;
608
609 deref_ptr(term);
610
611 key=hash_lookup(current_module->symbol_table,term->type->keyword->symbol);
612 if(key) {
613
614 if(key->definition->keyword->module!=current_module && !bool) {
615 warningline("local definition of '%s' overrides '%s'\n",
616 key->definition->keyword->symbol,
617 key->definition->keyword->combined_name);
618
619 (void)new_definition(key);
620 }
621
622 key->public=bool;
623 }
624 else {
625 def=update_symbol(current_module,term->type->keyword->symbol);
626 def->keyword->public=bool;
627 }
628
629 return ok;
630 }
631
632
633 #define MAKE_PUBLIC 1
634 #define MAKE_PRIVATE 2
635 #define MAKE_FEATURE_PRIVATE 3
636
637 /* Do for all arguments, for the built-ins
638 c_public, c_private, and c_private_feature.
639 */
640 void traverse_tree(n,flag)
641 ptr_node n;
642 int flag;
643 {
644 if (n) {
645 ptr_psi_term t;
646 traverse_tree(n->left,flag);
647
648 t=(ptr_psi_term)n->data;
649 deref_ptr(t);
650 switch (flag) {
651 case MAKE_PUBLIC:
652 (void)make_public(t,TRUE);
653 break;
654 case MAKE_PRIVATE:
655 (void)make_public(t,FALSE);
656 break;
657 case MAKE_FEATURE_PRIVATE:
658 (void)make_feature_private(t);
659 break;
660 }
661 traverse_tree(n->right,flag);
662 }
663 }
664
665
666 /******** C_PUBLIC()
667 The argument(s) are symbols.
668 Make them public in the current module if they belong to it.
669 */
670
671 long c_public()
672
673 {
674 // ptr_psi_term arg1,arg2;
675 ptr_psi_term call;
676 int success;
677
678 call=aim->aaaa_1;
679 deref_ptr(call);
680 if (call->attr_list) {
681 traverse_tree(call->attr_list,MAKE_PUBLIC);
682 success=TRUE;
683 } else {
684 Errorline("argument missing in '%P'\n",call);
685 success=FALSE;
686 }
687
688 return success;
689 }
690
691
692 /******** C_PRIVATE()
693 The argument is a single symbol or a list of symbols.
694 Make them private in the current module if they belong to it.
695 */
696
697 long c_private()
698
699 {
700 // ptr_psi_term arg1,arg2;
701 ptr_psi_term call;
702 int success;
703
704 call=aim->aaaa_1;
705 deref_ptr(call);
706 if (call->attr_list) {
707 traverse_tree(call->attr_list,MAKE_PRIVATE);
708 success=TRUE;
709 } else {
710 Errorline("argument missing in '%P'\n",call);
711 success=FALSE;
712 }
713
714 return success;
715 }
716
717
718
719 /******** C_DISPLAY_MODULES();
720 Set the display modules switch.
721 */
722
723 long c_display_modules()
724
725 {
726 ptr_psi_term arg1,arg2;
727 ptr_psi_term call;
728 int success=TRUE;
729
730
731 call=aim->aaaa_1;
732 deref_ptr(call);
733 get_two_args(call->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
734
735 if(arg1) {
736 deref_ptr(arg1);
737 if(arg1->type==lf_true)
738 display_modules=TRUE;
739 else
740 if(arg1->type==lf_false)
741 display_modules=FALSE;
742 else {
743 Errorline("argument should be boolean in '%P'\n",call);
744 success=FALSE;
745 }
746 }
747 else /* No argument: toggle */
748 display_modules= !display_modules;
749
750 return success;
751 }
752
753
754
755 /******** C_DISPLAY_PERSISTENT();
756 Set the display persistent switch.
757 */
758
759 long c_display_persistent() /* RM: Feb 12 1993 */
760
761 {
762 ptr_psi_term arg1,arg2;
763 ptr_psi_term call;
764 int success=TRUE;
765
766
767 call=aim->aaaa_1;
768 deref_ptr(call);
769 get_two_args(call->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
770
771 if(arg1) {
772 deref_ptr(arg1);
773 if(arg1->type==lf_true)
774 display_persistent=TRUE;
775 else
776 if(arg1->type==lf_false)
777 display_persistent=FALSE;
778 else {
779 Errorline("argument should be boolean in '%P'\n",call);
780 success=FALSE;
781 }
782 }
783 else /* No argument: toggle */
784 display_persistent= !display_persistent;
785
786 return success;
787 }
788
789
790
791 /******** C_TRACE_INPUT();
792 Set the trace_input switch.
793 */
794
795 long c_trace_input()
796
797 {
798 ptr_psi_term arg1,arg2;
799 ptr_psi_term call;
800 int success=TRUE;
801
802
803 call=aim->aaaa_1;
804 deref_ptr(call);
805 get_two_args(call->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
806
807 if(arg1) {
808 deref_ptr(arg1);
809 if(arg1->type==lf_true)
810 trace_input=TRUE;
811 else
812 if(arg1->type==lf_false)
813 trace_input=FALSE;
814 else {
815 Errorline("argument should be boolean in '%P'\n",call);
816 success=FALSE;
817 }
818 }
819 else /* No argument: toggle */
820 trace_input= !trace_input;
821
822 return success;
823 }
824
825
826
827 /******** REPLACE(old,new,term)
828 Replace all occurrences of type OLD with NEW in TERM.
829 */
830
831 void rec_replace(ptr_definition,ptr_definition,ptr_psi_term);
832 void replace_attr(ptr_node,ptr_psi_term,ptr_definition,ptr_definition );
833
834 void replace(old,new,term)
835
836 ptr_definition old;
837 ptr_definition new;
838 ptr_psi_term term;
839 {
840 clear_copy();
841 rec_replace(old,new,term);
842 }
843
844
845
846 void rec_replace(old,new,term)
847
848 ptr_definition old;
849 ptr_definition new;
850 ptr_psi_term term;
851 {
852 ptr_psi_term done;
853 long *info; // some trouble w this - don't see
854 ptr_node old_attr;
855
856 deref_ptr(term);
857 done=translate(term,&info);
858 if(!done) {
859 insert_translation(term,term,0);
860
861 if(term->type==old && !term->value_3) {
862 push_ptr_value(def_ptr,(GENERIC *)&(term->type));
863 term->type=new;
864 }
865 old_attr=term->attr_list;
866 if(old_attr) {
867 push_ptr_value(int_ptr,(GENERIC *)&(term->attr_list));
868 term->attr_list=NULL;
869 replace_attr(old_attr,term,old,new);
870 }
871 }
872 }
873
874
875 void replace_attr(old_attr,term,old,new)
876 ptr_node old_attr;
877 ptr_psi_term term;
878 ptr_definition old;
879 ptr_definition new;
880
881 {
882 ptr_psi_term value;
883 char *oldlabel; /* RM: Mar 12 1993 */
884 char *newlabel;
885
886 if(old_attr->left)
887 replace_attr(old_attr->left,term,old,new);
888
889 value=(ptr_psi_term)old_attr->data;
890 rec_replace(old,new,value);
891
892 if(old->keyword->private_feature) /* RM: Mar 12 1993 */
893 oldlabel=old->keyword->combined_name;
894 else
895 oldlabel=old->keyword->symbol;
896
897 if(new->keyword->private_feature) /* RM: Mar 12 1993 */
898 newlabel=new->keyword->combined_name;
899 else
900 newlabel=new->keyword->symbol;
901
902 if(!strcmp(old_attr->key,oldlabel))
903 (void)stack_insert(FEATCMP,newlabel,&(term->attr_list),(GENERIC)value);
904 else
905 (void)stack_insert(FEATCMP,old_attr->key,&(term->attr_list),(GENERIC)value);
906
907 if(old_attr->right)
908 replace_attr(old_attr->right,term,old,new);
909 }
910
911
912
913 /******** C_REPLACE()
914 Replace all occurrences of type ARG1 with ARG2 in ARG3.
915 */
916
917 long c_replace()
918
919 {
920 ptr_psi_term arg1=NULL;
921 ptr_psi_term arg2=NULL;
922 ptr_psi_term arg3=NULL;
923 ptr_psi_term call;
924 int success=FALSE;
925 ptr_node n;
926
927 call=aim->aaaa_1;
928 deref_ptr(call);
929
930 get_two_args(call->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
931 n=find(FEATCMP,three,call->attr_list);
932 if (n)
933 arg3=(ptr_psi_term)n->data;
934
935 if(arg1 && arg2 && arg3) {
936 deref_ptr(arg1);
937 deref_ptr(arg2);
938 deref_ptr(arg3);
939 replace(arg1->type,arg2->type,arg3);
940 success=TRUE;
941 }
942 else {
943 Errorline("argument missing in '%P'\n",call);
944 }
945
946 return success;
947 }
948
949
950
951
952 /******** C_CURRENT_MODULE
953 Return the current module.
954 */
955
956 long c_current_module()
957
958 {
959 long success=TRUE;
960 ptr_psi_term result,g,other;
961
962
963 g=aim->aaaa_1;
964 deref_ptr(g);
965 result=aim->bbbb_1;
966 deref_ptr(result);
967
968
969 other=stack_psi_term(4);
970 /* PVR 24.1.94 */
971 other->type=quoted_string;
972 other->value_3=(GENERIC)heap_copy_string(current_module->module_name);
973 /*
974 update_symbol(current_module,
975 current_module->module_name)
976 ->keyword->symbol
977 );
978 */ /* RM: 2/15/1994 */
979 /* other->type=update_symbol(current_module,current_module->module_name); */
980 resid_aim=NULL;
981 push_goal(unify,result,other,NULL);
982
983 return success;
984 }
985
986
987
988
989 /******** C_MODULE_ACCESS
990 Return the psi-term Module#Symbol
991 */
992
993 long c_module_access()
994
995 {
996 long success=FALSE;
997 // ptr_psi_term result,module,symbol,call,other;
998 ptr_psi_term call;
999
1000
1001 call=aim->aaaa_1;
1002 deref_ptr(call);
1003
1004 /*
1005 result=aim->bbbb_1;
1006 deref_ptr(result);
1007 get_two_args(call,(ptr_psi_term *)&module,(ptr_psi_term *)&symbol);
1008
1009 if(module && symbol) {
1010 other=stack_psi_term(4);
1011 other->type=update_symbol(module_access,module_access->module_name);
1012 resid_aim=NULL;
1013 push_goal(unify,result,other,NULL);
1014
1015 }
1016 */
1017
1018 warningline("%P not implemented yet...\n",call);
1019
1020 return success;
1021 }
1022
1023
1024
1025 /******** GLOBAL_UNIFY(u,v)
1026 Unify two psi-terms, where it is known that V is on the heap (a persistent
1027 variable).
1028
1029 This routine really matches U and V, it will only succeed if V is more
1030 general than U. U will then be bound to V.
1031 */
1032
1033 int global_unify_attr(ptr_node,ptr_node); /* RM: Feb 9 1993 */
1034
1035 int global_unify(u,v) /* RM: Feb 11 1993 */
1036
1037 ptr_psi_term u;
1038 ptr_psi_term v;
1039 {
1040 int success=TRUE;
1041 int compare;
1042 ptr_definition new_type;
1043 ptr_int_list new_code;
1044
1045 deref_ptr(u);
1046 deref_ptr(v);
1047
1048 traceline("match persistent %P with %P\n",u,v);
1049
1050 /* printf("u=%ld, v=%ld, heap_pointer=%ld\n",u,v,heap_pointer);*/
1051
1052 /* printf("u=%s, v=%s\n",
1053 u->type->keyword->symbol,
1054 v->type->keyword->symbol); */
1055
1056 if((GENERIC)u>=heap_pointer) {
1057 Errorline("cannot unify persistent values\n");
1058 return c_abort();
1059 }
1060
1061 /**** U is on the stack, V is on the heap ****/
1062
1063 /**** Calculate their Greatest Lower Bound and compare them ****/
1064 compare=glb(u->type,v->type,&new_type,&new_code);
1065
1066 /* printf("compare=%d\n",compare); */
1067
1068 if (compare==1 || compare==3) { /* Match only */
1069
1070 /**** Check for values ****/
1071 if(v->value_3) {
1072 if(u->value_3) {
1073 if(u->value_3!=v->value_3) { /* One never knows */
1074 if (overlap_type(v->type,real))
1075 success=(*((REAL *)u->value_3)==(*((REAL *)v->value_3)));
1076 else if (overlap_type(v->type,quoted_string))
1077 success=(strcmp((char *)u->value_3,(char *)v->value_3)==0);
1078 else
1079 return FALSE; /* Don't unify CUTs and STREAMs and things */
1080 }
1081 }
1082 }
1083 else
1084 if(u->value_3)
1085 return FALSE;
1086
1087 if(success) {
1088 /**** Bind the two psi-terms ****/
1089 push_psi_ptr_value(u,(GENERIC *)&(u->coref));
1090 u->coref=v;
1091
1092 /**** Match the attributes ****/
1093 success=global_unify_attr(u->attr_list,v->attr_list);
1094
1095 /*
1096 if(!success)
1097 warningline("attributes don't unify in %P and %P\n",u,v);
1098 */
1099
1100 if(success && u->resid)
1101 release_resid(u);
1102 }
1103 }
1104 else
1105 success=FALSE;
1106
1107 return success;
1108 }
1109
1110
1111
1112 /******** GLOBAL_UNIFY_ATTR(u,v)
1113 Unify the attributes of two terms, one on the heap, one on the stack.
1114 This is really matching, so all features of U must appear in V.
1115 */
1116
1117 int global_unify_attr(u,v) /* RM: Feb 9 1993 */
1118
1119 ptr_node u;
1120 ptr_node v;
1121 {
1122 int success=TRUE;
1123 ptr_node temp;
1124 long cmp;
1125
1126 if(u)
1127 if(v) {
1128 /* RM: Feb 16 1993 Avoid C optimiser bug */
1129 (void)dummy_printf("%s %s\n",u->key,v->key);
1130
1131 cmp=featcmp(u->key,v->key);
1132 if(cmp<0) {
1133 temp=u->right;
1134 u->right=NULL;
1135 success=global_unify_attr(u,v->left) && global_unify_attr(temp,v);
1136 u->right=temp;
1137 }
1138 else
1139 if(cmp>0) {
1140 temp=u->left;
1141 u->left=NULL;
1142 success=global_unify_attr(u,v->right) && global_unify_attr(temp,v);
1143 u->left=temp;
1144 }
1145 else {
1146 success=
1147 global_unify_attr(u->left,v->left) &&
1148 global_unify_attr(u->right,v->right) &&
1149 global_unify((ptr_psi_term)u->data,(ptr_psi_term)v->data);
1150 }
1151 }
1152 else
1153 success=FALSE;
1154
1155 return success;
1156 }
1157
1158
1159
1160 /******** C_ALIAS
1161 Alias one keyword to another.
1162 */
1163
1164 long c_alias()
1165 {
1166 long success=TRUE;
1167 ptr_psi_term arg1,arg2,g;
1168 ptr_keyword key;
1169
1170 g=aim->aaaa_1;
1171
1172 deref_ptr(g);
1173 get_two_args(g->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
1174 if (arg1 && arg2) {
1175 deref_ptr(arg1);
1176 deref_ptr(arg2);
1177
1178 key=hash_lookup(current_module->symbol_table,arg1->type->keyword->symbol);
1179 if(key) {
1180 if(key->definition!=arg2->type) {
1181 warningline("alias: '%s' has now been overwritten by '%s'\n",
1182 key->combined_name,
1183 arg2->type->keyword->combined_name);
1184
1185 key->definition=arg2->type;
1186 }
1187 }
1188 else
1189 Errorline("module violation: cannot alias '%s' from module \"%s\"\n",
1190 key->combined_name,
1191 current_module->module_name);
1192 }
1193 else {
1194 success=FALSE;
1195 Errorline("argument(s) missing in '%P'\n",g);
1196 }
1197
1198 return success;
1199 }
1200
1201
1202
1203 /******** GET_MODULE(psi,module,resid)
1204 Convert a psi-term to a module. The psi-term must be a string.
1205 */
1206
1207 int get_module(psi,module)
1208
1209 ptr_psi_term psi;
1210 ptr_module *module;
1211 {
1212 int success=TRUE;
1213 char *s;
1214
1215 *module=NULL;
1216
1217 deref_ptr(psi);
1218 if(overlap_type(psi->type,quoted_string) && psi->value_3)
1219 s=(char *)psi->value_3;
1220 else
1221 s=psi->type->keyword->symbol;
1222
1223 *module=find_module(s);
1224 if(!(*module)) {
1225 Errorline("undefined module \"%s\"\n",s);
1226 success=FALSE;
1227 }
1228
1229 return success;
1230 }
1231
1232
1233
1234
1235 /******** MAKE_FEATURE_PRIVATE(feature)
1236 Make a feature private.
1237 */
1238
1239 int make_feature_private(term) /* RM: Mar 11 1993 */
1240
1241 ptr_psi_term term;
1242 {
1243 int ok=TRUE;
1244 ptr_keyword key;
1245 ptr_definition def;
1246
1247 deref_ptr(term);
1248
1249 key=hash_lookup(current_module->symbol_table,term->type->keyword->symbol);
1250
1251 if(key) {
1252 /*
1253 if(key->definition->keyword->module!=current_module) {
1254 warningline("local definition of '%s' overrides '%s'\n",
1255 key->definition->keyword->symbol,
1256 key->definition->keyword->combined_name);
1257
1258 new_definition(key);
1259 }
1260 */
1261
1262 key->private_feature=TRUE;
1263 def=key->definition;
1264 }
1265 else {
1266 def=update_symbol(current_module,term->type->keyword->symbol);
1267 def->keyword->private_feature=TRUE;
1268 }
1269
1270
1271 if(ok && def->keyword->public) {
1272 warningline("feature '%s' is now private, but was also declared public\n",
1273 def->keyword->combined_name);
1274 }
1275
1276 return ok;
1277 }
1278
1279
1280
1281
1282
1283 /******** C_PRIVATE_FEATURE()
1284 The argument is a single symbol or a list of symbols.
1285 Make this feature private to the current module.
1286 */
1287
1288 long c_private_feature() /* RM: Mar 11 1993 */
1289
1290 {
1291 // ptr_psi_term arg1,arg2;
1292 ptr_psi_term call;
1293 int success;
1294
1295 call=aim->aaaa_1;
1296 deref_ptr(call);
1297 if (call->attr_list) {
1298 traverse_tree(call->attr_list,MAKE_FEATURE_PRIVATE);
1299 success=TRUE;
1300 } else {
1301 Errorline("argument missing in '%P'\n",call);
1302 success=FALSE;
1303 }
1304
1305 return success;
1306 }
1307
1308
1309
1310 /********* UPDATE_FEATURE(module,feature)
1311 Look up a FEATURE.
1312 May return NULL if the FEATURE is not visible from MODULE.
1313 */
1314
1315 ptr_definition update_feature(module,feature)
1316
1317 ptr_module module;
1318 char *feature;
1319 {
1320 ptr_keyword key;
1321 ptr_module explicit;
1322
1323 /* Check if the feature already contains a module name */
1324
1325 if(!module)
1326 module=current_module;
1327
1328 explicit=extract_module_from_name(feature);
1329 if(explicit)
1330 if(explicit!=module)
1331 return NULL; /* Feature isn't visible */
1332 else
1333 return update_symbol(NULL,feature);
1334
1335 /* Now we have a simple feature to look up */
1336 key=hash_lookup(module->symbol_table,feature);
1337 if(key && key->private_feature)
1338 return key->definition;
1339 else
1340 return update_symbol(module,feature);
1341 }
1342
1343
1344
1345 /******** ALL_PUBLIC_SYMBOLS
1346 Returns all public symbols from all modules or a specific module.
1347 */
1348
1349 long all_public_symbols()
1350 {
1351 ptr_psi_term arg1,arg2,funct,result;
1352 ptr_psi_term list;
1353 ptr_psi_term car;
1354 ptr_module module=NULL;
1355 ptr_definition d;
1356
1357 funct=aim->aaaa_1;
1358 deref_ptr(funct);
1359 result=aim->bbbb_1;
1360 get_two_args(funct->attr_list,(ptr_psi_term *)&arg1,(ptr_psi_term *)&arg2);
1361
1362 if(arg1) {
1363 deref_ptr(arg1);
1364 (void)get_module(arg1,&module);
1365 }
1366 else
1367 module=NULL;
1368
1369 list=stack_nil();
1370
1371 for(d=first_definition;d;d=d->next)
1372 if(d->keyword->public && (!module || d->keyword->module==module)) {
1373 car=stack_psi_term(4);
1374 car->type=d;
1375 list=stack_cons(car,list);
1376 }
1377
1378 push_goal(unify,result,list,NULL);
1379
1380 return TRUE;
1381 }
init_modules
void init_modules()
Definition: modules.c:30
module_table
ptr_node module_table
Definition: modules.c:12
wl_goal::aaaa_1
ptr_psi_term aaaa_1
Definition: def_struct.h:224
hash_lookup
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
Definition: hash_table.c:133
wl_definition::already_loaded
char already_loaded
Definition: def_struct.h:137
get_two_args
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
Definition: login.c:37
user_module
ptr_module user_module
Definition: modules.c:20
translate
ptr_psi_term translate(ptr_psi_term a, long **infoptr)
Definition: copy.c:101
wl_definition::init_value
ptr_psi_term init_value
Definition: def_struct.h:142
display_persistent
long display_persistent
Definition: def_glob.h:165
c_public
long c_public()
Definition: modules.c:671
FEATCMP
#define FEATCMP
Definition: def_const.h:257
display_modules
long display_modules
Definition: modules.c:23
clear_copy
void clear_copy()
Definition: copy.c:52
def_type
struct wl_definition * def_type
Definition: def_struct.h:32
stack_cons
ptr_psi_term stack_cons(ptr_psi_term head, ptr_psi_term tail)
Definition: built_ins.c:47
wl_definition::evaluate_args
char evaluate_args
Definition: def_struct.h:136
wl_keyword::combined_name
char * combined_name
Definition: def_struct.h:92
traverse_tree
void traverse_tree(ptr_node n, int flag)
Definition: modules.c:640
glb
long glb(ptr_definition t1, ptr_definition t2, ptr_definition *t3, ptr_int_list *c3)
Definition: types.c:1388
c_open_module
long c_open_module()
Definition: modules.c:514
push_ptr_value
void push_ptr_value(type_ptr t, GENERIC *p)
Definition: login.c:360
push_goal
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:555
def_ptr
#define def_ptr
Definition: def_const.h:173
new_definition
ptr_definition new_definition(ptr_keyword key)
Definition: modules.c:215
global_unify_attr
int global_unify_attr(ptr_node, ptr_node)
Definition: modules.c:1117
legal_in_name
long legal_in_name(long c)
Definition: token.c:861
input_file_name
string input_file_name
Definition: def_glob.h:40
NOT_CODED
#define NOT_CODED
Definition: def_const.h:134
undef
#define undef
Definition: def_const.h:360
replace_attr
void replace_attr(ptr_node, ptr_psi_term, ptr_definition, ptr_definition)
Definition: modules.c:875
wl_module
Definition: def_struct.h:74
push_psi_ptr_value
void push_psi_ptr_value(ptr_psi_term q, GENERIC *p)
Definition: login.c:443
wl_keyword::definition
ptr_definition definition
Definition: def_struct.h:96
c_private_feature
long c_private_feature()
Definition: modules.c:1288
wl_definition::type_def
def_type type_def
Definition: def_struct.h:133
defs.h
wl_psi_term
Definition: def_struct.h:161
open_module_tree
void open_module_tree(ptr_node n, int *onefailed)
Definition: modules.c:533
global_unify
int global_unify(ptr_psi_term u, ptr_psi_term v)
Definition: modules.c:1035
sys_module
ptr_module sys_module
Definition: modules.c:17
c_abort
long c_abort()
Definition: built_ins.c:2117
wl_module::symbol_table
ptr_hash_table symbol_table
Definition: def_struct.h:79
hash_create
ptr_hash_table hash_create(int size)
Definition: hash_table.c:26
wl_definition::keyword
ptr_keyword keyword
Definition: def_struct.h:124
insert_translation
void insert_translation(ptr_psi_term a, ptr_psi_term b, long info)
Definition: copy.c:63
wl_node::data
GENERIC data
Definition: def_struct.h:185
NULL
#define NULL
Definition: def_const.h:203
current_module
ptr_module current_module
Definition: modules.c:13
three
char * three
Definition: def_glob.h:252
wl_keyword::symbol
char * symbol
Definition: def_struct.h:91
module_buffer
string module_buffer
Definition: def_glob.h:312
resid_aim
ptr_goal resid_aim
Definition: def_glob.h:220
overlap_type
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
REAL
#define REAL
Definition: def_const.h:72
c_trace_input
long c_trace_input()
Definition: modules.c:795
heap_insert
ptr_node heap_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:276
wl_definition::always_check
char always_check
Definition: def_struct.h:134
bi_module
ptr_module bi_module
Definition: modules.c:15
open_module_one
void open_module_one(ptr_psi_term t, int *onefailed)
Definition: modules.c:550
release_resid
void release_resid(ptr_psi_term t)
Definition: lefun.c:414
wl_node::left
ptr_node left
Definition: def_struct.h:183
traceline
void traceline(char *format,...)
Definition: error.c:157
wl_int_list
Definition: def_struct.h:53
strip_module_name
char * strip_module_name(char *str)
Definition: modules.c:139
trace_input
long trace_input
Definition: def_glob.h:167
ptr_module
struct wl_module * ptr_module
Definition: def_struct.h:83
print_symbol
char * print_symbol(ptr_keyword k)
Definition: modules.c:429
wl_definition::next
ptr_definition next
Definition: def_struct.h:148
Errorline
void Errorline(char *format,...)
Definition: error.c:414
heap_copy_string
char * heap_copy_string(char *s)
Definition: trees.c:147
real
ptr_definition real
Definition: def_glob.h:102
MAKE_PRIVATE
#define MAKE_PRIVATE
Definition: modules.c:634
stack_insert
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:291
update_symbol
ptr_definition update_symbol(ptr_module module, char *symbol)
Definition: modules.c:264
deref_ptr
#define deref_ptr(P)
Definition: def_macro.h:95
all_public_symbols
long all_public_symbols()
Definition: modules.c:1349
hash_insert
void hash_insert(ptr_hash_table table, char *symbol, ptr_keyword keyword)
Definition: hash_table.c:155
wl_node::key
char * key
Definition: def_struct.h:182
TRUE
#define TRUE
Definition: def_const.h:127
first_definition
ptr_definition first_definition
Definition: def_glob.h:3
STRCMP
#define STRCMP
Definition: def_const.h:255
error_psi_term
ptr_psi_term error_psi_term
Definition: def_glob.h:23
replace
void replace(ptr_definition old, ptr_definition new, ptr_psi_term term)
Definition: modules.c:834
wl_definition::date
long date
Definition: def_struct.h:122
lf_true
ptr_definition lf_true
Definition: def_glob.h:107
wl_definition::rule
ptr_pair_list rule
Definition: def_struct.h:126
wl_definition::global_value
ptr_psi_term global_value
Definition: def_struct.h:141
FALSE
#define FALSE
Definition: def_const.h:128
quoted_string
ptr_definition quoted_string
Definition: def_glob.h:101
make_feature_private
int make_feature_private(ptr_psi_term term)
Definition: modules.c:1239
rec_replace
void rec_replace(ptr_definition, ptr_definition, ptr_psi_term)
Definition: modules.c:846
wl_keyword
Definition: def_struct.h:89
stack_psi_term
ptr_psi_term stack_psi_term(long stat)
Definition: lefun.c:15
pretty_quote_symbol
void pretty_quote_symbol(ptr_keyword k)
Definition: modules.c:464
wl_psi_term::value_3
GENERIC value_3
Definition: def_struct.h:170
lf_false
ptr_definition lf_false
Definition: def_glob.h:89
stack_nil
ptr_psi_term stack_nil()
Definition: built_ins.c:29
aim
ptr_goal aim
Definition: def_glob.h:49
wl_module::module_name
char * module_name
Definition: def_struct.h:75
heap_pointer
GENERIC heap_pointer
Definition: def_glob.h:12
create_module
ptr_module create_module(char *module)
Definition: modules.c:67
x_module
ptr_module x_module
Definition: modules.c:21
unify
#define unify
Definition: def_const.h:274
find
ptr_node find(long comp, char *keystr, ptr_node tree)
Definition: trees.c:341
wl_module::open_modules
ptr_int_list open_modules
Definition: def_struct.h:77
dummy_printf
int dummy_printf(char *f, char *s, char *t)
Definition: login.c:2482
featcmp
long featcmp(char *str1, char *str2)
Definition: trees.c:89
pretty_symbol
void pretty_symbol(ptr_keyword k)
Definition: modules.c:446
string_val
char * string_val(ptr_psi_term term)
Definition: modules.c:164
wl_definition
Definition: def_struct.h:121
wl_keyword::module
ptr_module module
Definition: def_struct.h:90
prettyf
void prettyf(char *s)
Definition: print.c:447
make_public
long make_public(ptr_psi_term term, long bool)
Definition: modules.c:600
c_display_persistent
long c_display_persistent()
Definition: modules.c:759
update_feature
ptr_definition update_feature(ptr_module module, char *feature)
Definition: modules.c:1315
wl_definition::protected
char protected
Definition: def_struct.h:135
ptr_psi_term
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
c_alias
long c_alias()
Definition: modules.c:1164
c_module_access
long c_module_access()
Definition: modules.c:993
MAKE_FEATURE_PRIVATE
#define MAKE_FEATURE_PRIVATE
Definition: modules.c:635
find_module
ptr_module find_module(char *module)
Definition: modules.c:48
MAKE_PUBLIC
#define MAKE_PUBLIC
Definition: modules.c:633
wl_keyword::private_feature
int private_feature
Definition: def_struct.h:95
no_module
ptr_module no_module
Definition: modules.c:14
c_current_module
long c_current_module()
Definition: modules.c:956
wl_definition::code
ptr_int_list code
Definition: def_struct.h:129
extract_module_from_name
ptr_module extract_module_from_name(char *str)
Definition: modules.c:111
warningline
void warningline(char *format,...)
Definition: error.c:327
wl_keyword::public
int public
Definition: def_struct.h:94
wl_node
Definition: def_struct.h:181
wl_psi_term::type
ptr_definition type
Definition: def_struct.h:165
get_module
int get_module(ptr_psi_term psi, ptr_module *module)
Definition: modules.c:1207
wl_int_list::value_1
GENERIC value_1
Definition: def_struct.h:54
wl_goal::bbbb_1
ptr_psi_term bbbb_1
Definition: def_struct.h:225
prettyf_quote
void prettyf_quote(char *s)
Definition: print.c:474
GENERIC
unsigned long * GENERIC
Definition: def_struct.h:17
wl_definition::properties
ptr_triple_list properties
Definition: def_struct.h:127
c_replace
long c_replace()
Definition: modules.c:917
wl_definition::children
ptr_int_list children
Definition: def_struct.h:131
HEAP_ALLOC
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
make_module_token
char * make_module_token(ptr_module module, char *str)
Definition: modules.c:185
set_current_module
ptr_module set_current_module(ptr_module module)
Definition: modules.c:95
wl_psi_term::attr_list
ptr_node attr_list
Definition: def_struct.h:171
c_private
long c_private()
Definition: modules.c:697
c_set_module
long c_set_module()
Definition: modules.c:483
wl_definition::op_data
ptr_operator_data op_data
Definition: def_struct.h:139
syntax_module
ptr_module syntax_module
Definition: modules.c:16
wl_node::right
ptr_node right
Definition: def_struct.h:184
wl_int_list::next
ptr_int_list next
Definition: def_struct.h:55
c_display_modules
long c_display_modules()
Definition: modules.c:723
wl_definition::parents
ptr_int_list parents
Definition: def_struct.h:130
int_ptr
#define int_ptr
Definition: def_const.h:172