types.c File Reference

types More...

Go to the source code of this file.

Functions
void	print_def_type (def_type t)
	print_def_type More...
long	yes_or_no ()
	yes_or_no More...
void	remove_cycles (ptr_definition d, ptr_int_list *dl)
	remove_cycles More...
long	redefine (ptr_psi_term t)
	redefine More...
ptr_int_list	cons (GENERIC v, ptr_int_list l)
	cons More...
long	assert_less (ptr_psi_term t1, ptr_psi_term t2)
	assert_less More...
void	assert_protected (ptr_node n, long prot)
	assert_protected More...
void	assert_args_not_eval (ptr_node n)
	assert_args_not_eval More...
void	assert_delay_check (ptr_node n)
	assert_delay_check More...
void	clear_already_loaded (ptr_node n)
	clear_already_loaded More...
void	assert_type (ptr_psi_term t)
	assert_type More...
void	assert_complicated_type (ptr_psi_term t)
	assert_complicated_type More...
void	assert_attributes (ptr_psi_term t)
	assert_attributes More...
void	find_adults ()
	find_adults More...
void	insert_own_prop (ptr_definition d)
	insert_own_prop More...
void	insert_prop (ptr_definition d, ptr_triple_list prop)
	insert_prop More...
void	propagate_definitions ()
	propagate_definitions More...
long	count_sorts (long c0)
	count_sorts More...
void	clear_coding ()
	clear_coding More...
void	least_sorts ()
	void least_sorts() More...
void	all_sorts ()
	all_sorts More...
ptr_int_list	two_to_the (long p)
	two_to_the More...
ptr_int_list	copyTypeCode (ptr_int_list u)
	copyTypeCode More...
void	or_codes (ptr_int_list u, ptr_int_list v)
	or_codes More...
void	equalize_codes (int len)
	equalize_codes More...
void	make_type_link (ptr_definition t1, ptr_definition t2)
	make_type_link More...
long	type_member (ptr_definition t, ptr_int_list tlst)
	type_member More...
void	perr_sort (ptr_definition d)
	perr_sort More...
void	perr_sort_list (ptr_int_list anc)
	perr_sort_list More...
void	perr_sort_cycle (ptr_int_list anc)
	perr_sort_cycle More...
long	type_cyclicity (ptr_definition d, ptr_int_list anc)
	type_cyclicity More...
void	propagate_always_check (ptr_definition d, long *ch)
	propagate_always_check More...
void	one_pass_always_check (long *ch)
	one_pass_always_check More...
void	inherit_always_check ()
	inherit_always_check More...
void	encode_types ()
	encode_types More...
void	print_codes ()
	print_codes More...
long	glb_value (long result, long f, GENERIC c, GENERIC value1, GENERIC value2, GENERIC *value)
	glb_value More...
long	glb_code (long f1, GENERIC c1, long f2, GENERIC c2, long *f3, GENERIC *c3)
	glb_code More...
long	glb (ptr_definition t1, ptr_definition t2, ptr_definition *t3, ptr_int_list *c3)
	glb More...
long	overlap_type (ptr_definition t1, ptr_definition t2)
	overlap_type More...
long	sub_CodeType (ptr_int_list c1, ptr_int_list c2)
	sub_CodeType More...
long	sub_type (ptr_definition t1, ptr_definition t2)
	sub_type More...
long	matches (ptr_definition t1, ptr_definition t2, long *smaller)
	matches More...
long	strict_matches (ptr_psi_term t1, ptr_psi_term t2, long *smaller)
	strict_matches More...
long	bit_length (ptr_int_list c)
	bit_length More...
ptr_int_list	decode (ptr_int_list c)
	decode More...

Variables
ptr_definition *	gamma_table = NULL

Detailed Description

types

These routines implement type encoding using the "Transitive Closure" binary encoding algorithm.

Definition in file types.c.

Function Documentation

void all_sorts

(

)

all_sorts

ALL_SORTS() Build a list of all sorts (except nothing) in nothing->parents.

Definition at line 759 of file types.c.

References cons(), first_definition, wl_definition::next, nothing, wl_definition::parents, wl_definition::type_def, and type_it.

{
  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);
}

void assert_args_not_eval

(

ptr_node

n

)

assert_args_not_eval

Parameters

n	- ptr_node n

ASSERT_ARGS_NOT_EVAL(n) Mark all the nodes in the attribute tree N as having unevaluated arguments, if they are functions or predicates.

Definition at line 294 of file types.c.

