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

genfunc.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 <ctype.h>
#include "header.h"
extern int indent;
int currfunc;
static int newcvar=1;

/*Use getfunc or newuserfunc instead*/
static int newfunc(const char *gpname)
{
  int nf=stack_new(&s_func);
  gpfunc *f=lfunc+nf;
  f->gpname=gpname;
  f->proto.cname=gpname;
  f->proto.code=NULL;
  f->proto.origin=NULL;
  f->proto.help=NULL;
  f->node=newnode(Ffunction,nf,-1);
  functype(*f)=Gempty;
  funcmode(*f)=0;
  f->spec=GPpari;
  f->dsc=NULL;
  f->user=NULL;
  return nf;
}

int newuserfunc(const char *gpname)
{
  int nf=newfunc(gpname);
  gpfunc *f=lfunc+nf;
  userfunc *uf;
  if (gpname[0]=='_' && gpname[1]=='.')
  {
    char *s=strdup(gpname);
    s[0]='m'; s[1]='_';
    f->proto.cname=usercname(s);
    if (s!= f->proto.cname) free(s);
  }
  else
    f->proto.cname=usercname(gpname);
  f->spec=GPuser;
  f->proto.origin=namelib;
  uf=f->user=(userfunc*) malloc(sizeof(*f->user));
  stack_init(&uf->v,sizeof(*uf->var),(void *)&uf->var);
  stack_init(&uf->g,sizeof(*uf->gcvar),(void *)&uf->gcvar);
  return nf;
}

int findfunction_len(const char *s, int n)
{
  int i;
  for(i=0; i<s_func.n;i++)
  {
    const char *f=lfunc[i].gpname;
    if (strlen(f)==n && !strncmp(s,f,n))
      return i;
  }
  return -1;
}

int findfunction(const char *s)
{
  int i;
  for(i=0; i<s_func.n && strcmp(lfunc[i].gpname,s);i++);
  return i<s_func.n?i:-1;
}

int findfuncdesc(const char *s)
{
  int n=findfunction(s);
  if (n<0)
    die(err_desc,"Cannot find description of %s",s);
  if (!lfunc[n].dsc)
    die(err_desc,"Function %s has no description",s);
  return n;
}

int findfuncdescopt(const char *s)
{
  int n=findfunction(s);
  if (n>=0 && !lfunc[n].dsc)
    die(err_desc,"Function %s has no description",s);
  return n;
}

int findfunctype(char *s)
{
  int nf=findfuncdesc(s);
  gpdescarg *da=descfindrules(0,NULL,lfunc+nf);
  return da->type;
}

int getfunc(const char *gpname)
{
  int r=findfunction(gpname);
  if (r>=0)
    return r;
  return newfunc(strdup(gpname));
}

int genautoarg(FILE *fout, char c)
{
  switch(c)
  {
  case 'p':
    fprintf(fout,"prec");
    return 1;
  case 'P':
    fprintf(fout,"precdl");
    return 1;
  }
  return 0;
}
int genarg(int nerr, FILE *fout, char c, int n)
{
  if (n==-1)
    die(n,"missing mandatory argument in function call");
  switch(c)
  {
  case 'G':
    gencast(fout,n,Ggen);
    return 1;
  case 'L':
    gencast(fout,n,Gsmall);
    return 1;
  case '&':
    if (tree[n].f!=Frefarg)
      die(nerr,"Missing & for reference");
    fprintf(fout,"&");
    gencode(fout,n);
    return 1;
  case 'W':
    gencode(fout,n);
    return 1;
  case 'r':
  case 's':
    gencast(fout,n,Gstr);
    return 1;
  case 'n':
    gencast(fout,n,Gvar);
    return 1;
  default:
    die(nerr,"Unsupported letter `%c' in prototype.\n"
        "This function is not supported by the compiler."
        ,c);
    return 0;
  }
}
void gendefarg(int n, FILE *fout, char c, const char *name)
{
  switch(c)
  {
  case 'G':
  case '&':
  case 'I':
  case 'V':
    fprintf(fout,"NULL");
    break;
  case 'n':
    fprintf(fout,"-1");
    break;
  default:
    die(n,"Unknown default in prototype code `%c' for `%s'",c,name);
  }
}
void gendefargmulti(FILE *fout, char const *q, char const *p)
{
  for(p++;p<q-3;p++)
    if (p[0]!='\\' || p[1]!='"')
      fputc(*p,fout);
}

