types.c

Go to the documentation of this file.

/* Copyright 1991 Digital Equipment Corporation.
** All Rights Reserved.
*****************************************************************/

#include "defs.h"

ptr_definition *gamma_table = NULL;

void print_def_type(def_type t)
{
  switch ((long)t) {
  case (long)predicate_it:
    perr("predicate");
    break;
  case (long)function_it:
    perr("function");
    break;
  case (long)type_it:
    perr("sort");
    break;
  case (long)global_it: /*  RM: Feb  8 1993  */
    perr("global variable");
    break;
  default:
    perr("undefined");
  }
}

long yes_or_no()
{
  char *old_prompt;
  long c,d;
  ptr_psi_term old_state_loc;

  perr("*** Are you really sure you want to do that ");
  old_prompt=prompt;
  prompt="(y/n)?";
  old_state_loc=input_state;
  (void)open_input_file("stdin");

  do {
    do {
      c=read_char();
    } while (c!=EOLN && c>0 && c<=32);
  } while (c!='y' && c!='n');

  d=c;
  while (d!=EOLN && d!=EOF) d=read_char();

  prompt=old_prompt;
  input_state=old_state_loc;
  restore_state(old_state_loc);
  return (c=='y');
}

void remove_cycles(ptr_definition d, ptr_int_list *dl)
{
  while (*dl) {
    if (((ptr_definition)(*dl)->value_1)==d)
      *dl = (*dl)->next;
    else
      dl= &((*dl)->next);
  }
}

long redefine(ptr_psi_term t)
{
  ptr_definition d; // ,d2;
  //  ptr_int_list l,*l2;
  long success=TRUE;
  
  deref_ptr(t);
  d=t->type;
  if (d->date<file_date) {
    if (d->type_def==(def_type)type_it) {
      /* Except for top, sorts are always unprotected, with a warning. */
      if (FALSE /*d==top*/) {
        Errorline("the top sort '@' may not be extended.\n");
        success=FALSE;
      }
      /*  RM: Mar 25 1993
    else if (d!=top)
        warningline("extending definition of sort '%s'.\n",d->keyword->symbol);
    */
    }
    else if (d->protected && d->type_def!=(def_type)undef_it) {
      if (d->date>0) {
        /* The term was entered in a previous file, and therefore */
        /* cannot be altered. */
        Errorline("the %T '%s' may not be changed.\n", /*  RM: Jan 27 1993  */
                  d->type_def, d->keyword->combined_name);
        success=FALSE;
      }
      else {
        if (d->rule && (unsigned long)d->rule<=MAX_BUILT_INS /*&& input_stream==stdin*/) {
          /* d is a built-in, and therefore cannot be altered. */
          Errorline("the built-in %T '%s' may not be extended.\n",
                    d->type_def, d->keyword->symbol);
          success=FALSE;
        }
        else {
          /* d is not a built-in, and therefore can be altered. */
          warningline("extending the %T '%s'.\n",d->type_def,d->keyword->symbol);
          if (warningflag) if (!yes_or_no()) success=FALSE;
        }
      }
    }
    
    if (success) {
      if (d->type_def==(def_type)type_it) { /* d is an already existing type */
        /* Remove cycles in the type hierarchy of d */
        /* This is done by Richard's version, and I don't know why. */
        /* It seems to be a no-op. */
        remove_cycles(d, &(d->children));
        remove_cycles(d, &(d->parents));
        /* d->rule=NULL; */ /* Types must keep their rules! */
        /* d->properties=NULL; */ /* Types get new properties from encode */
      }
      if (d->date==0) d->date=file_date;
      /* d->type=undef_it; */ /* Objects keep their type! */
      /* d->always_check=TRUE; */
      /* d->protected=TRUE; */
      /* d->children=NULL; */
      /* d->parents=NULL; */
      /* d->code=NOT_CODED; */
    }
  }

  return success;
}

ptr_int_list cons(GENERIC v,ptr_int_list l)
{
  ptr_int_list n;

  n=HEAP_ALLOC(int_list);
  n->value_1=v;
  n->next=l;
  
  return n;
}

