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

genblock.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"

static int newprivvar=1;
extern int initnode;
extern int optstrict;

int newdecl(int flag, int t, int initval, int *v)
{
  char s[33];
  sprintf(s,"%d",newprivvar++);
  *v=newnode(Fentry,newentry(strdup(s)),-1);
  return pushvar(*v,flag,t,initval);
}
int newcall(const char *s, int y)
{
  return newnode(Fentryfunc,newentry(s),y);
}

int listtoseq(int *stack, int nb)
{
  int n,i;
  if (nb==-1) return -1;
  for(n=stack[0],i=1;i<nb;n=newnode(Flistarg,n,stack[i++]));
  return n;
}

int newseq(int x, int y)
{
  int seq;
  if (tree[x].f==Fgnil || tree[y].f==Fgnil)
  {
    if (tree[x].f==Fgnil && tree[y].f==Fgnil)
      return GNIL;
    else if (tree[x].f==Fgnil)
      return y;
    else
      return x;
  }
  seq=newnode(Fseq,x,y);
  return seq;
}

int addseqleft(int n, int seq)
{
  int i;
  int bseq;
  if(seq==-1)
    return n;
  if (tree[seq].f!=Fseq)
    return newnode(Fseq,n,seq);
  for(i=seq;tree[tree[i].x].f==Fseq;i=tree[i].x);
  bseq=newnode(Fseq,n,tree[i].x);
  tree[i].x=bseq;
  return seq;
}
int addseqright(int seq, int n)
{
  if(seq==-1)
    return n;
  return newnode(Fseq,seq,n);
}

static int insertreturn(int y)
{
  if (isfunc(y,"return"))
    return y;
  return newcall("return",y);
}

int geninsertreturn(int seq)
{
  int bseq;
  if (seq==GNOARG) return seq;
  if (tree[seq].f==Fseq)
  {
    bseq=insertreturn(tree[seq].y);
    bseq=newnode(Fseq,tree[seq].x,bseq);
  }
  else
    bseq=insertreturn(seq);
  return bseq;
}

int geninsertvar(int seq, int ret)
{
  int bseq;
  if (seq==-1)
    return -1;
  if (ret>=0)
  {
    if (tree[seq].f==Fseq)
    {
      bseq=newnode(Faffect,ret,tree[seq].y);
      bseq=newnode(Fseq,tree[seq].x,bseq);
    }
    else
      bseq=newnode(Faffect,ret,seq);
  }
  else
    bseq=seq;
  return bseq;
}
int geninsertvarop(int seq, int ret, OPerator op)
{
  int bseq;
  if (seq==-1)
    return -1;
  if (ret>=0)
  {
    if (tree[seq].f==Fseq)
    {
      bseq=newopcall(op,ret,tree[seq].y);
      bseq=newnode(Fseq,tree[seq].x,bseq);
    }
    else
      bseq=newopcall(op,ret, seq);
  }
  else
    bseq=seq;
  return bseq;
}

int newcoeff(int n, int x, int y)
{
  int arg[3];
  int nb=y<0?2:3;
  arg[0]=n; arg[1]=x; arg[2]=y;
  return newnode(Fentryfunc,OPcoeff,listtoseq(arg,nb));
}

void makeblock(int bl, int n, int aseq, int ret, int savx)
{
  /*create a block*/
  tree[n].f=Fblock;
  tree[n].x=bl;
  block[bl].ret=ret;
  tree[n].y=aseq;
  copyctx(savx,block+bl);
  restorectx(savx);
}
void makeblocks(int bl1, int bl2, int n, int bseq, int aseq, int ret, int savx)
{
  int y;
  tree[n].f=Fblock;
  tree[n].x=bl1;
  block[tree[n].x].ret=ret;
  y=addseqright(bseq,newnode(Fblock,bl2,aseq));
  tree[n].y=y;
  copyctx(savx,block+bl2);
  restorectx(savx);
}
void makeblocks3(int bl1, int bl2, int bl3, int n, int bseq, int aseq, int ret, int sav0, int savx)
{
  int y;
  tree[n].f=Fblock;
  tree[n].x=bl1;
  block[tree[n].x].ret=ret;
  y=addseqright(bseq,newnode(Fblock,bl2,newnode(Fblock,bl3,aseq)));
  tree[n].y=y;
  copyctx(savx,block+bl3);
  restorectx(savx);
  copyctx(sav0,block+bl2);
  restorectx(sav0);
}

