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