long assert_less(ptr_psi_term t1,ptr_psi_term t2)
{
  ptr_definition d1,d2; 
  long ok=FALSE;
  deref_ptr(t1);
  deref_ptr(t2);

  if (t1->type==top) {
    Errorline("the top sort '@' may not be a subsort.\n");
    return FALSE;
  }
  if (t1->value_3 || t2->value_3) {
    Errorline("the declaration '%P <| %P' is illegal.\n",t1,t2);
    return FALSE;
  }
  /* Note: A *full* cyclicity check of the hierarchy is done in encode_types. */
  if (t1->type==t2->type) {
    Errorline("cyclic sort declarations are not allowed.\n");
    return FALSE;
  }
    
  if (!redefine(t1)) return FALSE;
  if (!redefine(t2)) return FALSE;
  d1=t1->type;
  d2=t2->type;
  if (d1->type_def==(def_type)predicate_it || d1->type_def==(def_type)function_it) {
    Errorline("the %T '%s' may not be redefined as a sort.\n",  
              d1->type_def, d1->keyword->symbol);
  }
  else if (d2->type_def==(def_type)predicate_it || d2->type_def==(def_type)function_it) {
    Errorline("the %T '%s' may not be redefined as a sort.\n",  
              d2->type_def, d2->keyword->symbol);
  }
  else {
    d1->type_def=(def_type)type_it;
    d2->type_def=(def_type)type_it;
    types_modified=TRUE;
    make_type_link(d1, d2); /* 1.7 */
    /* d1->parents=cons(d2,d1->parents); */
    /* d2->children=cons(d1,d2->children); */
    ok=TRUE;
  }
  
  return ok;
}

void assert_protected(ptr_node n,long prot)
{
  ptr_psi_term t;

  if (n) {
    assert_protected(n->left,prot);
    
    t=(ptr_psi_term)n->data;
    deref_ptr(t);
    if (t->type) {
      if (t->type->type_def==(def_type)type_it) {
        warningline("'%s' is a sort. It can be extended without a declaration.\n",
                    t->type->keyword->symbol);
      }
      else if ((unsigned long)t->type->rule<MAX_BUILT_INS &&
               (unsigned long)t->type->rule>0) {
        if (!prot)
          warningline("'%s' is a built-in--it has not been made dynamic.\n",
                      t->type->keyword->symbol);
      }
      else {
        t->type->protected=prot;
        if (prot) t->type->date&=(~1); else t->type->date|=1;
      }
    }

    assert_protected(n->right,prot);
  }
}

void assert_args_not_eval(ptr_node n)
{
  ptr_psi_term t;

  if (n) {
    assert_args_not_eval(n->left);
    
    t=(ptr_psi_term)n->data;
    deref_ptr(t);
    if (t->type) {
      if (t->type->type_def==(def_type)type_it) {
        warningline("'%s' is a sort--only functions and predicates\
 can have unevaluated arguments.\n",t->type->keyword->symbol);
      }
      else
        t->type->evaluate_args=FALSE;
    }

    assert_args_not_eval(n->right);
  }
}

void assert_delay_check(ptr_node n)
{
  if (n) {
    ptr_psi_term t;
    assert_delay_check(n->left);
    
    t=(ptr_psi_term)n->data;
    deref_ptr(t);
    if (t->type) {
      t->type->always_check=FALSE;
    }

    assert_delay_check(n->right);
  }
}

void clear_already_loaded(ptr_node n)
{
  ptr_definition d;

  if (n) {
    d=((ptr_keyword)n->data)->definition;
    d->already_loaded=FALSE;
    clear_already_loaded(n->left);
    clear_already_loaded(n->right);
  }
}

void assert_type(ptr_psi_term t)
{
  ptr_psi_term arg1,arg2;

  get_two_args(t->attr_list,&arg1,&arg2);
  if(arg1==NULL || arg2==NULL) {
    Errorline("bad sort declaration '%P' (%E).\n",t);
  }
  else
    assert_ok=assert_less(arg1,arg2);
}