int genfuncbycode(FILE *fout, int nb, int *arg, int nf, int nerr)
{
  gpproto pro=lfunc[nf].proto;
  const char *name=pro.cname;
  const char *proto=pro.code;
  int i=0;
  int firstarg=0;
  char const *p=proto,*q=proto;
  char c;
  PPproto mod;
  if (!proto) return 1;
  fprintf(fout,"%s(",name);
  while((mod=parseproto(&p,&c)))
  {
    if (mod==PPsep) continue;
    if (firstarg) fprintf(fout,", ");
    firstarg=1;
    switch(mod)
    {
    case PPstd:
      if (genautoarg(fout,c))
        break;
      if (i<nb && arg[i]!=GNOARG)
        genarg(nerr,fout,c,arg[i]);
      else
        die(nerr,"Mandatory argument needed for %s",name);
      i++;
      break;
    case PPdefault:
      if (i<nb && arg[i]!=GNOARG)
        genarg(nerr,fout,c,arg[i]);
      else
        gendefarg(nerr,fout,c,name);
      i++;
      break;
    case PPdefaultmulti:
      if (i<nb && arg[i]!=GNOARG)
        genarg(nerr,fout,c,arg[i]);
      else
        gendefargmulti(fout,p,q);
      i++;
      break;
    case PPmultiarg:
      {
        int carg[STACKSZ];
        int na,j;
        for (na=0,j=i; j<nb; j++)
          na+=genlistcats(arg[j],carg+na,STACKSZ-na);
        genfuncbydesc(fout,na,carg,FC_tovec,nerr);
        i+=na;
        break;
      }
    default:
      die(nerr,"internal error: PPproto %d in genfuncbycode",mod);
    }
    q=p;
  }
  if(i<nb) die(nerr,"Too many arguments in function call");
  fprintf(fout,")");
  return 0;
}

int genfuncbycode1(FILE *fout, int arg, int nf, int nerr)
{
  return genfuncbycode(fout,1,&arg,nf,nerr);
}

void gencodenoarg(FILE *fout, int t, int n)
{
  int arg=newsmall(0);
  tree[arg].t=t;
  if (genfuncbydesc1(fout, arg, FC_default_marker, n))
    die(n,"No implicit default for type %s",GPname(t));
  stack_pop_safe(&s_node,arg);
}

void genuserfunc(FILE *fout, int n, int nf)
{
  int arg[STACKSZ];
  int nb,firstarg=0;
  int j;
  gpfunc *gp=lfunc+nf;
  userfunc *ufunc=gp->user;
  context *fc=block+gp->user->bl;
  nb=genlistargs(n,arg,0,ufunc->narg);
  fprintf(fout,"%s(",gp->proto.cname);
  for(j=0;j<ufunc->narg;j++)
  {
    ctxvar *v=fc->c+ufunc->sarg+j;
    int t=vartype(*v);
    if (firstarg)
      fprintf(fout,", ");
    firstarg=1;
    if (j<nb && arg[j]>=0 && arg[j]!=GNOARG)
      gencast(fout,arg[j],t);
    else if (v->initval<0)
      die(n,"a mandatory argument is missing");
    else if (v->flag&(1<<Cdefmarker))
      gencodenoarg(fout,t,n);
    else
      gencast(fout,v->initval,t);
  }
  if (funcmode(*gp)&(1<<Mprec))
  {
    if (firstarg) fprintf(fout,", ");
    else firstarg=1;
    fprintf(fout,"prec");
  }
  fprintf(fout,")");
}

int genfunc(FILE *fout, int nb, int *arg, int nf, int nerr)
{
  if (lfunc[nf].dsc && genfuncbydesc(fout,nb,arg,nf,nerr)==0)
    return 0;
  return genfuncbycode(fout,nb,arg,nf,nerr);
}