void genblock_nolabel(int n, int p)
{
  int l=newlabel(0);
  genblock(n,p);
  stack_pop_safe(&s_label,l);
}

Clabel_t genblock_label(int n, int p)
{
  Clabel_t t;
  int l=newlabel(1);
  genblock(n,p);
  t=label[l];
  stack_pop_safe(&s_label,l);
  return t;
}

int genblockdeclaration(int args, int n, int flag, int type)
{
  int stack[STACKSZ];
  int i;
  enum {local,global,function} decl;
  int savx=s_ctx.n;
  int mint=(type>=0)?type:Ggen;
  int nb=listtostack(args,Flistarg,stack,STACKSZ,"function declaration",n);
  if (nb==1 && stack[0]==GNOARG)
    nb--;
  decl=(flag&(1<<Carg))?function:(flag&(1<<Cglobal))?global:local;
  for(i=0;i<nb;i++)
  {
    int var,tv;
    int val=-1;
    switch(tree[stack[i]].f)
    {
    case Ftag:
      var=tree[stack[i]].x;
      tv=tree[stack[i]].y;
      if (tree[var].f!=Fentry)
        die(stack[i],"Incorrect declaration");
      if (decl!=function && autogc && ctype[tv]==Vgen)
        /*Make sure GEN objects are gerepilable.*/
        val = newnode(Ftag, newnode(Ftag, newsmall(0), Ggen), tv);
      pushvar(var,flag,tv,val);
      break;
    case Fentry:
      switch(decl)
      {
      case local:
        if (type<0 || autogc)
        /*Make sure (implicitly GEN) objects are gerepilable.*/
          val=newsmall(0);
        break;
      case global:
        if (type<0)
          val=newcall("_const_quote",newstringnode(entryname(stack[i]),-1));
        else if (autogc)
        /*Make sure (implicitly GEN) objects are gerepilable.*/
          val=newsmall(0);
        break;
      case function:
        if (!optstrict)
          val=newsmall(0);
        break;
      }
      pushvar(stack[i],flag,mint,val);
      break;
    case Faffect:
      {
        ctxvar *v;
        int vn;
        genequal(stack[i],"declaration",&var,&val,&tv);
        if (tv==Gnotype)
          tv=mint;
        vn = pushvar(var,flag,tv,val);/* can change ctxstack */
        v = ctxstack+vn;
        if (decl==function && descfindrules1(v->node,FC_default_check))
          v->flag|=(1<<Cdefmarker);
      }
      break;
    default:
      die(n,"Incorrect node %s in function declaration",
          funcname(tree[stack[i]].f));
    }
  }
  for (i=0; i<nb; i++)
  {
    ctxvar *v=ctxstack+savx+i;
    if (v->initval>=0)
      genblock(v->initval,n);
  }
  return nb;
}

int genblockcheckargs(int seq, userfunc *ufunc)
{
  int i;
  gpfunc *gp=lfunc+currfunc;
  context *fc=block+ufunc->bl;
  seq=addseqleft(newcall("_copyarg",-1),seq);
  for(i=ufunc->narg-1;i>=0;i--)
  {
    ctxvar *v=fc->c+ufunc->sarg+i;
    int check=-1;
    gpdescarg *rule=descfindrules1(v->node, FC_badtype);
    if (rule->args[0].type==vartype(*v))
    {
      check=newcall("_badtype",newleaf(v->node));
      if (rule->type!=Gvoid)
        check=newcall("if",
            newnode(Flistarg,check,
                     newcall("_err_type",newstringnode(gp->gpname,-1))));
    }
    if (v->initval>=0 && (v->flag&(1<<Cdefmarker)))
    {
      int n=newnode(Flistarg,
          newcall("_default_check",newleaf(v->node)),
          newnode(Faffect,newleaf(v->node),v->initval));
      check=newcall("if", (check>=0)?newnode(Flistarg,n,check):n);
    }
    if (check>=0)
      seq=addseqleft(check,seq);
  }
  return seq;
}