void assert_complicated_type(ptr_psi_term t)
{
  ptr_psi_term arg2,typ1,typ2,pred=NULL;
  // ptr_list lst;
  long eqflag = equ_tok((*t),":=");
  long ok, any_ok=FALSE;
  
  get_two_args(t->attr_list,&typ1,&arg2);
  
  if (typ1 && arg2) {
    deref_ptr(typ1);
    deref_ptr(arg2);
    typ2=arg2;
    if (!strcmp(arg2->type->keyword->symbol,"|")) {
      typ2=NULL;
      get_two_args(arg2->attr_list,&arg2,&pred);
      if (arg2) {
        deref_ptr(arg2);
        typ2=arg2;
      }
    }
    if (typ2) {
      if (typ2->type==disjunction) {
    
        if (typ1->attr_list && eqflag) {
          warningline("attributes ignored left of ':=' declaration (%E).\n");
        }
        while(typ2 && typ2->type!=nil) {
          get_two_args(typ2->attr_list,&arg2,&typ2); /*  RM: Dec 14 1992  */
          if(typ2)
        deref_ptr(typ2);
          if (arg2) {
            deref_ptr(arg2);
            if (eqflag) {
              ok=assert_less(arg2,typ1);
              if (ok) any_ok=TRUE;
              if (ok && (arg2->attr_list || pred!=NULL)) {
                add_rule(arg2,pred,(def_type)type_it);
              }
            }
            else {
              ok=assert_less(typ1,arg2);
              if (ok) any_ok=TRUE;
              if (ok && arg2->attr_list) {
                warningline("attributes ignored in sort declaration (%E).\n");
              }
            }
          }
        }
        assert_ok=TRUE;
      }
      else if (eqflag) {
        if (typ1->attr_list) {
          warningline("attributes ignored left of ':=' declaration (%E).\n");
        }
        ok=assert_less(typ1,typ2);
        if (ok) any_ok=TRUE;
        typ2->type=typ1->type;
        if (ok && (typ2->attr_list || pred!=NULL))
          add_rule(typ2,pred,(def_type)type_it);
        else
          assert_ok=TRUE;
      }
      else {
        if (typ2->attr_list) {
          warningline("attributes ignored right of '<|' declaration (%E).\n");
        }
        ok=assert_less(typ1,typ2);
        if (ok) any_ok=TRUE;
        if (ok && (typ1->attr_list || pred!=NULL))
          add_rule(typ1,pred,(def_type)type_it);
        else
          assert_ok=TRUE;
      }
    }
    else {
      Errorline("argument missing in sort declaration (%E).\n");
    }
  }
  else {
    Errorline("argument missing in sort declaration (%E).\n");
  }
  if (!any_ok) assert_ok=FALSE;
}

void assert_attributes(ptr_psi_term t)
{
  ptr_psi_term arg1,arg2,pred=NULL,typ;
  ptr_definition d;
  
  get_two_args(t->attr_list,&arg1,&arg2);
  
  if (arg1) {
    typ=arg1;
    deref_ptr(arg1);
    if (!strcmp(arg1->type->keyword->symbol,"|")) {
      get_two_args(arg1->attr_list,&arg1,&pred);
      if (arg1) {
        typ=arg1;
        deref_ptr(arg1);
      }
    }
    
    if (arg1 && wl_const_3(*arg1)) {
      /* if (!redefine(arg1)) return;   RM: Feb 19 1993  */
      d=arg1->type;
      if (d->type_def==(def_type)predicate_it || d->type_def==(def_type)function_it) {
        Errorline("the %T '%s' may not be redefined as a sort.\n",
                  d->type_def, d->keyword->symbol);
      }
      else {
        d->type_def=(def_type)type_it;
        types_modified=TRUE;
        add_rule(typ,pred,(def_type)type_it);
      }
    }
    else {
      Errorline("bad argument in sort declaration '%P' (%E).\n",t);
    }
  }
  else {
    Errorline("argument missing in sort declaration (%E).\n");
  }
}

void find_adults()       /*  RM: Feb  3 1993  */

{
  ptr_definition d;
  ptr_int_list l;

  for(d=first_definition;d;d=d->next)
    if(d->type_def==(def_type)type_it && d->parents==NULL) {
      l=HEAP_ALLOC(int_list);
      l->value_1=(GENERIC)d;
      l->next=adults;
      adults=l;
    }
}

void insert_own_prop(ptr_definition d)
{
  ptr_int_list l;
  ptr_pair_list rule;
  ptr_triple_list *t;
  long flag;

  l=HEAP_ALLOC(int_list);
  l->value_1=(GENERIC)d;
  l->next=children;
  children=l;

  rule = d->rule;
  while (rule) {
    t= &(d->properties);
    flag=TRUE;
    
    while (flag) {
      if (*t)
        if ((*t)->aaaa_4==rule->aaaa_2 && (*t)->bbbb_4==rule->bbbb_2 && (*t)->cccc_4==d)
          flag=FALSE;
        else
          t= &((*t)->next);
      else {
        *t = HEAP_ALLOC(triple_list);
        (*t)->aaaa_4=rule->aaaa_2;
        (*t)->bbbb_4=rule->bbbb_2;
        (*t)->cccc_4=d;
        (*t)->next=NULL;
        flag=FALSE;
      }
    } 
    rule=rule->next;
  }
}

