Wild Life  2.29
 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 */
18 
19 // set NULL next 2 DJD
22 
23 long display_modules=TRUE; /* Should really default to FALSE */
24 
25 
26 /******** INIT_MODULES()
27  Initialize the module system.
28  */
29 
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 
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 
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 
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 
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 
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 
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 
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 
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) {
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 
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,
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;
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) {
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) {
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 
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)
739  else
740  if(arg1->type==lf_false)
742  else {
743  Errorline("argument should be boolean in '%P'\n",call);
744  success=FALSE;
745  }
746  }
747  else /* No argument: toggle */
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)
775  else
776  if(arg1->type==lf_false)
778  else {
779  Errorline("argument should be boolean in '%P'\n",call);
780  success=FALSE;
781  }
782  }
783  else /* No argument: toggle */
785 
786  return success;
787 }
788 
789 
790 
791 /******** C_TRACE_INPUT();
792  Set the trace_input switch.
793  */
794 
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)
811  else
812  if(arg1->type==lf_false)
814  else {
815  Errorline("argument should be boolean in '%P'\n",call);
816  success=FALSE;
817  }
818  }
819  else /* No argument: toggle */
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 
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) {
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 
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 
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) &&
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);
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) {
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 
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 
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 }
void init_modules()
Definition: modules.c:30
ptr_node module_table
Definition: modules.c:12
ptr_psi_term aaaa_1
Definition: def_struct.h:224
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
Definition: hash_table.c:133
char already_loaded
Definition: def_struct.h:137
void get_two_args(ptr_node t, ptr_psi_term *a, ptr_psi_term *b)
Definition: login.c:37
ptr_module user_module
Definition: modules.c:20
ptr_psi_term translate(ptr_psi_term a, long **infoptr)
Definition: copy.c:101
ptr_psi_term init_value
Definition: def_struct.h:142
long display_persistent
Definition: def_glob.h:165
long c_public()
Definition: modules.c:671
#define FEATCMP
Definition: def_const.h:257
long display_modules
Definition: modules.c:23
void clear_copy()
Definition: copy.c:52
struct wl_definition * def_type
Definition: def_struct.h:32
ptr_psi_term stack_cons(ptr_psi_term head, ptr_psi_term tail)
Definition: built_ins.c:47
char evaluate_args
Definition: def_struct.h:136
char * combined_name
Definition: def_struct.h:92
void traverse_tree(ptr_node n, int flag)
Definition: modules.c:640
long glb(ptr_definition t1, ptr_definition t2, ptr_definition *t3, ptr_int_list *c3)
Definition: types.c:1388
long c_open_module()
Definition: modules.c:514
void push_ptr_value(type_ptr t, GENERIC *p)
Definition: login.c:360
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:555
#define def_ptr
Definition: def_const.h:173
ptr_definition new_definition(ptr_keyword key)
Definition: modules.c:215
int global_unify_attr(ptr_node, ptr_node)
Definition: modules.c:1117
long legal_in_name(long c)
Definition: token.c:861
string input_file_name
Definition: def_glob.h:40
#define NOT_CODED
Definition: def_const.h:134
#define undef
Definition: def_const.h:360
void replace_attr(ptr_node, ptr_psi_term, ptr_definition, ptr_definition)
Definition: modules.c:875
void push_psi_ptr_value(ptr_psi_term q, GENERIC *p)
Definition: login.c:443
ptr_definition definition
Definition: def_struct.h:96
long c_private_feature()
Definition: modules.c:1288
def_type type_def
Definition: def_struct.h:133
void open_module_tree(ptr_node n, int *onefailed)
Definition: modules.c:533
int global_unify(ptr_psi_term u, ptr_psi_term v)
Definition: modules.c:1035
ptr_module sys_module
Definition: modules.c:17
long c_abort()
Definition: built_ins.c:2117
ptr_hash_table symbol_table
Definition: def_struct.h:79
ptr_hash_table hash_create(int size)
Definition: hash_table.c:26
ptr_keyword keyword
Definition: def_struct.h:124
void insert_translation(ptr_psi_term a, ptr_psi_term b, long info)
Definition: copy.c:63
GENERIC data
Definition: def_struct.h:185
#define NULL
Definition: def_const.h:203
ptr_module current_module
Definition: modules.c:13
char * three
Definition: def_glob.h:252
char * symbol
Definition: def_struct.h:91
string module_buffer
Definition: def_glob.h:312
ptr_goal resid_aim
Definition: def_glob.h:220
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
#define REAL
Definition: def_const.h:72
long c_trace_input()
Definition: modules.c:795
ptr_node heap_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:276
char always_check
Definition: def_struct.h:134
ptr_module bi_module
Definition: modules.c:15
void open_module_one(ptr_psi_term t, int *onefailed)
Definition: modules.c:550
void release_resid(ptr_psi_term t)
Definition: lefun.c:414
ptr_node left
Definition: def_struct.h:183
void traceline(char *format,...)
Definition: error.c:157
char * strip_module_name(char *str)
Definition: modules.c:139
long trace_input
Definition: def_glob.h:167
struct wl_module * ptr_module
Definition: def_struct.h:83
char * print_symbol(ptr_keyword k)
Definition: modules.c:429
ptr_definition next
Definition: def_struct.h:148
void Errorline(char *format,...)
Definition: error.c:414
char * heap_copy_string(char *s)
Definition: trees.c:147
ptr_definition real
Definition: def_glob.h:102
#define MAKE_PRIVATE
Definition: modules.c:634
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:291
ptr_definition update_symbol(ptr_module module, char *symbol)
Definition: modules.c:264
#define deref_ptr(P)
Definition: def_macro.h:95
long all_public_symbols()
Definition: modules.c:1349
void hash_insert(ptr_hash_table table, char *symbol, ptr_keyword keyword)
Definition: hash_table.c:155
char * key
Definition: def_struct.h:182
#define TRUE
Definition: def_const.h:127
ptr_definition first_definition
Definition: def_glob.h:3
#define STRCMP
Definition: def_const.h:255
ptr_psi_term error_psi_term
Definition: def_glob.h:23
void replace(ptr_definition old, ptr_definition new, ptr_psi_term term)
Definition: modules.c:834
ptr_definition lf_true
Definition: def_glob.h:107
ptr_pair_list rule
Definition: def_struct.h:126
ptr_psi_term global_value
Definition: def_struct.h:141
#define FALSE
Definition: def_const.h:128
ptr_definition quoted_string
Definition: def_glob.h:101
int make_feature_private(ptr_psi_term term)
Definition: modules.c:1239
void rec_replace(ptr_definition, ptr_definition, ptr_psi_term)
Definition: modules.c:846
ptr_psi_term stack_psi_term(long stat)
Definition: lefun.c:15
void pretty_quote_symbol(ptr_keyword k)
Definition: modules.c:464
GENERIC value_3
Definition: def_struct.h:170
ptr_definition lf_false
Definition: def_glob.h:89
ptr_psi_term stack_nil()
Definition: built_ins.c:29
ptr_goal aim
Definition: def_glob.h:49
char * module_name
Definition: def_struct.h:75
GENERIC heap_pointer
Definition: def_glob.h:12
ptr_module create_module(char *module)
Definition: modules.c:67
ptr_module x_module
Definition: modules.c:21
#define unify
Definition: def_const.h:274
ptr_node find(long comp, char *keystr, ptr_node tree)
Definition: trees.c:341
ptr_int_list open_modules
Definition: def_struct.h:77
int dummy_printf(char *f, char *s, char *t)
Definition: login.c:2482
long featcmp(char *str1, char *str2)
Definition: trees.c:89
void pretty_symbol(ptr_keyword k)
Definition: modules.c:446
char * string_val(ptr_psi_term term)
Definition: modules.c:164
ptr_module module
Definition: def_struct.h:90
void prettyf(char *s)
Definition: print.c:447
long make_public(ptr_psi_term term, long bool)
Definition: modules.c:600
long c_display_persistent()
Definition: modules.c:759
ptr_definition update_feature(ptr_module module, char *feature)
Definition: modules.c:1315
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
long c_alias()
Definition: modules.c:1164
long c_module_access()
Definition: modules.c:993
#define MAKE_FEATURE_PRIVATE
Definition: modules.c:635
ptr_module find_module(char *module)
Definition: modules.c:48
#define MAKE_PUBLIC
Definition: modules.c:633
int private_feature
Definition: def_struct.h:95
ptr_module no_module
Definition: modules.c:14
long c_current_module()
Definition: modules.c:956
ptr_int_list code
Definition: def_struct.h:129
ptr_module extract_module_from_name(char *str)
Definition: modules.c:111
void warningline(char *format,...)
Definition: error.c:327
int public
Definition: def_struct.h:94
ptr_definition type
Definition: def_struct.h:165
int get_module(ptr_psi_term psi, ptr_module *module)
Definition: modules.c:1207
GENERIC value_1
Definition: def_struct.h:54
ptr_psi_term bbbb_1
Definition: def_struct.h:225
void prettyf_quote(char *s)
Definition: print.c:474
unsigned long * GENERIC
Definition: def_struct.h:17
ptr_triple_list properties
Definition: def_struct.h:127
long c_replace()
Definition: modules.c:917
ptr_int_list children
Definition: def_struct.h:131
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
char * make_module_token(ptr_module module, char *str)
Definition: modules.c:185
ptr_module set_current_module(ptr_module module)
Definition: modules.c:95
ptr_node attr_list
Definition: def_struct.h:171
long c_private()
Definition: modules.c:697
long c_set_module()
Definition: modules.c:483
ptr_operator_data op_data
Definition: def_struct.h:139
ptr_module syntax_module
Definition: modules.c:16
ptr_node right
Definition: def_struct.h:184
ptr_int_list next
Definition: def_struct.h:55
long c_display_modules()
Definition: modules.c:723
ptr_int_list parents
Definition: def_struct.h:130
#define int_ptr
Definition: def_const.h:172