#if 0
/*The code for
  global(globalvars)
  f(args)=local(localvars);code;...
is */
{
  ulong ltop=avma;
  GEN p1;
  GEN *gptr[]={&p1,&globalsvar};
  {
    GEN args;
    GEN localvars;
    code;
    p1=...;
  }
  gerepilemany(ltop,gptr,N);
  return p1;
}
#endif
void genblockdeffunc(int n)
{
  int funcid=tree[n].x;
  int seq=tree[n].y;
  const char *name=entryname(funcid);
  int args=tree[funcid].y;
  int bl1,gltop=-1;
  int savcf,savnpv;
  int sav1,nodebl1;
  userfunc *ufunc;
  /*save global var*/
  savcf=currfunc;
  savnpv=newprivvar;
  /*reset private var counter*/
  newprivvar=1;
  /*create function*/
  currfunc=findfunction(entryname(funcid));
  if (currfunc<0)
    die(n,"internal error: unknown function %s in genblockdeffunc",name);
  if (lfunc[currfunc].spec!=GPuser)
  {
    if (lfunc[currfunc].spec==GPinstalled)
      die(n,"Cannot redefine install'ed function %s",name);
    else
      die(n,"internal error: not a user function %s in genblockdeffunc",name);
  }
  ufunc=lfunc[currfunc].user;
  /*create external block*/
  bl1=newblock();
  sav1=s_ctx.n;
  ufunc->bctx=sav1;
  ufunc->bl=bl1;
  if (autogc)
  {
    /*declare ltop*/
    gltop=newnode(Fentry,newentry("ltop"),-1);
    pushvar(gltop,1<<Cuser,Gpari_sp,newcall("_avma",-1));
  }
  /*declare function arguments*/
  ufunc->sarg=s_ctx.n-sav1;
  ufunc->narg=genblockdeclaration(args,n,(1<<Cuser)|(1<<Carg)|(1<<Ccompo),-1);
  /*Add return at the end*/
  seq=geninsertreturn(seq);
  /*generate block*/
  genblock(seq,-1);
  if (n!=initnode)
  {
    /*FIXME: For now, clear Cglobal flag to avoid initialization
      problem with implicit fetch_user_var().*/
    int i;
    for (i=sav1;i<s_ctx.n;i++)
    {
      if (ctxstack[i].flag&(1<<Cglobal))
        ctxstack[i].flag&=~(1<<Cglobal);
    }
  }
  copyctx(sav1,block+bl1);
  restorectx(sav1);
  seq=genblockcheckargs(seq,ufunc);
  nodebl1=newnode(Fblock,bl1,seq);
  tree[n].y=nodebl1;
  /*restore globalvar*/
  currfunc=savcf;
  savnpv=newprivvar;
}

int newvectoridx(int var, int ind)
{
  return newcoeff(var, newsmall(ind), -1);
}

int newmatidx(int var, int x, int y)
{
  return newcoeff(var, newsmall(x), newsmall(y));
}

