Logo Search packages:      
Sourcecode: gp2c version File versions  Download package

gentype.c

/*
Copyright (C) 2000-2005  The PARI group.

This file is part of the GP2C package.

PARI/GP is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free Software
Foundation. It is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY WHATSOEVER.

Check the License for details. You should have received a copy of it, along
with the package; see the file 'COPYING'. If not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */

#include "config.h"
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include "header.h"
int gentypefuncdesc(int n, gpfunc *gp);
void
inittrans(int n,int p)
{
  int i;
  for(i=0;i<s_GPtype.n;i++)
  {
    if (is_subtype(i,n))
      typemax[p][i]=typemax[i][p]=p;
    if (is_subtype(p,i))
      typemax[i][n]=typemax[n][i]=i;
  }
}
int
initmax(int n, int p)
{
  int i,m=Gnotype;
  for(i=0;i<s_GPtype.n;i++)
    if (is_subtype(n,i) && is_subtype(p,i))
      if(m==Gnotype || is_subtype(i,m))
        m=i;
  return m;
}
void outputtype(FILE *fout)
{
  int i,j;
  fprintf(fout,"        |");
  for(i=0;i<s_GPtype.n;i++)
    fprintf(fout,"%-8s",GPname(i));
  fprintf(fout,"\n--------+");
  for(i=0;i<s_GPtype.n;i++)
    fprintf(fout,"--------");
  fprintf(fout,"\n");
  for(i=0;i<s_GPtype.n;i++)
  {
    /*No, this is not strange smileys*/
    fprintf(fout,"%-8s|",GPname(i));
    for(j=0;j<s_GPtype.n;j++)
    {
      fprintf(fout,"%-8s",GPname(typemax[i][j]));
    }
    fprintf(fout,"\n");
  }
}
void inittype(void)
{
  int n;
  int i,j;
  int Gnbtype=s_GPtype.n;
  gpfunc *gp=lfunc+findfuncdesc("_type_preorder");
  gpdesc *dsc=gp->dsc;
  typemax=(int **) calloc(Gnbtype,sizeof(*typemax));
  for(i=0;i<Gnbtype;i++)
    typemax[i]=(int *) calloc(Gnbtype,sizeof(**typemax));
  for(i=0;i<Gnbtype;i++)
    for(j=0;j<Gnbtype;j++)
      typemax[i][j]=(i==j)?i:Gnotype;
  for(n=0; n<dsc->nb; n++)
  {
    gpdescarg *ga=dsc->a+n;
    int oldt=-1;
    for (i=0; i < ga->nargs; i++)
    {
      descargatom *a=ga->args+i;
      int t=a->type;
      if (a->t!=AAtype)
        die(err_desc,"unexpected atom in _type_preorder");
      if (oldt>=0)
        typemax[t][oldt]=typemax[oldt][t]=t;
      oldt=t;
    }
  }
  for(i=0;i<Gnbtype;i++)
    for(j=0;j<Gnbtype;j++)
      if (typemax[i][j]==j)
        inittrans(i,j);
  for(i=0;i<Gnbtype;i++)
    for(j=0;j<Gnbtype;j++)
      if (typemax[i][j]==Gnotype)
        typemax[i][j]=typemax[j][i]=initmax(i,j);
}
int gentypedeclaration(context *fc)
{
  int i;
  int mode=0;
  for(i=0;i<fc->s.n;i++)
  {
    ctxvar *v=fc->c+i;
    int val=v->initval;
    if (val!=-1)
    {
      int t=gentype(val);
      int vt=vartype(*v);
      if (v->flag&(1<<Cauto) && vt!=t && is_subtype(vt,t))
      {
        vartype(*v)=t;
        lastpass++;
      }
      mode|=tree[val].m;
    }
  }
  return mode;
}
void gentypedeffunc(int n)
{
  int funcid=tree[n].x;
  int seq=tree[n].y;
  const char *name=entryname(funcid);
  int savcf;
  int tf;
  gpfunc *gp;
  context *fc;

  /*save current function*/
  savcf=currfunc;
  /*get function number and context*/
  currfunc=findfunction(name);
  gp=lfunc+currfunc;
  /*gentype for seq*/
  gentype(seq);
  /*gentype may change functype(*gp)*/
  tf=functype(*gp);
  fc=block+gp->user->bl;
  if (tf==Gnegbool) tf=functype(*gp)=Gbool;
  if (tf==Glg) tf=functype(*gp)=Gsmall;
  if (tf==Gstr) tf=functype(*gp)=Ggenstr;
  if ((funcmode(*gp)^tree[seq].m)&((1<<Mprec)|(1<<Msidef)))
  {
    lastpass++;
    if(debug==2)
      fprintf(stderr,"%s mode %d now %d\n",gp->gpname,funcmode(*gp),tree[seq].m);
    /*funcmode(*gp)|(tree[seq].m&((1<<Mprec)|(1<<Msidef))));*/
    funcmode(*gp)|=tree[seq].m&((1<<Mprec)|(1<<Msidef));
  }
  currfunc=savcf;
  /*create type*/
  tree[n].t=Gvoid;
  tree[n].m=(1<<Msidef);
}
void gentypeblock(int n)
{
  int seq=tree[n].y;
  int savc;
  int mode;
  context *fc=block+tree[n].x;
  /*save new context address and gentype for seq*/
  savc=s_ctx.n;
  /*push context*/
  pushctx(fc);
  /*gentype for local var*/
  mode=gentypedeclaration(fc);
  /*gentype for seq*/
  gentype(seq);
   /*save context*/
  copyctx(savc,fc);
  /*restore current context*/
  restorectx(savc);
  /*create type*/
  if (fc->ret==-1)
    tree[n].t=Gvoid;
  else
  {
    int v=getvarerr(fc->ret);
    tree[n].t=vartype(ctxstack[v]);
  }
  tree[n].m=mode|(tree[seq].m&MODHERIT);
}

