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