void genblockmatrixl(int n, int x, int y)
{
  int arg[6];
  int var,bsup,seq,ret;
  int vx,vy,vsup;
  int savx,bl1,bl2;
  int aseq,bseq=-1;
  /*we have x[y,] x is a matrix, y a small*/
  newdecl((1<<Cauto)|(1<<Cconst),Gempty,-1,&vx);
  newdecl((1<<Cconst),Gsmall,-1,&vy);
  newdecl((1<<Cconst),Glg,-1,&vsup);
  newdecl(0,Gvec,-1,&ret);
  newdecl(0,Gsmall,-1,&var);
  bsup=newcall("length",newnode(Ftag,newleaf(vx),Gvec));
  bseq=addseqright(bseq,geninsertvar(x,vx));
  bseq=addseqright(bseq,geninsertvar(y,vy));
  bseq=addseqright(bseq,geninsertvar(bsup,vsup));
  genblock(bseq,-1);
  savx=s_ctx.n;
  bl1=newblock();
  bl2=newblock();
  seq=newcoeff(newleaf(vx),newleaf(vy),newleaf(var));
  aseq=newgetg(ret,newleaf(vsup), "t_VEC");
  arg[0]=newnode(Faffect,var,newsmall(1));
  arg[1]=newopcall(OPle,newleaf(var),vsup);
  arg[2]=newcoeff(newleaf(ret),newleaf(var),-1);
  arg[2]=geninsertvar(seq,arg[2]);
  genblock(arg[2],-1);
  arg[3]=newopcall(OPpp,newleaf(var),-1);
  aseq=addseqright(aseq,newcall("for",listtoseq(arg,4)));
  makeblocks(bl1,bl2,n,bseq,aseq,ret,savx);
}
void genblockaffmatrixl(int n, int x, int y, int z)
{
  int arg[6];
  int var,bsup,seq;
  int vy,vz,vsup;
  int savx,bl1,bl2;
  int aseq,bseq=-1;
  /*we have x[y,] x is a matrix, y a small, z is a vector*/
  newdecl((1<<Cconst),Gsmall,-1,&vy);
  newdecl((1<<Cconst),Glg,-1,&vsup);
  newdecl(0,Gsmall,-1,&var);
  bsup=newcall("length",newnode(Ftag,newleaf(x),Gvec));
  if (tree[z].f==Fentry)
  {
    genblock(z,n);
    vz=z;
  }
  else
  {
    newdecl(0,Gvec,-1,&vz);
    bseq=addseqright(bseq,geninsertvar(z,vz));
  }
  bseq=addseqright(bseq,geninsertvar(y,vy));
  bseq=addseqright(bseq,geninsertvar(bsup,vsup));
  genblock(bseq,-1);
  savx=s_ctx.n;
  bl1=newblock();
  bl2=newblock();
  seq=newcoeff(newleaf(x),newleaf(vy),newleaf(var));
  arg[0]=newnode(Faffect,var,newsmall(1));
  arg[1]=newopcall(OPle,newleaf(var),vsup);
  arg[2]=newcoeff(newleaf(vz),newleaf(var),-1);
  arg[2]=geninsertvar(arg[2],seq);
  genblock(arg[2],-1);
  arg[3]=newopcall(OPpp,newleaf(var),-1);
  aseq=newcall("for",listtoseq(arg,4));
  makeblocks(bl1,bl2,n,bseq,aseq,vz,savx);
}
void genblockvector(int n, const char *typ)
{
  int arg[STACKSZ];
  int x=tree[n].x;
  int i,nb,ret;
  int aseq;
  nb=listtostack(x,Fmatrixelts,arg+1,STACKSZ-1,"Vector too long.",n);
  newdecl(0,Gvec,-1,&ret);
  arg[0]=newgetg(ret, newsmall(nb), typ);
  for(i=1;i<=nb;i++)
    arg[i]=geninsertvar(arg[i],newvectoridx(newleaf(ret),i));
  for(i=1;i<=nb;i++)
    genblock(arg[i],-1);
  aseq=newcall("_makevec",listtoseq(arg,nb+1));
  makeblock(newblock(),n,aseq,ret,s_ctx.n);
}
void genblockindex(int n)
{
  int ret,z;
  int aseq;
  newdecl((1<<Cconst),Gsmall,-1,&ret);
  z=newleaf(n);
  tree[z]=tree[n];
  aseq=geninsertvar(z,ret);
  makeblock(newblock(),n,aseq,ret,s_ctx.n);
}
void genblockmatrix(int n)
{
  int line[STACKSZ];
  int arg[STACKSZ];
  int x=tree[n].x,xx;
  int i,j,k,nb=1,nbline,nbcol=-1,ret;
  int aseq;
  nbline=listtostack(x,Fmatrixlines,line,STACKSZ,"[...;...;...]",n);
  for(xx=line[0],nbcol=1;tree[xx].f==Fmatrixelts;xx=tree[xx].x,nbcol++);
  nb+=nbcol;
  for(i=0;i<nbline;i++)
  {
    int k;
    k=listtostack(line[i],Fmatrixelts,arg+nb,STACKSZ-nb,"[...;...;...]",n);
    if (k!=nbcol) die(n,"Matrix must be rectangular");
    nb+=k;
  }
  newdecl(0,Gvec,-1,&ret);
  arg[0]=newgetg(ret,newsmall(nbcol),"t_MAT");
  for(i=1;i<=nbcol;i++)
    arg[i]=newgetg(newcoeff(newleaf(ret),newsmall(i),-1),
                     newsmall(nbline),"t_COL");
  for(j=1,k=1;i<nb;i++)
  {
    arg[i]=geninsertvar(arg[i],newmatidx(newleaf(ret),k,j));
    if (j==nbcol)
    {
      j=1;
      k++;
    }
    else
      j++;
  }
  for(i=0;i<nb;i++)
    genblock(arg[i],-1);
  aseq=newcall("_makevec",listtoseq(arg,nb));
  makeblock(newblock(),n,aseq,ret,s_ctx.n);
}