void insert_prop(ptr_definition d,ptr_triple_list prop)
{
  ptr_int_list l;
  ptr_triple_list *t;
  long flag;

  l=HEAP_ALLOC(int_list);
  l->value_1=(GENERIC)d;
  l->next=children;
  children=l;

  while (prop) {
    t= &(d->properties);
    flag=TRUE;
    
    while (flag) {
      if (*t)
        if ((*t)->aaaa_4==prop->aaaa_4 && (*t)->bbbb_4==prop->bbbb_4 && (*t)->cccc_4==prop->cccc_4)
          flag=FALSE;
        else
          t= &((*t)->next);
      else {
        *t = HEAP_ALLOC(triple_list);
        (*t)->aaaa_4=prop->aaaa_4;
        (*t)->bbbb_4=prop->bbbb_4;
        (*t)->cccc_4=prop->cccc_4;
        (*t)->next=NULL;
        flag=FALSE;
      }
    } 
    prop=prop->next;
  }
}

void propagate_definitions()
{
  ptr_int_list kids;
  ptr_definition d;
  
  adults=NULL;
  find_adults();
  
  while (adults) {
    
    children=NULL;
    
    while (adults) {
      d=(ptr_definition)adults->value_1;
      
      insert_own_prop(d);
      children=children->next;
      
      kids=d->children;
      
      while(kids) {
        insert_prop((ptr_definition)kids->value_1,d->properties);
        /* if (d->always_check && kids->value_1)
          ((ptr_definition)kids->value_1)->always_check=TRUE; */
        kids=kids->next;
      }
      adults=adults->next;
    }
    adults=children;
  }
}

/******************************************************************************

  The following routines implement sort encoding.

*/

long count_sorts(long c0)  /*  RM: Feb  3 1993  */
{
  ptr_definition d;

  for(d=first_definition;d;d=d->next)
    if (d->type_def==(def_type)type_it) c0++;
  
  return c0;
}

void clear_coding()   /*  RM: Feb  3 1993  */
{
  ptr_definition d;

  for(d=first_definition;d;d=d->next)
    if (d->type_def==(def_type)type_it) d->code=NOT_CODED;
}

void least_sorts()  /*  RM: Feb  3 1993  */
{
  ptr_definition d;

  for(d=first_definition;d;d=d->next)
    if (d->type_def==(def_type)type_it && d->children==NULL && d!=nothing)
      nothing->parents=cons((GENERIC)d,nothing->parents);
}

void all_sorts()   /*  RM: Feb  3 1993  */
{
  ptr_definition d;
  
  for(d=first_definition;d;d=d->next)
    if (d->type_def==(def_type)type_it && d!=nothing)
      nothing->parents=cons((GENERIC)d,nothing->parents);
}

ptr_int_list two_to_the(long p)
{
  ptr_int_list result,code;
  long v=1;

  code=HEAP_ALLOC(int_list);
  code->value_1=0;
  code->next=NULL;
  result=code;
  
  while (p>=INT_SIZE) {
    code->next=HEAP_ALLOC(int_list);
    code=code->next;
    code->value_1=0;
    code->next=NULL;
    p=p-INT_SIZE;
  }

  v= v<<p ;
  code->value_1=(GENERIC)v;

  return result;
}

ptr_int_list copyTypeCode(ptr_int_list u)
{
  ptr_int_list code;

  code = HEAP_ALLOC(int_list);
  code->value_1=0;
  code->next=NULL;

  or_codes(code, u);

  return code;
}

void or_codes(ptr_int_list u,ptr_int_list v)
{
  while (v) {
    u->value_1= (GENERIC)(((unsigned long)(u->value_1)) | ((unsigned long)(v->value_1)));
    v=v->next;
    if (u->next==NULL && v) {
      u->next=HEAP_ALLOC(int_list);
      u=u->next;
      u->value_1=0;
      u->next=NULL;
    }
    else
      u=u->next;
  }
}

void equalize_codes(int len) /*  RM: Feb  3 1993  */
{
  ptr_definition d;
  ptr_int_list c,*ci;
  long i;
  int w;
  
  for(d=first_definition;d;d=d->next)
    if (d->type_def==(def_type)type_it) {
      c = d->code;
      ci = &(d->code);  /*  RM: Feb 15 1993  */
      w=len;
      
      /* Count how many words have to be added */
      while (c) {
        ci= &(c->next);
        c=c->next;
        w--;
      }
      assert(w>=0);
      /* Add the words */
      for (i=0; i<w; i++) {
        *ci = HEAP_ALLOC(int_list);
        (*ci)->value_1=0;
        ci= &((*ci)->next);
      }
      (*ci)=NULL;
    }
}