int genfunc1(FILE *fout, int arg, int nf, int nerr)
{
  return genfunc(fout,1,&arg,nf,nerr);
}

void genentryfunc(FILE *fout, int n)
{
  int stack[STACKSZ];
  const char *name=entryname(n);
  int i,nb;
  int nf=findfunction(name);
  if (nf >= 0)
  {
    gpfunc *gp=lfunc+nf;
    if (gp->spec==0)
    {
      genuserfunc(fout,n,nf);
      return;
    }
    else if (gp->spec>0)
    {
      genentryspec(fout,n,gp);
      return;
    }
    nb=genlistargs(n,stack,0,STACKSZ);
    if (genfunc(fout,nb,stack,nf,n)==0)
      return;
    if (gp->dsc)
      die(n," %s: arguments do not match descriptions",name);
    if (gp->proto.cname)
      name=gp->proto.cname;
  }
  /*copy verbatim*/
  nb=genlistargs(n,stack,0,STACKSZ);
  fprintf(fout,"%s(",name);
  for(i=0;i<nb;i++)
  {
    if (i) fprintf(fout,", ");
    gencode(fout,stack[i]);
  }
  fprintf(fout,")");
}

void genentry(FILE *fout, int n)
{
  ctxvar *v=ctxstack+getvarerr(n);
  fprintf(fout,"%s",v->cvar);
}

void genvarproto(FILE *fout, int n, int nerr)
{
  if (genfuncbydesc1(fout,n,FC_decl_base,nerr))
    die(nerr,"type not suitable for a variable");
  fprintf(fout," ");
  if (genfuncbydesc1(fout,n,FC_decl_ext,nerr))
    gencode(fout,n);
}

void genfuncproto(FILE *fout, int nf, char *sep, int nerr)
{
  gpfunc *gp=lfunc+nf;
  int n=gp->node;
  if (genfuncbydesc1(fout,n,FC_decl_base,nerr))
    die(nerr,"type not suitable for a function");
  fprintf(fout,"%s",sep);
  if (genfuncbydesc1(fout,n,FC_decl_ext,nerr))
    gencode(fout,n);
}

static void gendecvarend(FILE *fout, int t)
{
  if (t>=0)
  {
    if (t!=Ggen && t!=Gsmall && t!=Gpari_sp && t!=Gvoid)
      fprintf(fout,";\t  /* %s */\n",GPname(t));
    else
      fprintf(fout,";\n");
  }
}

void gendecvar(FILE *fout, context *fc, int nerr)
{
  int oldt=-1;
  int idx;
  for(idx=0;idx<fc->s.n;idx++)
  {
    ctxvar *v=fc->c+idx;
    int t=vartype(*v);
    if ((v->flag&(1<<Cconst)) && v->val!=-1)
      continue;
    if (v->flag&(1<<Carg))
      continue;
    if (is_subtype(vartype(*v),Gvoid))
      continue;
    if (t!=oldt)
    {
      gendecvarend(fout,oldt);
      genindent(fout);
      if (genfuncbydesc1(fout,v->node,FC_decl_base,nerr))
        die(nerr,"type `%s' not suitable for a variable",GPname(t));
      fprintf(fout, " ");
    }
    else
      fprintf(fout, ", ");
    if (genfuncbydesc1(fout,v->node,FC_decl_ext,nerr))
      gencode(fout,v->node);
    if (v->initval>=0)
    {
      fprintf(fout," = ");
      gencast(fout,v->initval,vartype(*v));
    }
    else if (ctype[t]==Vgen && autogc)
    {
      /* We want to protect gerepile from uninitialized values*/
      fprintf(fout," = ");
      gencast(fout, GNIL, Ggen);
    }
    oldt=t;
  }
  gendecvarend(fout,oldt);
}

