source: git/Singular/ipid.cc @ eff324

spielwiese
Last change on this file since eff324 was 75f10d, checked in by Hans Schoenemann <hannes@…>, 12 years ago
add: bigintmat stuff from master
  • Property mode set to 100644
File size: 15.3 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/*
5* ABSTRACT: identfier handling
6*/
7
8#include <string.h>
9
10#include "config.h"
11#include <kernel/mod2.h>
12#include <Singular/static.h>
13#include <omalloc/omalloc.h>
14#include <Singular/tok.h>
15#include <misc/options.h>
16#include <Singular/ipshell.h>
17#include <misc/intvec.h>
18#include <kernel/febase.h>
19#include <coeffs/numbers.h>
20#include <coeffs/bigintmat.h>
21#include <kernel/longrat.h>
22#include <kernel/polys.h>
23#include <polys/monomials/ring.h>
24#include <kernel/ideals.h>
25#include <polys/matpol.h>
26#include <Singular/lists.h>
27#include <Singular/attrib.h>
28#include <Singular/silink.h>
29#include <kernel/syz.h>
30#include <Singular/ipid.h>
31#include <Singular/blackbox.h>
32
33#ifdef HAVE_DYNAMIC_LOADING
34#include <polys/mod_raw.h>
35#endif /* HAVE_DYNAMIC_LOADING */
36
37omBin sip_command_bin = omGetSpecBin(sizeof(sip_command));
38omBin sip_package_bin = omGetSpecBin(sizeof(sip_package));
39//omBin ip_package_bin = omGetSpecBin(sizeof(ip_package));
40omBin idrec_bin = omGetSpecBin(sizeof(idrec));
41
42coeffs coeffs_BIGINT;
43
44FILE   *feFilePending; /*temp. storage for grammar.y */
45
46proclevel *procstack=NULL;
47#define TEST
48//idhdl idroot = NULL;
49
50idhdl currPackHdl = NULL;
51idhdl basePackHdl = NULL;
52package currPack =NULL;
53package basePack =NULL;
54idhdl currRingHdl = NULL;
55const char* iiNoName="_";
56
57void paCleanUp(package pack);
58
59/*0 implementation*/
60
61int iiS2I(const char *s)
62{
63  int i;
64  i=s[0];
65  if (s[1]!='\0')
66  {
67    i=(i<<8)+s[1];
68    if (s[2]!='\0')
69    {
70      i=(i<<8)+s[2];
71      if (s[3]!='\0')
72      {
73        i=(i<<8)+s[3];
74      }
75    }
76  }
77  return i;
78}
79
80idhdl idrec::get(const char * s, int level)
81{
82  assume(s!=NULL);
83  assume((level>=0) && (level<=1000)); //not really, but if it isnt in that bounds..
84  idhdl h = this;
85  idhdl found=NULL;
86  int l;
87  const char *id_;
88  int i=iiS2I(s);
89  int less4=(i < (1<<24));
90  while (h!=NULL)
91  {
92    omCheckAddr((ADDRESS)IDID(h));
93    l=IDLEV(h);
94    if ((l==0)||(l==level))
95    {
96      if (i==h->id_i)
97      {
98        id_=IDID(h);
99        if (less4 || (0 == strcmp(s+4,id_+4)))
100        {
101          if (l==level) return h;
102          found=h;
103        }
104      }
105    }
106    h = IDNEXT(h);
107  }
108  return found;
109}
110
111//idrec::~idrec()
112//{
113//  if (id!=NULL)
114//  {
115//    omFree((ADDRESS)id);
116//    id=NULL;
117//  }
118//  /* much more !! */
119//}
120
121void *idrecDataInit(int t)
122{
123  switch (t)
124  {
125    //the type with init routines:
126    case INTVEC_CMD:
127    case INTMAT_CMD:
128      return (void *)new intvec();
129    case BIGINTMAT_CMD:
130      return (void *)new bigintmat();
131    case NUMBER_CMD:
132      return (void *) nInit(0);
133    case BIGINT_CMD:
134      return (void *) n_Init(0, coeffs_BIGINT);
135    case IDEAL_CMD:
136    case MODUL_CMD:
137    case MATRIX_CMD:
138      return (void*) idInit(1,1);
139    case MAP_CMD:
140    {
141      map m = (map)idInit(1,1);
142      m->preimage = omStrDup(IDID(currRingHdl));
143      return (void *)m;
144    }
145    case STRING_CMD:
146      return (void *)omAlloc0(1);
147    case LIST_CMD:
148    {
149      lists l=(lists)omAllocBin(slists_bin);
150      l->Init();
151      return (void*)l;
152    }
153    //the types with the standard init: set the struct to zero
154    case LINK_CMD:
155      return (void*) omAlloc0Bin(sip_link_bin);
156    case RING_CMD:
157      return (void*) omAlloc0Bin(sip_sring_bin);
158    case PACKAGE_CMD:
159      return (void*) omAlloc0Bin(sip_package_bin);
160    case PROC_CMD:
161      return (void *) omAlloc0Bin(procinfo_bin);
162    case RESOLUTION_CMD:
163      return  (void *)omAlloc0(sizeof(ssyStrategy));
164    //other types: without init (int,script,poly,def,package)
165    case INT_CMD:
166    case DEF_CMD:
167    case POLY_CMD:
168    case VECTOR_CMD:
169    case QRING_CMD:
170       return (void*)0L;
171    default:
172      {
173        if (t>MAX_TOK)
174        {
175#ifdef BLACKBOX_DEVEL
176          Print("bb-type %d\n",t);
177#endif
178          blackbox *bb=getBlackboxStuff(t);
179          if (bb!=NULL)
180             return (void *)bb->blackbox_Init(bb);
181        }
182        else
183          Werror("unknown type %d",t);
184        break;
185      }
186  }
187  return (void *)0L;
188}
189idhdl idrec::set(const char * s, int level, int t, BOOLEAN init)
190{
191  //printf("define %s, %x, level: %d, typ: %d\n", s,s,level,t);
192  idhdl h = (idrec *)omAlloc0Bin(idrec_bin);
193  IDID(h)   = s;
194  IDTYP(h)  = t;
195  IDLEV(h)  = level;
196  IDNEXT(h) = this;
197  h->id_i=iiS2I(s);
198  if (init)
199  {
200    if ((t==IDEAL_CMD)||(t==MODUL_CMD))
201      IDFLAG(h) = Sy_bit(FLAG_STD);
202    IDSTRING(h)=(char *)idrecDataInit(t);
203    // additional settings:--------------------------------------
204#if 0
205    // this leads to a memory leak
206    if (t == QRING_CMD)
207    {
208      // IDRING(h)=rCopy(currRing);
209      /* QRING_CMD is ring dep => currRing !=NULL */
210    }
211    else
212#endif
213    if (t == PROC_CMD)
214    {
215      IDPROC(h)->language=LANG_NONE;
216    }
217    else if (t == PACKAGE_CMD)
218    {
219      IDPACKAGE(h)->language=LANG_NONE;
220      IDPACKAGE(h)->loaded = FALSE;
221    }
222  }
223  // --------------------------------------------------------
224  return  h;
225}
226
227char * idrec::String(BOOLEAN typed)
228{
229  sleftv tmp;
230  memset(&tmp,0,sizeof(sleftv));
231  tmp.rtyp=IDTYP(this);
232  tmp.data=IDDATA(this);
233  tmp.name=IDID(this);
234  return tmp.String(NULL, typed);
235}
236
237idhdl enterid(const char * s, int lev, int t, idhdl* root, BOOLEAN init, BOOLEAN search)
238{
239  if (s==NULL) return NULL;
240  idhdl h;
241  s=omStrDup(s);
242  idhdl *save_root=root;
243  if (t==PACKAGE_CMD)
244  {
245    if (root!=&(basePack->idroot))
246    {
247      root=&(basePack->idroot);
248    }
249  }
250  // is it already defined in root ?
251  if ((h=(*root)->get(s,lev))!=NULL)
252  {
253    if (IDLEV(h)==lev)
254    {
255      if ((IDTYP(h) == t)||(t==DEF_CMD))
256      {
257        if ((IDTYP(h)==PACKAGE_CMD)
258        && (strcmp(s,"Top")==0))
259        {
260          goto errlabel;
261        }
262        if (BVERBOSE(V_REDEFINE))
263          Warn("redefining %s **",s);
264        if (s==IDID(h)) IDID(h)=NULL;
265        killhdl2(h,root,currRing);
266      }
267      else
268        goto errlabel;
269    }
270  }
271  // is it already defined in currRing->idroot ?
272  else if (search && (currRing!=NULL)&&((*root) != currRing->idroot))
273  {
274    if ((h=currRing->idroot->get(s,lev))!=NULL)
275    {
276      if (IDLEV(h)==lev)
277      {
278        if ((IDTYP(h) == t)||(t==DEF_CMD))
279        {
280          if (BVERBOSE(V_REDEFINE))
281            Warn("redefining %s **",s);
282          IDID(h)=NULL;
283          killhdl2(h,&currRing->idroot,currRing);
284        }
285        else
286          goto errlabel;
287      }
288    }
289  }
290  // is it already defined in idroot ?
291  else if (search && (*root != IDROOT))
292  {
293    if ((h=IDROOT->get(s,lev))!=NULL)
294    {
295      if (IDLEV(h)==lev)
296      {
297        if ((IDTYP(h) == t)||(t==DEF_CMD))
298        {
299          if (BVERBOSE(V_REDEFINE))
300            Warn("redefining `%s` **",s);
301          if (s==IDID(h)) IDID(h)=NULL;
302          killhdl2(h,&IDROOT,NULL);
303        }
304        else
305          goto errlabel;
306      }
307    }
308  }
309  *root = (*root)->set(s, lev, t, init);
310#ifndef NDEBUG
311  checkall();
312#endif
313  return *root;
314
315  errlabel:
316    //Werror("identifier `%s` in use(lev h=%d,typ=%d,t=%d, curr=%d)",s,IDLEV(h),IDTYP(h),t,lev);
317    Werror("identifier `%s` in use",s);
318    //listall();
319    omFree((ADDRESS)s);
320    return NULL;
321}
322void killid(const char * id, idhdl * ih)
323{
324  if (id!=NULL)
325  {
326    idhdl h = (*ih)->get(id,myynest);
327
328    // id not found in global list, is it defined in current ring ?
329    if (h==NULL)
330    {
331      if ((currRing!=NULL) && (*ih != (currRing->idroot)))
332      {
333        h = currRing->idroot->get(id,myynest);
334        if (h!=NULL)
335        {
336          killhdl2(h,&(currRing->idroot),currRing);
337          return;
338        }
339      }
340      Werror("`%s` is not defined",id);
341      return;
342    }
343    killhdl2(h,ih,currRing);
344  }
345  else
346    Werror("kill what ?");
347}
348
349void killhdl(idhdl h, package proot)
350{
351  int t=IDTYP(h);
352  if (((BEGIN_RING<t) && (t<END_RING) && (t!=QRING_CMD))
353  || ((t==LIST_CMD) && (lRingDependend((lists)IDDATA(h)))))
354    killhdl2(h,&currRing->idroot,currRing);
355  else
356  {
357    if(t==PACKAGE_CMD)
358    {
359      killhdl2(h,&(basePack->idroot),NULL);
360    }
361    else
362    {
363      idhdl s=proot->idroot;
364      while ((s!=h) && (s!=NULL)) s=s->next;
365      if (s!=NULL)
366        killhdl2(h,&(proot->idroot),NULL);
367      else if (basePack!=proot)
368      {
369        idhdl s=basePack->idroot;
370        while ((s!=h) && (s!=NULL)) s=s->next;
371        if (s!=NULL)
372          killhdl2(h,&(basePack->idroot),currRing);
373        else
374          killhdl2(h,&(currRing->idroot),currRing);
375       }
376    }
377  }
378}
379
380void killhdl2(idhdl h, idhdl * ih, ring r)
381{
382  //printf("kill %s, id %x, typ %d lev: %d\n",IDID(h),(int)IDID(h),IDTYP(h),IDLEV(h));
383  idhdl hh;
384
385  if (h->attribute!=NULL)
386  {
387    //h->attribute->killAll(r); MEMORY LEAK!
388    h->attribute=NULL;
389  }
390  if (IDTYP(h) == PACKAGE_CMD)
391  {
392    if (strcmp(IDID(h),"Top")==0)
393    {
394      WarnS("can not kill `Top`");
395      return;
396    }
397    // any objects defined for this package ?
398    if ((IDPACKAGE(h)->ref<=0)  &&  (IDPACKAGE(h)->idroot!=NULL))
399    {
400      if (currPack==IDPACKAGE(h))
401      {
402        currPack=basePack;
403        currPackHdl=NULL;
404      }
405      idhdl * hd = &IDRING(h)->idroot;
406      idhdl  hdh = IDNEXT(*hd);
407      idhdl  temp;
408      while (hdh!=NULL)
409      {
410        temp = IDNEXT(hdh);
411        killhdl2(hdh,&(IDPACKAGE(h)->idroot),NULL);
412        hdh = temp;
413      }
414      killhdl2(*hd,hd,NULL);
415      if (IDPACKAGE(h)->libname!=NULL) omFree((ADDRESS)(IDPACKAGE(h)->libname));
416    }
417    paKill(IDPACKAGE(h));
418    if (currPackHdl==h) currPackHdl=packFindHdl(currPack);
419    iiCheckPack(currPack);
420  }
421  else if ((IDTYP(h)==RING_CMD)||(IDTYP(h)==QRING_CMD))
422    rKill(h);
423  else
424    s_internalDelete(IDTYP(h),IDDATA(h),r);
425  //  general  -------------------------------------------------------------
426  // now dechain it and delete idrec
427  if (IDID(h)!=NULL) // OB: ?????
428    omFree((ADDRESS)IDID(h));
429  IDID(h)=NULL;
430  IDDATA(h)=NULL;
431  if (h == (*ih))
432  {
433    // h is at the beginning of the list
434    *ih = IDNEXT(h) /* ==*ih */;
435  }
436  else if (ih!=NULL)
437  {
438    // h is somethere in the list:
439    hh = *ih;
440    loop
441    {
442      if (hh==NULL)
443      {
444        PrintS(">>?<< not found for kill\n");
445        return;
446      }
447      idhdl hhh = IDNEXT(hh);
448      if (hhh == h)
449      {
450        IDNEXT(hh) = IDNEXT(hhh);
451        break;
452      }
453      hh = hhh;
454    }
455  }
456  omFreeBin((ADDRESS)h, idrec_bin);
457}
458
459idhdl ggetid(const char *n, BOOLEAN local, idhdl *packhdl)
460{
461  idhdl h = IDROOT->get(n,myynest);
462  idhdl h2=NULL;
463  *packhdl = NULL;
464  if ((currRing!=NULL) && ((h==NULL)||(IDLEV(h)!=myynest)))
465  {
466    h2 = currRing->idroot->get(n,myynest);
467  }
468  if (h2==NULL) return h;
469  return h2;
470}
471
472idhdl ggetid(const char *n)
473{
474  idhdl h = IDROOT->get(n,myynest);
475  if ((h!=NULL)&&(IDLEV(h)==myynest)) return h;
476  idhdl h2=NULL;
477  if (currRing!=NULL)
478  {
479    h2 = currRing->idroot->get(n,myynest);
480  }
481  if (h2!=NULL) return h2;
482  if (h!=NULL) return h;
483  if (basePack!=currPack)
484    return basePack->idroot->get(n,myynest);
485  return NULL;
486}
487
488void ipListFlag(idhdl h)
489{
490  if (hasFlag(h,FLAG_STD)) PrintS(" (SB)");
491#ifdef HAVE_PLURAL
492  if (hasFlag(h,FLAG_TWOSTD)) PrintS(" (2SB)");
493#endif
494}
495
496lists ipNameList(idhdl root)
497{
498  idhdl h=root;
499  /* compute the length */
500  int l=0;
501  while (h!=NULL) { l++; h=IDNEXT(h); }
502  /* allocate list */
503  lists L=(lists)omAllocBin(slists_bin);
504  L->Init(l);
505  /* copy names */
506  h=root;
507  l=0;
508  while (h!=NULL)
509  {
510    /* list is initialized with 0 => no need to clear anything */
511    L->m[l].rtyp=STRING_CMD;
512    L->m[l].data=omStrDup(IDID(h));
513    l++;
514    h=IDNEXT(h);
515  }
516  return L;
517}
518
519/*
520* move 'tomove' from root1 list to root2 list
521*/
522static int ipSwapId(idhdl tomove, idhdl &root1, idhdl &root2)
523{
524  idhdl h;
525  /* search 'tomove' in root2 : if found -> do nothing */
526  h=root2;
527  while ((h!=NULL) && (h!=tomove)) h=IDNEXT(h);
528  if (h!=NULL) return FALSE; /*okay */
529  /* search predecessor of h in root1, remove 'tomove' */
530  h=root1;
531  if (tomove==h)
532  {
533    root1=IDNEXT(h);
534  }
535  else
536  {
537    while ((h!=NULL) && (IDNEXT(h)!=tomove)) h=IDNEXT(h);
538    if (h==NULL) return TRUE; /* not in the list root1 -> do nothing */
539    IDNEXT(h)=IDNEXT(tomove);
540  }
541  /* add to root2 list */
542  IDNEXT(tomove)=root2;
543  root2=tomove;
544  return FALSE;
545}
546
547void  ipMoveId(idhdl tomove)
548{
549  if ((currRing!=NULL)&&(tomove!=NULL))
550  {
551    if (((QRING_CMD!=IDTYP(tomove)) && RingDependend(IDTYP(tomove)))
552    || ((IDTYP(tomove)==LIST_CMD) && (lRingDependend(IDLIST(tomove)))))
553    {
554      /*move 'tomove' to ring id's*/
555      if (ipSwapId(tomove,IDROOT,currRing->idroot))
556      ipSwapId(tomove,basePack->idroot,currRing->idroot);
557    }
558    else
559    {
560      /*move 'tomove' to global id's*/
561      ipSwapId(tomove,currRing->idroot,IDROOT);
562    }
563  }
564}
565
566const char * piProcinfo(procinfov pi, const char *request)
567{
568  if(pi == NULL) return "empty proc";
569  else if (strcmp(request, "libname")  == 0) return pi->libname;
570  else if (strcmp(request, "procname") == 0) return pi->procname;
571  else if (strcmp(request, "type")     == 0)
572  {
573    switch (pi->language)
574    {
575      case LANG_SINGULAR: return "singular"; break;
576      case LANG_C:        return "object";   break;
577      case LANG_NONE:     return "none";     break;
578      default:            return "unknow language";
579    }
580  }
581  else if (strcmp(request, "ref")      == 0)
582  {
583    char p[8];
584    sprintf(p, "%d", pi->ref);
585    return omStrDup(p);  // MEMORY-LEAK
586  }
587  return "??";
588}
589
590void piCleanUp(procinfov pi)
591{
592  (pi->ref)--;
593  if (pi->ref <= 0)
594  {
595    if (pi->libname != NULL) // OB: ????
596      omFree((ADDRESS)pi->libname);
597    if (pi->procname != NULL) // OB: ????
598      omFree((ADDRESS)pi->procname);
599
600    if( pi->language == LANG_SINGULAR)
601    {
602      if (pi->data.s.body != NULL) // OB: ????
603        omFree((ADDRESS)pi->data.s.body);
604    }
605    if( pi->language == LANG_C)
606    {
607    }
608    memset((void *) pi, 0, sizeof(procinfo));
609    pi->language=LANG_NONE;
610  }
611}
612
613BOOLEAN piKill(procinfov pi)
614{
615  Voice *p=currentVoice;
616  while (p!=NULL)
617  {
618    if (p->pi==pi && pi->ref <= 1)
619    {
620      Warn("`%s` in use, can not be killed",pi->procname);
621      return TRUE;
622    }
623    p=p->next;
624  }
625  piCleanUp(pi);
626  if (pi->ref <= 0)
627    omFreeBin((ADDRESS)pi,  procinfo_bin);
628  return FALSE;
629}
630
631void paCleanUp(package pack)
632{
633  (pack->ref)--;
634  if (pack->ref < 0)
635  {
636#ifndef HAVE_STATIC
637    if( pack->language == LANG_C)
638    {
639      Print("//dlclose(%s)\n",pack->libname);
640#ifdef HAVE_DYNAMIC_LOADING
641      dynl_close (pack->handle);
642#endif /* HAVE_DYNAMIC_LOADING */
643    }
644#endif /* HAVE_STATIC */
645    omfree((ADDRESS)pack->libname);
646    memset((void *) pack, 0, sizeof(sip_package));
647    pack->language=LANG_NONE;
648  }
649}
650
651void proclevel::push(char *n)
652{
653  //Print("push %s\n",n);
654  proclevel *p=(proclevel*)omAlloc0(sizeof(proclevel));
655  p->cRing=currRing;
656  p->cRingHdl=currRingHdl;
657  p->name=n;
658  p->cPackHdl=currPackHdl;
659  p->cPack=currPack;
660  p->next=this;
661  procstack=p;
662}
663void proclevel::pop()
664{
665  //Print("pop %s\n",name);
666  //if (currRing!=::currRing) PrintS("currRing wrong\n");;
667  //::currRing=this->currRing;
668  //if (r==NULL) Print("set ring to NULL at lev %d(%s)\n",myynest,name);
669  //::currRingHdl=this->currRingHdl;
670  //if((::currRingHdl==NULL)||(IDRING(::currRingHdl)!=(::currRing)))
671  //  ::currRingHdl=rFindHdl(::currRing,NULL,NULL);
672  //Print("restore pack=%s,1.obj=%s\n",IDID(currPackHdl),IDID(currPack->idroot));
673  currPackHdl=this->cPackHdl;
674  currPack=this->cPack;
675  iiCheckPack(currPack);
676  proclevel *p=this;
677  procstack=next;
678  omFreeSize(p,sizeof(proclevel));
679}
680
681idhdl packFindHdl(package r)
682{
683  idhdl h=basePack->idroot;
684  while (h!=NULL)
685  {
686    if ((IDTYP(h)==PACKAGE_CMD)
687        && (IDPACKAGE(h)==r))
688      return h;
689    h=IDNEXT(h);
690  }
691  return NULL;
692}
Note: See TracBrowser for help on using the repository browser.