void make_type_link(ptr_definition t1,ptr_definition t2)
{
  if (t2!=top && !type_member(t2,t1->parents))
    t1->parents=cons((GENERIC)t2,t1->parents);
  if (t2!=top && !type_member(t1,t2->children))
    t2->children=cons((GENERIC)t1,t2->children);
}

long type_member(ptr_definition t,ptr_int_list tlst)
{
  while (tlst) {
   if (t==(ptr_definition)tlst->value_1) return TRUE;
   tlst=tlst->next;
  }
  return FALSE;
}

void perr_sort(ptr_definition d)
{
  perr_s("%s",d->keyword->symbol);
}

void perr_sort_list(ptr_int_list anc)
{
  if (anc) {
    perr_sort_list(anc->next);
    if (anc->next) perr(" <| ");
    perr_sort((ptr_definition)anc->value_1);
  }
}

void perr_sort_cycle(ptr_int_list anc)
{
  perr_sort((ptr_definition)anc->value_1);
  perr(" <| ");
  perr_sort_list(anc);
}

long type_cyclicity(ptr_definition d,ptr_int_list anc)
{
  ptr_int_list p=d->parents;
  ptr_definition pd;
  long errflag;
  int_list anc2;

  while (p) {
    pd=(ptr_definition)p->value_1;
    /* If unmarked, mark and recurse */
    if (pd->code==NOT_CODED) {
      pd->code = (ptr_int_list)TRUE;
      anc2.value_1=(GENERIC)pd;
      anc2.next=anc;
      errflag=type_cyclicity(pd,&anc2);
      if (errflag) return TRUE;
    }
    /* If marked, check if it's in the ancestor list */
    else {
      if (type_member(pd,anc)) {
    Errorline("there is a cycle in the sort hierarchy\n");
        perr("*** Cycle: [");
        perr_sort_cycle(anc);
        perr("]\n");
        exit_life(TRUE);
        return TRUE;
      }
    }
    p=p->next;
  }
  return FALSE;
}

void propagate_always_check(ptr_definition d,long *ch)
{
  ptr_int_list child_list;
  ptr_definition child;
  
  child_list = d->children;
  while (child_list) {
    child = (ptr_definition)child_list->value_1;
    if (child->always_check) {
      child->always_check = FALSE;
      *ch = TRUE;
      propagate_always_check(child,ch);
    }
    child_list = child_list->next;
  }
}

void one_pass_always_check(long *ch)
{
  ptr_definition d;
  
  
  for(d=first_definition;d;d=d->next)
    if (d->type_def==(def_type)type_it && !d->always_check)
      propagate_always_check(d,ch);
}

void inherit_always_check()
{
  long change;

  do {
    change=FALSE;
    one_pass_always_check(&change);
  } while (change);
}