void genprotocode(FILE *fout, int nf)
{
  gpfunc *gp=lfunc+nf;
  char const *p=gp->proto.code;
  char c;
  PPproto mod;
  int firstarg=0;
  fprintf(fout,"extern ");
  genfuncproto(fout, nf, " ", -1);
  fprintf(fout,"(");
  while((mod=parseproto(&p,&c)))
  {
    if (mod==PPsep) continue;
    if (firstarg) fprintf(fout,", ");
    firstarg=1;
    switch(c)
    {
    case 'p':
    case 'P':
    case 'L':
    case 'n':
      fprintf(fout,"long");
      break;
    case 'f':
      fprintf(fout,"long *");
      break;
    case 'W':
    case 'G':
      fprintf(fout,"GEN");
      break;
    case 'F':
    case '&':
      fprintf(fout,"GEN *");
      break;
    case 'r':
    case 's':
    case 'E':
    case 'I':
      fprintf(fout,"char *");
      break;
    case 'V':
    case 'S':
      fprintf(fout,"entree *");
      break;
    default:
      die(err_func,"prototype letter `%c' not known",c);
    }
  }
  fprintf(fout,")");
}

void genprototype(FILE *fout, int nf, int kb)
{
  int firstarg;
  gpfunc *gp=lfunc+nf;
  int m=funcmode(*gp);
  int i;
  int nerr=gp->user->defnode;
  int savc=s_ctx.n;
  context *fc=block+gp->user->bl;
  genfuncproto(fout,nf,kb?"\n":" ",nerr);
  fprintf(fout,"(");
  firstarg=0;
  pushctx(fc);
  for (i=0;i<fc->s.n;i++)
  {
    ctxvar *v=fc->c+i;
    if( v->flag&(1<<Carg) )
    {
      if (firstarg) fprintf(fout,", ");
      else firstarg=1;
      genvarproto(fout,v->node, nerr);
      if (v->initval>=0 && !(v->flag&(1<<Cdefmarker)) && vartype(*v)!=Ggen)
      {
        fprintf(fout,"/*=");
        printnode(fout,v->initval);
        fprintf(fout,"*/");
      }

    }
  }
  s_ctx.n=savc;
  if (m&(1<<Mprec))
  {
    if (firstarg) fprintf(fout,", ");
    else firstarg=1;
    fprintf(fout,"long prec");
  }
  if (!firstarg) fprintf(fout,"void");
  fprintf(fout,")");
}

void gendeffunc(FILE *fout, int n)
{
  int funcid=tree[n].x;
  int seq=tree[n].y;
  const char *name=entryname(funcid);
  int savcf=currfunc;
  gpfunc *gp;
  int t;
  /*get func number and context*/
  currfunc=findfunction(name);
  newcvar=1;
  if (currfunc==-1)
    die(n,"Internal error in gendeffunc : func %s not found",name);
  gp=lfunc+currfunc;
  gencomment(fout,funcid,0);
  genprototype(fout,currfunc,1);
  t=functype(*gp);
  if (t!=Ggen && t!=Gsmall)
    fprintf(fout,"\t  /* %s */",GPname(t));
  fprintf(fout,"\n");
  gencode(fout,seq);
  fprintf(fout,"\n");
  currfunc=savcf;
}

void gendefblock(FILE *fout, int n)
{
  int b=tree[n].x;
  int seq=tree[n].y;
  int i;
  int t,m;
  int savc;
  context *fc=block+b;
  savc=s_ctx.n;
  for(i=0;i<fc->s.n;i++)
  {
    ctxvar *v=fc->c+i;
    int t=vartype(*v);
    if ((v->flag&(1<<Cconst)) && v->val!=-1) continue;
    if (t!=Gvoid && isdigit(*varstr(*v)))
    {
      char s[33];
      sprintf(s,"%c%d",(ctype[t]==Vgen?'p':'l'),newcvar++);
      v->cvar=strdup(s);
    }
  }
  pushctx(fc);
  /*some shortcut*/
  t=tree[n].t;
  m=tree[n].m;
  if(!(m&(1<<Mbrace)))
  {
    genindent(fout);
    fprintf(fout,"{\n");
    indent++;
  }
  gendecvar(fout,fc,n);
  genindentseq(fout,seq);
  gencode(fout,seq);
  gensemicomma(fout,seq);
  if(!(m&(1<<Mbrace)))
  {
    indent--;
    genindent(fout);
    fprintf(fout,"}\n");
  }
  s_ctx.n=savc;
}

Generated by  Doxygen 1.6.0   Back to index