int gentype(int n)
{
  int t,tx,ty;
  int mx,my;
  int x,y,c;
  gpfunc *gp;
  int nf;
  if (n<0)
    return Gnotype;
  x=tree[n].x;
  y=tree[n].y;
  if (tree[n].f<FneedENTRY)
  {
    tx=gentype(x);
    mx=(x>=0)?tree[x].m:0;
    ty=gentype(y);
    my=(y>=0)?tree[y].m:0;
  }
  else
  {
    tx=-1; mx=-1;
    ty=-1; my=-1;
  }
  switch(tree[n].f)
  {
  case Fseq:
    if (x<0 || y<0)
      die(n,"internal error in gentype");
    if (mx&(1<<Mterm))
    {
      tree[n].t=Gvoid;/*the seq end here*/
      tree[n].m=mx&MODHERIT;
    }
    else
    {
      tree[n].t=ty;/*for `if(1,a;b)' and others construct */
      tree[n].m=(my|mx)&MODHERIT;
    }
    break;
  case Fmatrixelts:
    tree[n].t=Gnotype;
    tree[n].m=(mx|my)&MODHERIT;
    break;
  case Fmatrixlines:
    tree[n].t=Gnotype;
    tree[n].m=(mx|my)&MODHERIT;
    break;
  case Faffect:
    {
      int z,lx;
      ctxvar *v;
      tree[n].t=tx;/*Probably it should be ty*/
      tree[n].m=(mx|my)&MODHERIT;
      z=detag(tree[n].x);
      lx=getlvaluerr(z);
      v=ctxstack+getvarerr(lx);
      if (!is_subtype(ty,tx) && tree[z].f==Fentry)
      {
        if (!(v->flag&(1<<Cauto)))
        {
          if ((v->flag&(1<<Cuser)))
          {
            if (!is_subtype(tx,ty))
              die(n,"Assignement to an incompatible type %s<-%s"
                   ,GPname(tx),GPname(ty));
            warning(n,"Assignement to a less precise type: %s<-%s"
                     ,GPname(tx),GPname(ty));
          }
        }
        else
        {
          vartype(*v)=typemax[tx][ty];
          lastpass++;
          if (debug)
            fprintf(stderr,"casting %s from %s to %s now %s.\n",
              varstr(*v),GPname(tx),GPname(ty),GPname(vartype(*v)));
          tree[n].t=ty;
          tx=ty;
          tree[x].t=tx;
        }
      }
      if ((tree[z].f!=Fentry || (v->flag&(1<<Ccompo)))
       && (tree[y].f==Fentry || tree[y].f==Faffect))
        tree[y].m|=(1<<Mcopy);
      if (v->flag&(1<<Ccompo))
        tree[n].m|=(1<<Mcopy);
      if (tx!=Gvoid)
        tree[n].m|=(1<<Msidef);
      tree[n].m|=(tree[z].m&(1<<Mlong))|(1<<Mparens);
    }
    break;
  case Fconst:
    tree[n].m=0;
    switch(value[x].type)
    {
    case CSTsmall:
      tree[n].t=Gsmall;
      break;
    case CSTsmallreal:
      tree[n].t=Greal;
      tree[n].m=(1<<Mprec);
      break;
    case CSTint:
      tree[n].t=Gint;
      break;
    case CSTreal:
      tree[n].t=Greal;
      if (FC_const_real>=0)
        tree[n].m=(1<<Mprec);
      break;
    case CSTstr:
      tree[n].t=Gstr;
      break;
    }
    break;
  case Fsmall:
    tree[n].t=Gsmall;
    tree[n].m=(1<<Msimple);
    break;
  case Flistarg:
    tree[n].t=Gnotype;
    tree[n].m=(mx|my)&MODHERIT;
    break;
  case Ftag:
    tx=gentype(x);
    tree[n].t=y;
    if (!is_subtype(y,tx) && !is_subtype(tx,y))
      die(n,"Conversion to an incompatible type %s->%s"
          ,GPname(tx),GPname(y));
    tree[n].m=tree[x].m&MODHERIT;
    break;
  case Frefarg:
    gentype(x);
    tree[n].t=tree[x].t;
    tree[n].m=(tree[x].m&~(1<<Mlong));
    break;
  case Fentry:
    c=getvar(n);
    if (c>=0)
    {
      ctxvar *v=ctxstack+c;
      tree[n].t=vartype(*v);
      tree[n].m=(1<<Msimple)|(1<<Mvar);
      if (v->flag&(1<<Ccompo))
        tree[n].m|=(1<<Mcopy);
    }
    else
      die(n,"Internal error: extra variable `%s' in gentype",value[x].val.str);
    break;
  case Fentryfunc:
    nf=findfunction(entryname(n));
    if (nf>=0)
    {
      gp=lfunc+nf;
      if (functype(*gp)==Gnotype && gp->spec>0)
        /* is a special function ? */
        tree[n].t=gentypefuncspec(n,gp);
      else if (gp->dsc && (t=gentypefuncdesc(n,gp))!=Gnotype)
        /* else has the function a description ?*/
        tree[n].t=t;
      else
        /* else use the function a type */
      {
        gentype(y);
        tree[n].t=functype(*gp);
        my=(y==-1)?0:tree[y].m;
        tree[n].m=(funcmode(*gp)&(~(1<<Msemicomma)))|(my&MODHERIT);
      }
    }
    else
    {
      gentype(y);
      my=(y==-1)?0:tree[y].m;
      tree[n].t=Ggen;
      tree[n].m=my&MODHERIT;
      warning(n,"function prototype is unknown");
    }
    break;
  case Fdeffunc:
    gentypedeffunc(n);
    break;
  case Fblock:
    gentypeblock(n);
    break;
  case Fgnil:
    if (n!=GNOARG && n!=GNIL)
    {
      tree[n].m=0;
      tree[n].t=Gvoid;
      warning(n,"Internal warning: new gnil.");
    }
    break;
  default:
    die(n,"Internal error: Incorrect node %s in gentype",funcname(tree[n].f));
  }
  return tree[n].t;
}

Generated by  Doxygen 1.6.0   Back to index