void encode_types()
{
  long p=0,i,possible,ok=TRUE;
  ptr_int_list layer,l,kids,dads,code;
  ptr_definition xdef,kdef,ddef; //,err;
  
  if (types_modified) {
    
    nothing->parents=NULL;
    nothing->children=NULL;
    
    top->parents=NULL;
    top->children=NULL;

    /* The following definitions are vital to avoid crashes */
    make_type_link(integer,real);
    make_type_link(lf_true,boolean);
    make_type_link(lf_false,boolean);

    /* These just might be useful */
    make_type_link(quoted_string,built_in);
    make_type_link(boolean,built_in);
    make_type_link(real,built_in);

    make_sys_type_links();
    
    type_count=count_sorts(-1); /* bottom does not count */
    clear_coding();
    nothing->parents=NULL; /* Must be cleared before all_sorts */
    all_sorts();
    if (type_cyclicity(nothing,NULL)) {
      clear_coding();
      return;
    }
    clear_coding();
    nothing->parents=NULL; /* Must be cleared before least_sorts */
    least_sorts();
    
    nothing->code=NULL;

    /*  RM: Feb 17 1993  */
    traceline("*** Codes:\n%C= %s\n", NULL, nothing->keyword->symbol);
    
    gamma_table=(ptr_definition *) heap_alloc(type_count*sizeof(definition));
    
    layer=nothing->parents;
    
    while (layer) {
      l=layer;
      do {
        xdef=(ptr_definition)l->value_1;
        if (xdef->code==NOT_CODED && xdef!=top) {
          
          kids=xdef->children;
          code=two_to_the(p);
          
          while (kids) {
            kdef=(ptr_definition)kids->value_1;
            or_codes(code,kdef->code);
            kids=kids->next;
          }
          
          xdef->code=code;
          gamma_table[p]=xdef;

      /*  RM: Feb 17 1993  */
          traceline("%C = %s\n", code, xdef->keyword->symbol);
          p=p+1;
        }
        
        l=l->next;
        
      } while (l);
      
      l=layer;
      layer=NULL;
      
      do {
        xdef=(ptr_definition)l->value_1;
        dads=xdef->parents;
        
        while (dads) {
          ddef=(ptr_definition)dads->value_1;
          if(ddef->code==NOT_CODED) {
            
            possible=TRUE;
            kids=ddef->children;
            
            while(kids && possible) {
              kdef=(ptr_definition)kids->value_1;
              if(kdef->code==NOT_CODED)
                possible=FALSE;
              kids=kids->next;
            }
            if(possible)
              layer=cons((GENERIC)ddef,layer);
          }
          dads=dads->next;
        }
        l=l->next;
      } while(l);
    }
    
    top->code=two_to_the(p);
    for (i=0;i<p;i++)
      or_codes(top->code,two_to_the(i));

    gamma_table[p]=top;

    /*  RM: Jan 13 1993  */
    /* Added the following line because type_count is now over generous
       because the same definition can be referenced several times in
       the symbol table because of modules
       */
    type_count=p+1;
    for(i=type_count;i<type_count;i++)
      gamma_table[i]=NULL;
    
    traceline("%C = @\n\n", top->code);
    equalize_codes(p/32+1);

    propagate_definitions();

    /* Inherit 'FALSE' always_check flags to all types' children */
    inherit_always_check();
    
    traceline("*** Encoding done, %d sorts\n",type_count);
    
    if (overlap_type(real,quoted_string)) {
      Errorline("the sorts 'real' and 'string' are not disjoint.\n");
      ok=FALSE;
    }

    /*  RM: Dec 15 1992  I don't think this really matters any more
    if (overlap_type(real,alist)) {
    Errorline("the sorts 'real' and 'list' are not disjoint.\n");
    ok=FALSE;
    }
    */
    
    /*  RM: Dec 15 1992  I don't think this really matters any more
    if (overlap_type(alist,quoted_string)) {
    Errorline("the sorts 'list' and 'string' are not disjoint.\n");
    ok=FALSE;
    }
    */
    
    if (!ok) {
      perr("*** Internal problem:\n");
      perr("*** Wild_Life may behave abnormally because some basic types\n");
      perr("*** have been defined incorrectly.\n\n");
    }

    types_modified=FALSE;
    types_done=TRUE;
  }
}

void print_codes()
{
  long i;

  for (i=0; i<type_count; i++) {
    outputline("%C = %s\n",
           gamma_table[i]->code,
           gamma_table[i]->keyword->combined_name);
  }
}

long glb_value(long result,long f,GENERIC c,GENERIC value1,GENERIC value2,GENERIC *value)
{
  ptr_int_list code;

  if (!result) return FALSE;
  if (value1==NULL) {
    *value=value2;
    return TRUE;
  }
  if (value2==NULL) {
    *value=value1;
    return TRUE;
  }
  /* At this point, both value fields are non-NULL */
  /* and must be compared. */

  /* Get a pointer to the sort code */
  code = f ? ((ptr_definition)c)->code : (ptr_int_list)c;

  /* This rather time-consuming analysis is necessary if both objects */
  /* have non-NULL value fields.  Note that only those objects with a */
  /* non-NULL value field needed for disentailment are looked at.     */
  if (sub_CodeType(code,real->code)) {
    *value=value1;
    return (*(REAL *)value1 == *(REAL *)value2);
  }
  else if (sub_CodeType(code,quoted_string->code)) {
    *value=value1;
    return (!strcmp((char *)value1,(char *)value2));
  }
  else {
    /* All other sorts with 'value' fields always return TRUE, that is, */
    /* the value field plays no role in disentailment. */
    *value=value1;
    return TRUE;
  }
}