References wl_node::data, deref_ptr, wl_definition::evaluate_args, FALSE, wl_definition::keyword, wl_node::left, wl_node::right, wl_keyword::symbol, wl_psi_term::type, wl_definition::type_def, type_it, and warningline().

{
  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_attributes

(

ptr_psi_term

t

)

assert_attributes

Parameters

t	- ptr_psi_term t

ASSERT_ATTRIBUTES(t) T is of the form ':: type(attributes) | pred', the attributes must be appended to T's definition, and will be propagated after ENCODING to T's subtypes.

Definition at line 500 of file types.c.

References add_rule(), wl_psi_term::attr_list, deref_ptr, Errorline(), function_it, get_two_args(), wl_definition::keyword, NULL, predicate_it, wl_keyword::symbol, TRUE, wl_psi_term::type, wl_definition::type_def, type_it, types_modified, and wl_const_3.

{
  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 assert_complicated_type

(

ptr_psi_term

t

)

assert_complicated_type

Parameters

t	- ptr_psi_term t

ASSERT_COMPLICATED_TYPE This deals with all the type declarations of the form:

a(attr) <| b. % (a<|b) a(attr) <| b | pred.

a(attr) <| {b;c;d}. % (a<|b, a<|c, a<|d) a(attr) <| {b;c;d} | pred.

a := b(attr). % (a<|b) a := b(attr) | pred.

a := {b(attr1);c(attr2);d(attr3)}. % (b<|a,c<|a,d<|a) a := {b(attr1);c(attr2);d(attr3)} | pred.

Definition at line 405 of file types.c.

References add_rule(), assert_less(), assert_ok, wl_psi_term::attr_list, deref_ptr, disjunction, equ_tok, Errorline(), FALSE, get_two_args(), wl_definition::keyword, nil, NULL, wl_keyword::symbol, TRUE, wl_psi_term::type, type_it, and warningline().

{
  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_delay_check

(

ptr_node

n

)

assert_delay_check

Parameters

n	- ptr_node n

ASSERT_DELAY_CHECK(n) Assert that the types in the attribute tree N will have their properties checked only when they have attributes. If they have no attributes, then no properties are checked.

Definition at line 326 of file types.c.

References wl_definition::always_check, wl_node::data, deref_ptr, FALSE, wl_node::left, wl_node::right, and wl_psi_term::type.

{
  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);
  }
}

long assert_less	(	ptr_psi_term	t1,
		ptr_psi_term	t2
	)

assert_less

Parameters

t1	- ptr_psi_term t1
t2	- ptr_psi_term t2

ASSERT_LESS(t1,t2) Assert that T1 <| T2. Return false if some sort of error occurred.

Definition at line 200 of file types.c.

References deref_ptr, Errorline(), FALSE, function_it, wl_definition::keyword, make_type_link(), predicate_it, redefine(), wl_keyword::symbol, top, TRUE, wl_psi_term::type, wl_definition::type_def, type_it, types_modified, and wl_psi_term::value_3.

{
  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
	)

assert_protected

Parameters

n	- ptr_node n
prot	- long prot

ASSERT_PROTECTED(n,prot) Mark all the nodes in the attribute tree N with protect flag prot.

Definition at line 255 of file types.c.

References wl_node::data, wl_definition::date, deref_ptr, wl_definition::keyword, wl_node::left, MAX_BUILT_INS, wl_definition::protected, wl_node::right, wl_definition::rule, wl_keyword::symbol, wl_psi_term::type, wl_definition::type_def, type_it, and warningline().

{
  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_type

(

ptr_psi_term

t

)

assert_type

Parameters

t	- ptr_psi_term t

ASSERT_TYPE(t) T is the psi_term <|(type1,type2). Add that to the type-definitions.

Definition at line 372 of file types.c.

References assert_less(), assert_ok, wl_psi_term::attr_list, Errorline(), get_two_args(), and NULL.

{
  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);
}

long bit_length

(

ptr_int_list

c

)

bit_length

Parameters

c	- ptr_int_list c

BIT_LENGTH(c) Returns the number of bits needed to code C. That is the rank of the first non NULL bit of C.

Examples: C= 1001001000 result=7 C= 10000 result=1 C= 0000000 result=0

Definition at line 1753 of file types.c.

References INT_SIZE, wl_int_list::next, and wl_int_list::value_1.

{
  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;
}

void clear_already_loaded

(

ptr_node

n

)

clear_already_loaded

Parameters

n	- ptr_node n

CLEAR_ALREADY_LOADED() Clear the 'already_loaded' flags in all symbol table entries. Done at each top level prompt.

Definition at line 351 of file types.c.

References wl_definition::already_loaded, wl_node::data, FALSE, wl_node::left, and wl_node::right.

{
  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 clear_coding

(

)

clear_coding

CLEAR_CODING() Clear the bit-vector coding of the sorts.

Definition at line 727 of file types.c.

References wl_definition::code, first_definition, wl_definition::next, NOT_CODED, wl_definition::type_def, and type_it.

{
  ptr_definition d;

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

ptr_int_list cons	(	GENERIC	v,
		ptr_int_list	l
	)

cons

Parameters

v	- GENERIC v
l	- ptr_int_list l

CONS(value,list) Returns the list [VALUE|LIST]

Definition at line 179 of file types.c.

References HEAP_ALLOC, wl_int_list::next, and wl_int_list::value_1.

{
  ptr_int_list n;

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

ptr_int_list copyTypeCode

(

ptr_int_list

u

)

copyTypeCode

Parameters

u	- ptr_int_list u

copyTypeCode(code) returns copy of code on the heap

Definition at line 808 of file types.c.

References HEAP_ALLOC, wl_int_list::next, NULL, or_codes(), and wl_int_list::value_1.

{
  ptr_int_list code;

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

  or_codes(code, u);

  return code;
}

long count_sorts

(

long

c0

)

count_sorts

Parameters

c0

- long c0

COUNT_SORTS(c) Count the number of sorts in the symbol table T. Overestimates in the module version. RM: Jan 21 1993 No longer !! RM: Feb 3 1993

Definition at line 710 of file types.c.

References first_definition, wl_definition::next, wl_definition::type_def, and type_it.

{
  ptr_definition d;

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

ptr_int_list decode

(

ptr_int_list

c

)

decode

Parameters

c	- ptr_int_list c

DECODE(c) Returns a list of the symbol names which make up the disjunction whose code is C.

Definition at line 1784 of file types.c.

References bit_length(), wl_definition::code, cons(), wl_int_list::next, NULL, STACK_ALLOC, and wl_int_list::value_1.

{
  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;
}

void encode_types

(

)

encode_types

ENCODE_TYPES() This routine performs type-coding using transitive closure. First any previous coding is undone. Then a new encryption is performed.

Some of these routines loop indefinitely if there is a circular type definition (an error should be reported but it isn't implemented (but it's quite easy to do)).

Definition at line 1091 of file types.c.

References all_sorts(), built_in, wl_definition::children, clear_coding(), wl_definition::code, cons(), count_sorts(), equalize_codes(), Errorline(), FALSE, heap_alloc(), inherit_always_check(), integer, wl_definition::keyword, least_sorts(), lf_false, lf_true, make_sys_type_links(), make_type_link(), wl_int_list::next, NOT_CODED, nothing, NULL, or_codes(), overlap_type(), wl_definition::parents, perr(), propagate_definitions(), quoted_string, real, wl_keyword::symbol, top, traceline(), TRUE, two_to_the(), type_count, type_cyclicity(), types_done, types_modified, and wl_int_list::value_1.

{
  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 equalize_codes

(

int

len

)

equalize_codes

Parameters

len

- int len

EQUALIZE_CODES(w) Make sure all codes are w words long, by increasing the length of the shorter ones. This simplifies greatly the bitvector manipulation routines. This operation should be done after encoding. For correct operation, w>=maximum number of words used for a code.

Definition at line 859 of file types.c.

References assert, wl_definition::code, first_definition, HEAP_ALLOC, wl_int_list::next, wl_definition::next, NULL, wl_definition::type_def, and type_it.

{
  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 find_adults

(

)

find_adults

FIND_ADULTS() Returns the list of all the maximal types (apart from top) in the symbol table. That is, types which have no parents. This routine modifies the global variable 'adults'.

Definition at line 549 of file types.c.

References adults, first_definition, HEAP_ALLOC, wl_int_list::next, wl_definition::next, NULL, wl_definition::parents, wl_definition::type_def, type_it, and wl_int_list::value_1.

{
  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;
    }
}

long glb	(	ptr_definition	t1,
		ptr_definition	t2,
		ptr_definition *	t3,
		ptr_int_list *	c3
	)

glb

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2
t3	- ptr_definition *t3
c3	- ptr_int_list *c3

GLB(t1,t2,t3) This function returns the Greatest Lower Bound of two types T1 and T2 in T3.

T3 = T1 /\ T2

If T3 is not a simple type then C3 is its code, and T3=NULL.

It also does some type comparing, and returns

0 if T3 = bottom 1 if T1 = T2 2 if T1 <| T2 ( T3 = T1 ) 3 if T1 |> T2 ( T3 = T2 ) 4 otherwise ( T3 strictly <| T1 and T3 strictly <| T2 )

These results are used for knowing when to inherit properties or release residuations. The t3 field is NULL iff a new type is needed to represent the result.

RM: May 7 1993 Fixed bug in when multiple word code

Definition at line 1481 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, nothing, NULL, STACK_ALLOC, top, TRUE, and wl_int_list::value_1.

{
  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 glb_code	(	long	f1,
		GENERIC	c1,
		long	f2,
		GENERIC	c2,
		long *	f3,
		GENERIC *	c3
	)

glb_code

Parameters

f1	- long f1
c1	- GENERIC c1
f2	- long f2
c2	- GENERIC c2
f3	- long *f3
c3	- GENERIC *c3

GLB_CODE(f1,c1,f2,c2,f3,c3) (21.9) Calculate glb of two type codes C1 and C2, put result in C3. Return a result value (see comments of glb(..)).

Sorts are stored as a 'Variant Record': f1==TRUE: c1 is a ptr_definition (an interned symbol). f1==FALSE: c1 is a ptr_int_list (a sort code). The result (f3,c3) is also in this format. This is needed to correctly handle psi-terms that don't have a sort code (for example, functions, predicates, and singleton sorts). The routine handles a bunch of special cases that keep f3==TRUE. Other than that, it is almost a replica of the inner loop of glb(..).

Definition at line 1351 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, NULL, STACK_ALLOC, top, TRUE, and wl_int_list::value_1.

{
  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_value	(	long	result,
		long	f,
		GENERIC	c,
		GENERIC	value1,
		GENERIC	value2,
		GENERIC *	value
	)

glb_value

Parameters

result	- long result
f	- long f
c	- GENERIC c
value1	- GENERIC value1
value2	- GENERIC value2
value	- GENERIC *value

GLB_VALUE(result,f,c,value1,value2,value) Do the comparison of the value fields of two psi-terms. This is used in conjunction with glb_code to correctly implement completeness for disequality for psi-terms with non-NULL value fields. This must be preceded by a call to glb_code, since it uses the outputs of that call.

result result of preceding glb_code call (non-NULL iff non-empty intersec.) f,c sort intersection (sortflag & code) of preceding glb_code call. value1 value field of first psi-term. value2 value field of second psi-term. value output value field (if any).

Definition at line 1290 of file types.c.

References wl_definition::code, FALSE, NULL, quoted_string, REAL, real, sub_CodeType(), and TRUE.

{
  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;
  }
}

void inherit_always_check

(

)

inherit_always_check

INHERIT_ALWAYS_CHECK() The 'always_check' flag, if false, should be propagated to a sort's children. This routine does a closure on this propagation operation for all declared sorts.

Definition at line 1068 of file types.c.

References FALSE, and one_pass_always_check().

{
  long change;

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

void insert_own_prop

(

ptr_definition

d

)

insert_own_prop

Parameters

d	- ptr_definition d

INSERT_OWN_PROP(definition) Append a type's "rules" (i.e. its own attr. & constr.) to its property list. The property list also contains the type's code. A type's attributes and constraints are stored in the 'rule' field of the definition.

Definition at line 575 of file types.c.

References wl_pair_list::aaaa_2, wl_pair_list::bbbb_2, children, FALSE, HEAP_ALLOC, wl_int_list::next, wl_definition::next, wl_pair_list::next, NULL, wl_definition::properties, wl_definition::rule, TRUE, and wl_int_list::value_1.

{
  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
	)

insert_prop

Parameters

d	- ptr_definition d
prop	- ptr_triple_list prop

INSERT_PROP(definition,prop) Append the properties to the definition if they aren't already present.

Definition at line 620 of file types.c.

References wl_triple_list::aaaa_4, wl_triple_list::bbbb_4, wl_triple_list::cccc_4, children, FALSE, HEAP_ALLOC, wl_int_list::next, wl_definition::next, wl_triple_list::next, NULL, wl_definition::properties, TRUE, and wl_int_list::value_1.

{
  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 least_sorts

(

)

void least_sorts()

LEAST_SORTS() Build the list of terminals (i.e. sorts with no children) in nothing->parents.

Definition at line 743 of file types.c.

References wl_definition::children, cons(), first_definition, wl_definition::next, nothing, NULL, wl_definition::parents, wl_definition::type_def, and type_it.

{
  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 make_type_link	(	ptr_definition	t1,
		ptr_definition	t2
	)

make_type_link

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2

MAKE_TYPE_LINK(t1,t2) Assert that T1 <| T2, this is used to initialise the built_in type relations so that nothing really horrible happens if the user modifies built-in types such as INT or LIST. This routine also makes sure that top has no links.

Definition at line 901 of file types.c.

References wl_definition::children, cons(), wl_definition::parents, top, and type_member().

{
  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 matches	(	ptr_definition	t1,
		ptr_definition	t2,
		long *	smaller
	)

matches

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2
smaller	- long *smaller

MATCHES(t1,t2,s) Returns TRUE if GLB(t1,t2)!=bottom. Sets S to TRUE if type T1 is <| than type T2, that is if T1 matches T2.

Definition at line 1666 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, top, TRUE, and wl_int_list::value_1.

{
  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;
}

void one_pass_always_check

(

long *

ch

)

one_pass_always_check

Parameters

ch	- long *ch ONE_PASS_ALWAYS_CHECK(ch) Go through the symbol table & propagate all FALSE always_check flags of all sorts to their children. Return a TRUE flag if a change was made somewhere (for the closure calculation).

Definition at line 1049 of file types.c.

References wl_definition::always_check, first_definition, wl_definition::next, propagate_always_check(), wl_definition::type_def, and type_it.

{
  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 or_codes	(	ptr_int_list	u,
		ptr_int_list	v
	)

or_codes

Parameters

u	- ptr_int_list u
v	- ptr_int_list v

OR_CODES(code1,code2) Performs CODE1 := CODE1 or CODE2, 'or' being the binary logical operator on bits.

Definition at line 831 of file types.c.

References HEAP_ALLOC, wl_int_list::next, NULL, and wl_int_list::value_1.

{
  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;
  }
}

long overlap_type	(	ptr_definition	t1,
		ptr_definition	t2
	)

overlap_type

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2

OVERLAP_TYPE(t1,t2) This function returns TRUE if GLB(t1,t2)!=bottom. This is essentially the same thing as GLB, only it's faster 'cause we don't care about the resulting code.

Definition at line 1579 of file types.c.

References wl_definition::code, FALSE, wl_int_list::next, NOT_CODED, top, TRUE, and wl_int_list::value_1.

{
  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;
}

void perr_sort

(

ptr_definition

d

)

perr_sort

Parameters

d	- ptr_definition d

Definition at line 933 of file types.c.

References wl_definition::keyword, perr_s(), and wl_keyword::symbol.

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

void perr_sort_cycle

(

ptr_int_list

anc

)

perr_sort_cycle

Parameters

anc	- ptr_int_list anc

Definition at line 959 of file types.c.

References perr(), perr_sort(), perr_sort_list(), and wl_int_list::value_1.

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

void perr_sort_list

(

ptr_int_list

anc

)

perr_sort_list

Parameters

anc	- ptr_int_list anc

Definition at line 944 of file types.c.

References wl_int_list::next, perr(), perr_sort(), and wl_int_list::value_1.

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

void print_codes

(

)

print_codes

PRINT_CODES() Print all the codes.

Definition at line 1256 of file types.c.

References outputline(), and type_count.

{
  long i;

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

void print_def_type

(

def_type

t

)

print_def_type

Parameters

t	- def_type t

PRINT_DEF_TYPE(t) This prints type T to stderr, where T=predicate, function or type.

Definition at line 24 of file types.c.

References function_it, global_it, perr(), predicate_it, and type_it.

{
  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");
  }
}

void propagate_always_check	(	ptr_definition	d,
		long *	ch
	)

propagate_always_check

Parameters

d	- ptr_definition d
ch	- long *ch

PROPAGATE_ALWAYS_CHECK(d,ch) Recursively set the always_check flag to 'FALSE' for all d's children. Continue until encountering only 'FALSE' values. Return a TRUE flag if a change was made somewhere (for the closure calculation).

Definition at line 1022 of file types.c.

References wl_definition::always_check, wl_definition::children, FALSE, wl_int_list::next, TRUE, and wl_int_list::value_1.

{
  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 propagate_definitions

(

)

propagate_definitions

PROPAGATE_DEFINITIONS() This routine propagates the definition (attributes,predicates) of a type to all its sons.

Definition at line 662 of file types.c.

References adults, wl_definition::children, children, find_adults(), insert_own_prop(), insert_prop(), wl_int_list::next, NULL, wl_definition::properties, and wl_int_list::value_1.

{
  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;
  }
}

long redefine

(

ptr_psi_term

t

)

redefine

Parameters

t	- ptr_psi_term t

REDEFINE(t) This decides whether a definition (a sort, function, or predicate) may be extended or not.

Definition at line 104 of file types.c.

References wl_definition::children, wl_keyword::combined_name, wl_definition::date, deref_ptr, Errorline(), FALSE, file_date, wl_definition::keyword, MAX_BUILT_INS, wl_definition::parents, wl_definition::protected, remove_cycles(), wl_definition::rule, wl_keyword::symbol, TRUE, wl_psi_term::type, wl_definition::type_def, type_it, undef_it, warningflag, warningline(), and yes_or_no().

{
  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;
}

void remove_cycles	(	ptr_definition	d,
		ptr_int_list *	dl
	)

remove_cycles

Parameters

d	- ptr_definition d
dl	- ptr_int_list *dl

Remove references to d in d's children or parents

Definition at line 85 of file types.c.

References wl_int_list::next.

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

long strict_matches	(	ptr_psi_term	t1,
		ptr_psi_term	t2,
		long *	smaller
	)

strict_matches

Parameters

t1	- ptr_psi_term t1
t2	- ptr_psi_term t2
smaller	- long *smaller

STRICT_MATCHES(t1,t2,s) Almost the same as matches, except that S is set to TRUE only if the type of t1 is strictly less than the type of t2. Because of the implementation of ints, reals, strings, and lists, this has to take the value field into account, and thus must be passed the whole psi-term.

Definition at line 1713 of file types.c.

References FALSE, matches(), NULL, TRUE, wl_psi_term::type, and wl_psi_term::value_3.

{
  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 sub_CodeType	(	ptr_int_list	c1,
		ptr_int_list	c2
	)

sub_CodeType

Parameters

c1	- ptr_int_list c1
c2	- ptr_int_list c2

SUB_CodeType(c1,c2) Return TRUE if code C1 is <| than type C2, that is if type represented by code C1 matches type represented by C2.

We already know that t1 and t2 are not top.

Definition at line 1618 of file types.c.

References FALSE, wl_int_list::next, NOT_CODED, TRUE, and wl_int_list::value_1.

{
  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
	)

sub_type

Parameters

t1	- ptr_definition t1
t2	- ptr_definition t2

SUB_TYPE(t1,t2) Return TRUE if type T1 is <| than type T2, that is if T1 matches T2.

Definition at line 1642 of file types.c.

References wl_definition::code, FALSE, sub_CodeType(), top, and TRUE.

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

ptr_int_list two_to_the

(

long

p

)

two_to_the

Parameters

p

- long p

TWO_TO_THE(p) Return the code worth 2^p.

Definition at line 776 of file types.c.

References HEAP_ALLOC, INT_SIZE, wl_int_list::next, NULL, and wl_int_list::value_1.

{
  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;
}

long type_cyclicity	(	ptr_definition	d,
		ptr_int_list	anc
	)

type_cyclicity

Parameters

d	- ptr_definition d
anc	- ptr_int_list anc

TYPE_CYCLICITY(d,anc) Check cyclicity of type hierarchy. If cyclic, return a TRUE error condition and print an error message with a cycle.

Definition at line 977 of file types.c.

References wl_definition::code, Errorline(), exit_life(), FALSE, wl_int_list::next, NOT_CODED, wl_definition::parents, perr(), perr_sort_cycle(), TRUE, type_member(), and wl_int_list::value_1.

{
  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;
}

long type_member	(	ptr_definition	t,
		ptr_int_list	tlst
	)

type_member

Parameters

t	- ptr_definition t
tlst	- ptr_int_list tlst

TYPE_MEMBER(t,tlst) Return TRUE iff type t is in the list tlst.

Definition at line 918 of file types.c.

References FALSE, wl_int_list::next, TRUE, and wl_int_list::value_1.

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

long yes_or_no

(

)

yes_or_no

Confirm an important change

Definition at line 50 of file types.c.

References EOLN, input_state, open_input_file(), perr(), prompt, read_char(), and restore_state().

{
  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');
}

Variable Documentation

ptr_definition* gamma_table = NULL

Definition at line 14 of file types.c.