home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / progs / pari / pari_137 / src / init.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-05-20  |  9.6 KB  |  338 lines
  1. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  2. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  3. /*                                                                 */
  4. /*                                                                 */
  5. /*              PROGRAMME D'INITIALISATION DU SYSTEME              */
  6. /*                                                                 */
  7. /*                    ET TRAITEMENT DES ERREURS                    */
  8. /*                                                                 */
  9. /*                       copyright Babe Cool                       */
  10. /*                                                                 */
  11. /*                                                                 */
  12. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  13. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  14.  
  15.  
  16. #include        "genpari.h"
  17.  
  18. /*      Variables statiques communes :          */
  19.  
  20. unsigned long top,bot,avma;
  21. long    avloc;
  22. long    prec=5, precdl=16, defaultpadicprecision=16;
  23. long    tglobal,paribuffsize=30000,pariecho=0;
  24. jmp_buf environnement;
  25. FILE    *outfile = stdout;
  26. FILE    *logfile = NULL;
  27. FILE    *infile = stdin;
  28. long    nvar = 0;
  29. GEN     gnil,gzero,gun,gdeux,ghalf,polvar,gi,RAVYZARC;
  30. GEN     gpi=(GEN)0;
  31. GEN     geuler=(GEN)0;
  32. GEN     bernzone=(GEN)0;
  33. entree  **varentries, *hashtable[TBLSZ];
  34. GEN     *blocliste, *polun, *polx, *g;
  35. long    *ordvar,varchanged=0;
  36. long    nextbloc = 0;
  37. long    glbfmt[]={'g',0,28};
  38. long    **rectgraph;
  39.  
  40. byteptr diffptr;
  41. long    lontyp[30]={0,0x10000,0x10000,1,1,1,1,2,1,1,2,2,0,1,1,1,1,1,1,1};
  42. long    lontyp2[30]={0,0x10000,0x10000,2,1,1,1,3,2,2,2,2,0,1,1,1,1,1,1,1};     
  43.      
  44.      /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  45.      /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  46.      /*                                                                 */
  47.      /*                      INITIALISATION DU SYSTEME                  */
  48.      /*                                                                 */
  49.      /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  50.      /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  51.  
  52. void catchinterrupt()
  53. {
  54.   signal(SIGINT,catchinterrupt);
  55.   err(interrupter);
  56. }
  57.  
  58. void init(parisize,maxprime)
  59.      long parisize,maxprime;
  60.      
  61. {
  62.   long v, n;
  63.   char *p;
  64.   GEN p1;
  65.   
  66.   if (setjmp(environnement))
  67.   {
  68.     fprintf(stderr, "\n  ###   Error in the PARI system. End of the program.\n");
  69.     exit(1);
  70.   }
  71.   signal(SIGINT,catchinterrupt);
  72.   
  73.   if (!(diffptr=initprimes(maxprime))) err(memer);
  74.   if (!(bot=(long)malloc(parisize))) err(memer);
  75.   top=avma=bot+parisize;
  76.   if (!(varentries=(entree **)malloc(4*MAXVAR))) err(memer);
  77.   if (!(blocliste=(GEN *)malloc(4*MAXBLOC))) err(memer);
  78.   if (!(ordvar=(long *)malloc(4*MAXVAR))) err(memer);
  79.   if (!(polun=(GEN *)malloc(1024))) err(memer);
  80.   if (!(polx=(GEN *)malloc(1024))) err(memer);
  81.   if (!(g=(GEN *)malloc(4*STACKSIZE))) err(memer);
  82.   if (!(rectgraph=(long**)malloc(64))) err(memer);
  83.   for(n=0;n<16;n++) if(!(rectgraph[n]=(long*)malloc(24))) err(memer);
  84.   
  85.   for(n = 0; n < TBLSZ; n++) hashtable[n] = NULL;
  86.   for(v = 0; v < NUMFUNC; v++)
  87.   {
  88.     for(n = 0, p = fonctions[v].name; *p; p++) n = n << 1 ^ *p;
  89.     if (n < 0) n = -n; n %= TBLSZ;
  90.     fonctions[v].next = hashtable[n];
  91.     hashtable[n] = fonctions + v;
  92.   }
  93.   gnil = cgeti(2);gnil[1]=2; setpere(gnil,255);
  94.   gzero = cgeti(2);gzero[1]=2; setpere(gzero, 255);
  95.   gun = stoi(1); setpere(gun, 255);
  96.   gdeux = stoi(2); setpere(gdeux, 255);
  97.   ghalf = cgetg(3,4);ghalf[1]=un;ghalf[2]=deux; setpere(ghalf, 255);
  98.   gi = cgetg(3,6); gi[1] = zero; gi[2] = un; setpere(gi, 255);
  99.   p1=cgetg(4,10);p1[1]=0x1ff0004;p1[2]=zero;p1[3]=un;polx[255]=p1;
  100.   p1=cgetg(3,10);p1[1]=0x1ff0003;p1[2]=un;polun[255]=p1;
  101.   for(v=0; v < MAXVAR; v++) ordvar[v] = v;
  102.   polvar = cgetg(MAXVAR + 1,17); setlg(polvar,1); setpere(polvar, 255);
  103.   for(v=1;v<=MAXVAR;v++) polvar[v]=0x11ff0001;
  104.   for(v = 0; v < MAXBLOC; v++) blocliste[v] = (GEN)0;
  105.   for(v = 0; v < STACKSIZE; v++) g[v] = gzero;
  106.   lisseq("x");avloc=avma;
  107. }
  108.  
  109. GEN geni()
  110. {
  111.   return gi;
  112. }
  113.  
  114. long marklist()
  115. {
  116.   long i;
  117.   GEN x, *p = blocliste;
  118.   for (i = 0; i < MAXBLOC; i++)
  119.     if(x = blocliste[i])
  120.     {
  121.       x[-2] = (long)p;
  122.       *p++ = x;
  123.     }
  124.   for (nextbloc = i = p - blocliste; i < MAXBLOC; i++)
  125.     blocliste[i] = 0;
  126.   return nextbloc;
  127. }
  128.  
  129. GEN newbloc(n)
  130.   long n;
  131. {
  132.   long i, *x;
  133.   for(i = nextbloc; i < MAXBLOC; i++) if (!blocliste[i]) break;
  134.   if (i == MAXBLOC)
  135.   {
  136.     for (i = 0; i < nextbloc; i++) if (!blocliste[i]) break;
  137.     if (i == nextbloc) err(newblocer1);
  138.   }
  139.   x = (long *)malloc((n << 2) + 8);
  140.   if (!x) err(memer);
  141.   x += 2;
  142.   x[-2] = (long)(blocliste + i);
  143.   x[-1] = 0;
  144.   blocliste[i] = x;
  145.   nextbloc = i + 1;
  146.   return x;
  147. }
  148.  
  149. void killbloc(x)
  150.   GEN x;
  151. {
  152.   if (!x || isonstack(x)) return;
  153.   *(long *)x[-2] = 0;
  154.   free(x-2);
  155. }
  156.  
  157. void newvalue(ep, val)
  158.   entree *ep;
  159.   GEN val;
  160. {
  161.   GEN y = gclone(val);
  162.   y[-1] = (long) ep->value;
  163.   ep->value = (void *)y;
  164. }
  165.  
  166. void changevalue(ep, val)
  167.   entree *ep;
  168.   GEN val;
  169. {
  170.   GEN y = gclone(val);
  171.   GEN x = (GEN)ep->value;
  172.   ep->value = (void *)y;
  173.   if ((long)x - (long)ep == sizeof(entree)) 
  174.   {
  175.     y[-1] = (long)x;
  176.     return;
  177.   }
  178.   y[-1] = x[-1];
  179.   killbloc(x);
  180. }
  181.  
  182. void killvalue(ep)
  183.   entree *ep;
  184. {
  185.   GEN x = (GEN)ep->value;
  186.   if ((long)x - (long)ep == sizeof(entree)) return;
  187.   ep->value = (void *)x[-1];
  188.   killbloc(x);
  189. }
  190.  
  191.  
  192. void install(f, name, valence)
  193.      GEN (*f)();
  194.      char *name;
  195.      int valence;
  196. {
  197.   int n;
  198.   entree *ep;
  199.   char *p;
  200.   
  201.   if ((valence < 0) || (valence > 3)) err(valencer1);
  202.   for(n = 0, p = name; *p; p++) n = n << 1 ^ *p;
  203.   if (n < 0) n = -n; n %= TBLSZ;
  204.   for(ep = hashtable[n]; ep; ep = ep->next)
  205.     if (!strcmp(name, ep->name)) err(nomer1);
  206.   ep = (entree *)malloc(sizeof(entree) + strlen(name) + 1);
  207.   ep->name = (char *)ep + sizeof(entree); strcpy(ep->name, name);
  208.   ep->value = (void *)f;
  209.   ep->valence = valence;
  210.   ep->next = hashtable[n];
  211.   hashtable[n] = ep;
  212. }
  213.  
  214. void preserve(av, nb)
  215.      long av, nb;
  216. {
  217.   GEN q,**s;
  218.   long i,tetpil=avma;
  219.   for(s=(GEN**)&nb,i=1; i<nb; i++) {s++; **s = gcopy(**s);}
  220.   q=cgetg(nb+1,17);
  221.   for(s=(GEN**)&nb,i=1; i<nb; i++) q[i]=(long)**++s;
  222.   q=gerepile(av, tetpil,q);
  223.   for(s=(GEN**)&nb,i=1; i<nb; i++) **++s=(GEN)q[i];
  224.   avma+=(nb+1)*sizeof(long);
  225. }
  226.  
  227. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  228. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  229. /*                                                                 */
  230. /*              TRAITEMENT DES ERREURS                             */
  231. /*                                                                 */
  232. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  233. /*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*/
  234.  
  235.  
  236. void err(numerr,ch,noninv)
  237.      
  238.      long numerr;
  239.      char *ch;
  240.      GEN noninv;
  241.      
  242. {
  243.   char c;
  244.   FILE *temp;
  245.  
  246.   fprintf(stderr, "\n  ***   %s",errmessage[numerr]);
  247.   switch (numerr)
  248.   {
  249.     case matcher1:
  250.       c = *ch++;
  251.       fprintf(stderr, "'%c'\n  ***   instead of: '%s'", c, ch); break;
  252.     case impl: fprintf(stderr, " %s is not yet implemented.",ch); break;
  253.     case talker: fprintf(stderr, "%s.",ch); break;
  254.     case invmoder: temp=outfile;outfile=stderr;fprintf(stderr,": ");
  255.       output(noninv);outfile=temp;break;
  256.     case errpile: putc('\n', stderr);allocatemoremem();break;
  257.     case varer1:
  258.     case unknowner1:
  259.     case caracer1: fprintf(stderr, "'%s'",ch);
  260.   }
  261.   putc('\n', stderr);
  262.   longjmp(environnement, numerr);
  263. }
  264.  
  265. void recover(listloc)
  266.   long listloc;
  267. {
  268.   long i, m, n;
  269.   GEN x;
  270.   entree *ep, *ep2;
  271.  
  272.   for (n = 0; n < TBLSZ; n++)
  273.     for (ep = hashtable[n]; ep;)
  274.       if (ep->valence >= 100)
  275.       {
  276.         x = (GEN)ep->value;
  277.         if ((long)x - (long)ep == sizeof(entree))
  278.         {
  279.           if (ep->valence == 200) ep = ep->next;
  280.           else
  281.             if (ep == hashtable[n])
  282.             {
  283.               hashtable[n] = ep->next;
  284.               free(ep);
  285.               ep = hashtable[n];
  286.             }
  287.             else
  288.             {
  289.               for(ep2 = hashtable[n]; ep2->next != ep; ep2 = ep2->next);
  290.               ep2->next = ep->next;
  291.               free(ep); ep = ep2->next;
  292.             }
  293.           continue;
  294.         }
  295.         m = (long *)x[-2] - (long *)blocliste;
  296.         if ((m < listloc) || (m >= MAXBLOC)) ep=ep->next;
  297.         else killvalue(ep);
  298.       }
  299.       else ep = ep->next;
  300.   for (i = listloc; i < MAXBLOC; i++)
  301.     if ((x = blocliste[i]) && (x != gpi) && (x != geuler))
  302.       killbloc(x);
  303. }
  304.  
  305. void allocatemoremem()
  306. {
  307.   long av,declg,declg2,tl,parisize,v;
  308.   GEN ll,pp,l1,l2,l3;
  309.   unsigned long topold,avmaold,botold;
  310.  
  311.  /* Peut-etre pourra-t-on utiliser ce qui suit plus tard */
  312.   avmaold=avloc;topold=top;botold=bot;parisize=(topold-botold)<<1;
  313.   if (!(bot=(long)malloc(parisize))) err(nomer2);
  314.   fprintf(stderr, "  *** Warning: doubling the stack size; new stack = %d\n",parisize);
  315.   fprintf(stderr, "  *** Please reissue the same command if you are under GP\n");
  316.   top=avma=bot+parisize;
  317.   declg=(long)top-(long)topold;declg2=declg>>2;
  318.   for(ll=(GEN)top,pp=(GEN)topold;pp>(GEN)avmaold;) *--ll= *--pp;
  319.   av=(long)ll;
  320.   while(ll<(GEN)top)
  321.   {
  322.     l2=ll+lontyp[tl=typ(ll)];
  323.     if(tl==10) {l3=ll+lgef(ll);ll+=lg(ll);if(l3>ll) l3=l2;}
  324.     else {ll+=lg(ll);l3=ll;} 
  325.     for(;l2<l3;l2++) 
  326.       {
  327.     l1=(GEN)(*l2);
  328.     if((l1<(GEN)topold)&&(l1>=(GEN)avmaold)) *l2+=declg;
  329.       }
  330.   }
  331.   gnil+=declg2;gzero+=declg2;gun+=declg2;gdeux+=declg2;ghalf+=declg2;
  332.   gi+=declg2;polx[255]+=declg2;polun[255]+=declg2;polvar+=declg2;
  333.   for(v=0;v<=tglobal;v++)
  334.     if((g[v]<(GEN)topold)&&(g[v]>=(GEN)avmaold)) g[v]+=declg2;
  335.   free((void *)botold);avloc=avma=av;
  336. }
  337.  
  338.