long glb_code(long f1,GENERIC c1,long f2,GENERIC c2,long *f3,GENERIC *c3)
{
  long result=0;
  unsigned long v1,v2,v3;
  ptr_int_list cd1,cd2,*cd3; /* sort codes */

  /* First, the cases where c1 & c2 are ptr_definitions: */
  if (f1 && f2) {
    if ((ptr_definition)c1==(ptr_definition)c2) {
      *c3=c1;
      result=1;
    }
    else if ((ptr_definition)c1==top) {
      *c3=c2;
      if ((ptr_definition)c2==top)
        result=1;
      else
        result=3;
    }
    else if ((ptr_definition)c2==top) {
      *c3=c1;
      result=2;
    }
    /* If both inputs are either top or the same ptr_definition */
    /* then can return quickly with a ptr_definition. */
    if (result) {
      *f3=TRUE; /* c3 is ptr_definition (an interned symbol) */
      return result;
    }
  }
  /* In the other cases, can't return with a ptr_definition: */
  cd1=(ptr_int_list)(f1?(GENERIC)((ptr_definition)c1)->code:c1);
  cd2=(ptr_int_list)(f2?(GENERIC)((ptr_definition)c2)->code:c2);
  cd3=(ptr_int_list*)c3;
  *f3=FALSE; /* cd3 is ptr_int_list (a sort code) */
  if (cd1==NOT_CODED) {
    if (cd2==NOT_CODED) {
      if (c1==c2) {
        *cd3=cd1;
        result=1;
      }
      else
        result=0;
    }
    else if (cd2==top->code) {
      *cd3=cd1;
      result=2;
    }
    else
      result=0;
  }
  else if (cd1==top->code) {
    if (cd2==top->code) {
      *cd3=cd1;
      result=1;
    }
    else {
      *cd3=cd2;
      result=3;
    }
  }
  else if (cd2==NOT_CODED)
    result=0;
  else if (cd2==top->code) {
    *cd3=cd1;
    result=2;
  }
  else while (cd1 && cd2) {
    /* Bit operations needed only if c1 & c2 coded & different from top */
    *cd3 = STACK_ALLOC(int_list);
    (*cd3)->next=NULL;
    
    v1=(unsigned long)(cd1->value_1);
    v2=(unsigned long)(cd2->value_1);
    v3=v1 & v2;
    (*cd3)->value_1=(GENERIC)v3;
    
    if (v3) {
      if (v3<v1 && v3<v2)
        result=4;
      else if (result!=4)
        if (v1<v2)
          result=2;
        else if (v1>v2)
          result=3;
        else
          result=1;
    }
    else if (result)
      if (v1 || v2)
        result=4;
        
    cd1=cd1->next;
    cd2=cd2->next;
    cd3= &((*cd3)->next);
  }

  return result;
}

long glb(ptr_definition t1,ptr_definition t2,ptr_definition *t3,ptr_int_list *c3)
{
  ptr_int_list c1,c2;
  long result=0;
  unsigned long v1,v2,v3;
  int e1,e2,b; /*  RM: May  7 1993  */


  
  *c3=NULL;
  
  if (t1==t2) { 
    result=1;
    *t3= t1;
  }
  else if (t1==top) {
    *t3= t2;
    if (t2==top)
      result=1;
    else
      result=3;
  }
  else if (t2==top) {
    result=2;
    *t3= t1;
  }
  else {
    /* printf("glb of %s and %s\n",
       t1->keyword->combined_name,
       t2->keyword->combined_name); */
       
    c1=t1->code;
    c2=t2->code;

    e1=TRUE;e2=TRUE;b=TRUE;
    
    if (c1!=NOT_CODED && c2!=NOT_CODED) {
      result=0;
      while (c1 && c2) {

        *c3 = STACK_ALLOC(int_list);
        (*c3)->next=NULL;

        v1=(unsigned long)(c1->value_1);
        v2=(unsigned long)(c2->value_1);
        v3=v1 & v2;

    /* printf("v1=%d, v2=%d, v3=%d\n",v1,v2,v3); */
    
        (*c3)->value_1=(GENERIC)v3;

    if(v3!=v1) /*  RM: May  7 1993  */
      e1=FALSE;
    if(v3!=v2)
      e2=FALSE;
    if(v3)
      b=FALSE;
    
        c1=c1->next;
        c2=c2->next;
        c3= &((*c3)->next);
      }
      *t3=NULL;

      if(b) /*  RM: May  7 1993  */
    result=0; /* 0 if T3 = bottom */
      else
    if(e1)
      if(e2)
        result=1; /* 1 if T1 = T2 */
      else
        result=2; /* 2 if T1 <| T2 ( T3 = T1 ) */
    else
      if(e2)
        result=3; /* 3 if T1 |> T2 ( T3 = T2 ) */
      else
        result=4; /* 4 otherwise */
    }
  }
  
  if (!result) *t3=nothing;
  
  /* printf("result=%d\n\n",result); */
  
  return result;
}