void genblockprotoraw(int n, gpfunc *gp)
{
  int arg[STACKSZ];
  const char *p=gp->proto.code, *q=gp->proto.code;
  char c;
  PPproto mod;
  int nb=genlistargs(n,arg,0,STACKSZ);
  int i=0;
  while((mod=parseproto(&p,&c)))
  {
    switch(mod)
    {
    case PPstd:
    case PPdefault:
    case PPdefaultmulti:
      if (c=='r' && i<nb)
      {
        if (tree[arg[i]].f==Fentry)
          tree[arg[i]].f=Fconst;
        else if (tree[arg[i]].f!=Fconst)
          die(n,"argument must be a raw string");
      }
      break;
    default: /* Skip */
      break;
    }
    q=p;
  }
}
/*
  n: node
  p: caller node

  Rule of the game:
  genblock must never be used twice on the same node.
  Using p=-1 is allowed but this assume the value of n is to be discarded.

  genblock must not change p.
*/
static long multi=0;
extern int linecount;

int newgetgvec(const char *t)
{
  return newtag(newcall("_cgetg",
                        newnode(Flistarg, newsmall(0), newstringnode(t,-1))),
                "vec", -1);
}

void genblock(int n, int p)
{
  int x,y;
  if (n<0)
    return;
  linecount=tree[n].lineno;
  x=tree[n].x;
  y=tree[n].y;
  switch(tree[n].f)
  {
  case Fseq:
      genblock(x, n);
      genblock(y, n);
    break;
  case Fmat:
      if (x==-1)
      {
        int z=newgetgvec("t_MAT");
        tree[n]=tree[z];
      }
      else
        genblockmatrix(n);
    break;
  case Fvec:
      if (x==-1)
      {
        int z=newgetgvec("t_VEC");
        tree[n]=tree[z];
      }
      else
        genblockvector(n, "t_VEC");
    break;
  case Faffect:
    x=detag(x);
    if (tree[x].f==Ffacteurmat)
    {
      int l=getlvalue(x);
      genblock(l,n);
      if (l>=0)
      {
        ctxvar *v=ctxstack+getvarerr(l);
        v->flag|=1<<Ccompo;
      }
    }
    if (tree[x].f==Ffacteurmat && tree[tree[x].y].f==FmatrixL)
    {
      int xx=tree[x].x;
      int xy=tree[tree[x].y].x;
      genblockaffmatrixl(n,xx,xy,y);
    }
    else
    {
      genblock(x, n);
      genblock(y, n);
    }
    break;
  case Fmatrix:
  case FmatrixR:
    genblock(x,n);
    genblock(y,n);
    if (multi && x!=-1 && tree[x].f!=Fsmall)
      genblockindex(x);
    if (multi && y!=-1 && tree[y].f!=Fsmall)
      genblockindex(y);
    break;
  case Ffacteurmat:
    if ( tree[y].f==FmatrixL )
    {
      y=tree[n].y=tree[y].x;
      if (FC_matrixrow>=0)
      {
        int nn;
        genblock(x,n);
        genblock(y,n);
        nn=newcall("_[_,]",newnode(Flistarg,x,y));
        tree[n]=tree[nn];
      }
      else
        genblockmatrixl(n,x,y);
    }
    else
    {
      int nn;
      genblock(x,n);
      genblock(y,n);
      nn=newcoeff(x,tree[y].x,tree[y].y);
      tree[n]=tree[nn];
    }
    break;
  case Frefarg:
    x=detag(x);
    if (tree[x].f==Ffacteurmat)
    {
      int l=getlvalue(x);
      genblock(l,n);
      if (l>=0)
      {
        ctxvar *v=ctxstack+getvarerr(l);
        v->flag|=1<<Ccompo;
      }
    }
    genblock(x,n);
    break;
  case Fentry:/*may be an hidden function call*/
    if (findfunction(entryname(n))==-1) /*it is not a function call*/
    {
      if (getvar(n)==-1)
      {/*The variable has not been declared.
        * We declare it as a function-local variable initialized
        * to 'var. The global flag is set to avoid being block-local.
        * It is discarded in genblockdeffunc. This can be changed.
        */
        int iv=newquotenode(entryname(n),-1);
        pushvar(n,(1<<Cuser)|(1<<Cglobal)|(1<<Cundeclared),Ggen,iv);
        if (warn)
          warning(n,"variable undeclared");
      }
      break;
    }/*else it is a function call*/
    tree[n].f=Fentryfunc;
  case Fentryfunc:/*fall through*/
    if (x==OPn)
    {
      if (tree[y].f==Fsmall)
      {
        tree[n]=tree[y];
        tree[n].x=-tree[n].x;
        break;
      }
      else if (tree[y].f==Fconst)
      {
        value_t *val = value + tree[y].x;
        if (val->type==CSTsmall || val->type==CSTsmallreal)
        {
          tree[n]=tree[y];
          val->val.small=-val->val.small;
          break;
        }
      }
    }
    else if (x==OPtrans && tree[y].f==Fvec)
    {
      if (tree[y].x==-1)
      {
        int z=newgetgvec("t_COL");
        tree[n]=tree[z];
      }
      else
      {
        tree[n]=tree[y];
        genblockvector(n,"t_COL");
        break;
      }
    }
    /*FIXME: add true parsing of description*/
    if (x>=OPss && x<=OPme)
    {
      int dy;
      if (x<=OPpp)
        dy=detag(y);
      else
        dy=detag(tree[y].x);
      if (tree[dy].f==Ffacteurmat)
      {
        int l=getlvalue(dy);
        genblock(l,n);
        ctxvar *v = ctxstack+getvarerr(l);
        v->flag|=1<<Ccompo;
      }
      multi++;
      genblock(y,n);
      multi--;
    }
    else
    {
      int nf=findfunction(value[x].val.str);
      if (nf>=0 && lfunc[nf].spec>0)
        genblockfuncspec(n,p,lfunc+nf);
      else
      {
        if (nf>=0 && lfunc[nf].proto.code)
          genblockprotoraw(n,lfunc+nf);
        genblock(y,n);
      }
    }
    break;
  case Fdeffunc:
    if (currfunc!=-1)
      die(n,"nested function definition not implemented");
    genblockdeffunc(n);
    break;
  case Fconst:
  case Fsmall:
  case Fgnil:
    break;
  case Ftag:
    genblock(x,n);
    break;
  case Fblock:
    die(p,"Internal error : looping in genblock");
  default:
    if (tree[n].f>=FneedENTRY)
    {
      die(p,"Internal error : unknown func %s in genblock",funcname(tree[n].f));
    }
    else
    {
      genblock(x, n);
      genblock(y, n);
    }
  }
}


Generated by  Doxygen 1.6.0   Back to index