long overlap_type(ptr_definition t1,ptr_definition t2)
{
  ptr_int_list c1,c2;
  long result=TRUE;
  
  if (t1!=t2 && t1!=top && t2!=top) {
    
    c1=t1->code;
    c2=t2->code;
    result=FALSE;

    if (c1!=NOT_CODED && c2!=NOT_CODED) {     
      while (!result && c1 && c2) {          
        result=(((unsigned long)(c1->value_1)) & ((unsigned long)(c2->value_1)));
        c1=c1->next;
        c2=c2->next;
      }
    }
  }
  
  /*
  printf("overlap_type(%s,%s) => %ld\n",t1->def->keyword->symbol,t2->def->keyword->symbol,result);
  */
  
  return result;
}

long sub_CodeType(ptr_int_list c1,ptr_int_list c2)
{
  if (c1!=NOT_CODED && c2!=NOT_CODED) {
    while (c1 && c2) {
      if ((unsigned long)c1->value_1 & ~(unsigned long)c2->value_1) return FALSE;
      c1=c1->next;
      c2=c2->next;
    }
  }
  else
    return FALSE;

  return TRUE;
}

long sub_type(ptr_definition t1,ptr_definition t2)
{
  if (t1!=t2)
    if (t2!=top)
    {
      if (t1==top)
        return FALSE;
      else
        return sub_CodeType(t1->code, t2->code);
    }
  return TRUE;
}

long matches(ptr_definition t1,ptr_definition t2,long *smaller)
{
  ptr_int_list c1,c2;
  long result=TRUE;
  
  *smaller=TRUE;
  
  if (t1!=t2)
    if (t2!=top)
      if (t1==top)
        *smaller=FALSE;
      else {
        c1=t1->code;
        c2=t2->code;
        result=FALSE;
        
        if (c1!=NOT_CODED && c2!=NOT_CODED) {          
          while (c1 && c2) {          
            if ((unsigned long)c1->value_1 &  (unsigned long)c2->value_1) result=TRUE;
            if ((unsigned long)c1->value_1 & ~(unsigned long)c2->value_1) *smaller=FALSE;
            c1=c1->next;
            c2=c2->next;
          }
        }
        else
          *smaller=FALSE;
      }
  
  return result;
}



long strict_matches(ptr_psi_term t1,ptr_psi_term t2,long *smaller)
{
  long result,sm;

  result=matches(t1->type,t2->type,&sm);

  if (sm) {
    /* At this point, t1->type <| t2->type */
    if (t1->type==t2->type) {
      /* Same types: strict only if first has a value & second does not */
      if (t1->value_3!=NULL && t2->value_3==NULL)
        sm=TRUE;
      else
        sm=FALSE;
    }
    else {
      /* Different types: the first must be strictly smaller */
      sm=TRUE;
    }
  }

  *smaller=sm;
  return result;
}

long bit_length(ptr_int_list c)
{
  unsigned long p=0,dp=0,v=0,dv=0;
  
  while (c) {
    v=(unsigned long)c->value_1;
    if(v) {
      dp=p;
      dv=v;
    }
    c=c->next;
    p=p+INT_SIZE;
  }
  
  while (dv) {
    dp++;
    dv=dv>>1;
  }
  
  return dp;
}

ptr_int_list decode(ptr_int_list c)
{
  ptr_int_list c2,c3,c4,result=NULL,*prev;
  long p;
  
  p=bit_length(c);
  
  while (p) {
    p--;
    c2=gamma_table[p]->code;
    result=cons((GENERIC)gamma_table[p],result);
    prev= &c4;
    *prev=NULL;
    
    while (c2) {
      c3=STACK_ALLOC(int_list);
      *prev=c3;
      prev= &(c3->next);
      *prev=NULL;
      
      c3->value_1=(GENERIC)(((unsigned long)(c->value_1)) & ~((unsigned long)(c2->value_1)));
      
      c=c->next;
      c2=c2->next;
    }
    
    c=c4;
    p=bit_length(c);
  }
  
  return result;
}