source: git/Singular/ipid.cc @ fdc537

spielwiese
Last change on this file since fdc537 was 3838a9, checked in by Hans Schönemann <hannes@…>, 24 years ago
*hannes: work-arounds for names-spaces: dump procs in MP git-svn-id: file:///usr/local/Singular/svn/trunk@4374 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 22.2 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ipid.cc,v 1.40 2000-05-23 14:33:24 Singular Exp $ */
5
6/*
7* ABSTRACT: identfier handling
8*/
9
10#include <string.h>
11
12#include "mod2.h"
13#include "tok.h"
14#include "ipshell.h"
15#include "intvec.h"
16#include "febase.h"
17#include "mmemory.h"
18#include "numbers.h"
19#include "polys.h"
20#include "ring.h"
21#include "ideals.h"
22#include "matpol.h"
23#include "lists.h"
24#include "attrib.h"
25#include "silink.h"
26#include "syz.h"
27#include "ipid.h"
28
29namehdl namespaceroot = NULL;
30#define TEST
31#ifndef HAVE_NAMESPACES
32idhdl idroot = NULL;
33#endif /* HAVE_NAMESPACES */
34idhdl currRingHdl = NULL;
35ring  currRing = NULL;
36ideal currQuotient = NULL;
37char* iiNoName="_";
38
39void paCleanUp(package pack);
40#ifdef HAVE_NAMESPACES
41BOOLEAN paKill(package pack, BOOLEAN force_top=FALSE);
42#endif
43
44/*0 implementation*/
45
46idhdl idrec::get(const char * s, int lev)
47{
48  idhdl h = this;
49  idhdl found=NULL;
50  int l;
51  char *id;
52  while (h!=NULL)
53  {
54    mmTestLP(IDID(h));
55// =============================================================
56#if 0
57// timings: ratchwum: 515 s, wilde13: 373 s, nepomuck: 267 s, lukas 863 s
58    id=IDID(h);
59    l=IDLEV(h);
60    if ((l==0) && (*(short *)s==*(short *)id) && (0 == strcmp(s+1,id+1)))
61    {
62      found=h;
63    }
64    else if ((l==lev) && (*(short *)s==*(short *)id) && (0 == strcmp(s+1,id+1)))
65    {
66      return h;
67    }
68#endif
69// =============================================================
70#if 0
71// timings: ratchwum: 515 s, wilde13: 398 s, nepomuck: 269 s, lukas 834 s
72    id=IDID(h);
73    if (*(short *)s==*(short *)id)
74    {
75      l=IDLEV(h);
76      if ((l==0) && (0 == strcmp(s+1,id+1)))
77      {
78        found=h;
79      }
80      else if ((l==lev) && (0 == strcmp(s+1,id+1)))
81      {
82        return h;
83      }
84    }
85#endif
86// =============================================================
87#if 1
88// timings: ratchwum: 501 s, wilde13: 357 s, nepomuck: 267 s, lukas 816 s
89    l=IDLEV(h);
90    if ((l==0)||(l==lev))
91    {
92      id=IDID(h);
93      if (*(short *)s==*(short *)id)
94      {
95        if (0 == strcmp(s+1,id+1))
96        {
97          if (l==lev) return h;
98          found=h;
99        }
100      }
101    }
102#endif
103// =============================================================
104    h = IDNEXT(h);
105  }
106  return found;
107}
108
109//idrec::~idrec()
110//{
111//  if (id!=NULL)
112//  {
113//    FreeL((ADDRESS)id);
114//    id=NULL;
115//  }
116//  /* much more !! */
117//}
118
119idhdl idrec::set(char * s, int lev, idtyp t, BOOLEAN init)
120{
121  //printf("define %s, %x, lev: %d, typ: %d\n", s,s,lev,t);
122  idhdl h = (idrec *)Alloc0SizeOf(idrec);
123  int   len = 0;
124  IDID(h)   = s;
125  IDTYP(h)  = t;
126  IDLEV(h)  = lev;
127#ifdef HAVE_NAMESPACES
128  h->ref    = 0;
129#endif /* HAVE_NAMESPACES */
130  IDNEXT(h) = this;
131  if (init)
132  {
133    switch (t)
134    {
135    //the type with init routines:
136      case INTVEC_CMD:
137      case INTMAT_CMD:
138        IDINTVEC(h) = NewIntvec0();
139        break;
140      case NUMBER_CMD:
141        IDNUMBER(h) = nInit(0);
142        break;
143      case IDEAL_CMD:
144      case MODUL_CMD:
145        IDFLAG(h) = Sy_bit(FLAG_STD);
146      case MATRIX_CMD:
147        IDIDEAL(h) = idInit(1,1);
148        break;
149      case MAP_CMD:
150        IDIDEAL(h) = idInit(1,1);
151        IDMAP(h)->preimage = mstrdup(IDID(currRingHdl));
152        break;
153      case STRING_CMD:
154        IDSTRING(h) = mstrdup("");
155        break;
156      case LIST_CMD:
157        IDLIST(h)=(lists)AllocSizeOf(slists);
158        IDLIST(h)->Init();
159        break;
160    //the types with the standard init: set the struct to zero
161      case LINK_CMD:
162        len=sizeof(ip_link);
163        break;
164      case RING_CMD:
165      case QRING_CMD:
166        len = sizeof(ip_sring);
167        break;
168      case PACKAGE_CMD:
169        len = sizeof(ip_package);
170        break;
171      case RESOLUTION_CMD:
172        len=sizeof(ssyStrategy);
173        break;
174      case PROC_CMD:
175        len=sizeof(procinfo);
176        break;
177    //other types: without init (int,script,poly,def,package)
178    }
179    if (len!=0)
180    {
181      IDSTRING(h) = (char *)Alloc0(len);
182    }
183    // additional settings:--------------------------------------
184    if (t == QRING_CMD)
185    {
186      IDRING(h)=rCopy(currRing);
187      /* QRING_CMD is ring dep => currRing !=NULL */
188    }
189    else if (t == PROC_CMD)
190    {
191      IDPROC(h)->language=LANG_NONE;
192    }
193    else if (t == PACKAGE_CMD)
194    {
195      IDPACKAGE(h)->language=LANG_NONE;
196      IDPACKAGE(h)->loaded = FALSE;
197    }
198
199  }
200  // --------------------------------------------------------
201  return  h;
202}
203
204char * idrec::String()
205{
206  sleftv tmp;
207  memset(&tmp,0,sizeof(sleftv));
208  tmp.rtyp=IDTYP(this);
209  tmp.data=IDDATA(this);
210  tmp.name=IDID(this);
211  return tmp.String();
212}
213
214//#define KAI
215idhdl enterid(char * s, int lev, idtyp t, idhdl* root, BOOLEAN init)
216{
217  idhdl h;
218  // is it the currRing - id ?
219#ifdef HAVE_NAMESPACES
220  namehdl topnsroot = namespaceroot->root;
221#endif
222  if ((currRingHdl!=NULL)
223  &&(IDLEV(currRingHdl)!=lev)
224  &&(s==IDID(currRingHdl)))
225  {
226    s=mstrdup(s);
227  }
228  // is it already defined in root ?
229  else if ((h=(*root)->get(s,lev))!=NULL)
230  {
231    if (IDLEV(h)!=lev)
232    {
233      s=mstrdup(s);
234    }
235    else if ((IDTYP(h) == t)||(t==DEF_CMD))
236    {
237      if (BVERBOSE(V_REDEFINE))
238#ifdef KAI
239        Warn("1 redefining %s **",s);
240#else
241        Warn("redefining %s **",s);
242#endif
243#ifdef HAVE_NAMESPACES
244        if(t==PACKAGE_CMD && strcmp(s,"Top")==0) {
245          Warn("identifier `%s` in use",s);
246          return(h);
247        }
248#endif /* HAVE_NAMESPACES */
249        if (s==IDID(h))
250        IDID(h)=NULL;
251      killhdl(h,root);
252    }
253    else
254      goto errlabel;
255  }
256  // is it already defined in idroot ?
257  else if (*root != IDROOT)
258  {
259    if ((h=IDROOT->get(s,lev))!=NULL)
260    {
261      if (IDLEV(h)!=lev)
262      {
263        s=mstrdup(s);
264      }
265      else if ((IDTYP(h) == t)||(t==DEF_CMD))
266      {
267        if (BVERBOSE(V_REDEFINE))
268#ifdef KAI
269          Warn("2 redefining %s **",s);
270#else
271          Warn("redefining %s **",s);
272#endif
273        IDID(h)=NULL;
274        killhdl(h,&IDROOT);
275      }
276      else
277      {
278        goto errlabel;
279      }
280    }
281  }
282#ifdef HAVE_NAMESPACES
283  // is it already defined in toplevel idroot ?
284  else if (*root != NSROOT(topnsroot))
285  {
286    if ((h=topnsroot->get(s,lev))!=NULL)
287    {
288        s=mstrdup(s);
289    }
290  }
291#endif /* HAVE_NAMESPACES */
292  // is it already defined in currRing->idroot ?
293  else if ((currRing!=NULL)&&((*root) != currRing->idroot))
294  {
295    if ((h=currRing->idroot->get(s,lev))!=NULL)
296    {
297      if (IDLEV(h)!=lev)
298      {
299        s=mstrdup(s);
300      }
301      else if ((IDTYP(h) == t)||(t==DEF_CMD))
302      {
303        if (BVERBOSE(V_REDEFINE))
304#ifdef KAI
305          Warn("3 redefining %s **",s);
306#else
307          Warn("redefining %s **",s);
308#endif
309        IDID(h)=NULL;
310        killhdl(h,&currRing->idroot);
311      }
312      else
313      {
314        goto errlabel;
315      }
316    }
317  }
318  return *root = (*root)->set(s, lev, t, init);
319
320  errlabel:
321    Werror("identifier `%s` in use",s);
322    return NULL;
323}
324
325void killid(char * id, idhdl * ih)
326{
327  if (id!=NULL)
328  {
329    idhdl h = (*ih)->get(id,myynest);
330
331    // id not found in global list, is it defined in current ring ?
332    if (h==NULL)
333    {
334      if ((currRing!=NULL) && (*ih != (currRing->idroot)))
335      {
336        h = currRing->idroot->get(id,myynest);
337        if (h!=NULL)
338        {
339          killhdl(h,&(currRing->idroot));
340          return;
341        }
342      }
343      Werror("`%s` is not defined",id);
344      return;
345    }
346    killhdl(h,ih);
347  }
348  else
349    Werror("kill what ?");
350}
351
352void killhdl(idhdl h)
353{
354  int t=IDTYP(h);
355  if ((BEGIN_RING<t) && (t<END_RING) && (t!=QRING_CMD))
356    killhdl(h,&currRing->idroot);
357  else
358  {
359#ifdef HAVE_NAMESPACES
360    if(t==PACKAGE_CMD) {
361      killhdl(h,&NSROOT(namespaceroot->root));
362    } else
363#endif /* HAVE_NAMESPACES */
364    {
365      idhdl s=IDROOT;
366      while ((s!=h) && (s!=NULL)) s=s->next;
367      if (s==NULL) killhdl(h,&currRing->idroot);
368      else killhdl(h,&IDROOT);
369    }
370  }
371}
372
373void killhdl(idhdl h, idhdl * ih)
374{
375  //printf("kill %s, id %x, typ %d lev: %d\n",IDID(h),(int)IDID(h),IDTYP(h),IDLEV(h));
376  idhdl hh;
377  BOOLEAN killOtherRing = TRUE;
378  BOOLEAN needResetRing = FALSE;
379
380  if (h->attribute!=NULL)
381  {
382    atKillAll(h);
383    //h->attribute=NULL;
384  }
385  // ring / qring  --------------------------------------------------------
386  if ((IDTYP(h) == RING_CMD) || (IDTYP(h) == QRING_CMD))
387  {
388    idhdl savecurrRingHdl = currRingHdl;
389    ring  savecurrRing = currRing;
390    // any objects defined for this ring ?
391    if (((IDTYP(h)==RING_CMD) && (IDRING(h)->ref<=0))
392    &&  (IDRING(h)->idroot!=NULL))
393    {
394      idhdl * hd = &IDRING(h)->idroot;
395      idhdl  hdh = IDNEXT(*hd);
396      idhdl  temp;
397      killOtherRing=(IDRING(h)!=currRing);
398      if (killOtherRing) //we are not killing the base ring, so switch
399      {
400        needResetRing=TRUE;
401        rSetHdl(h,FALSE);
402        /* no complete init*/
403      }
404      while (hdh!=NULL)
405      {
406        temp = IDNEXT(hdh);
407        killhdl(hdh,&(IDRING(h)->idroot));
408        hdh = temp;
409      }
410      killhdl(*hd,hd);
411    }
412    // reset currRing ?
413    if (needResetRing) // && (killOtherRing)
414    {
415      //we have to switch back to the base ring
416      //currRing = savecurrRing;
417      //currRingHdl = savecurrRingHdl;
418      if (savecurrRingHdl!=NULL)
419      {
420        rSetHdl(savecurrRingHdl,TRUE);
421      }
422      else if (savecurrRing!=NULL)
423      {
424        rChangeCurrRing(savecurrRing,TRUE);
425      }
426    }
427    rKill(h);
428  }
429#ifdef HAVE_NAMESPACES
430  // package -------------------------------------------------------------
431  else if (IDTYP(h) == PACKAGE_CMD)
432  {
433    if(IDPACKAGE(h)->language!=LANG_TOP)
434    {
435      if(!paKill(IDPACKAGE(h))) return;
436    }
437    else
438    {
439      if(strcmp(IDID(h), "Top")!=0)
440      {
441        if(!paKill(IDPACKAGE(h))) return;
442      }
443      else
444      {
445        if(!paKill(IDPACKAGE(h), TRUE)) return;
446      }
447    }
448  }
449  // pointer -------------------------------------------------------------
450  else if(IDTYP(h)==POINTER_CMD)
451  {
452    PrintS(">>>>>>Free pointer\n");
453  }
454#endif /* HAVE_NAMESPACES */
455  // poly / vector -------------------------------------------------------
456  else if ((IDTYP(h) == POLY_CMD) || (IDTYP(h) == VECTOR_CMD))
457  {
458    pDelete(&IDPOLY(h));
459  }
460  // ideal / module/ matrix / map ----------------------------------------
461  else if ((IDTYP(h) == IDEAL_CMD)
462           || (IDTYP(h) == MODUL_CMD)
463           || (IDTYP(h) == MATRIX_CMD)
464           || (IDTYP(h) == MAP_CMD))
465  {
466    ideal iid = IDIDEAL(h);
467    if (IDTYP(h) == MAP_CMD)
468    {
469      map im = IDMAP(h);
470      FreeL((ADDRESS)im->preimage);
471    }
472    idDelete(&iid);
473  }
474  // string -------------------------------------------------------------
475  else if (IDTYP(h) == STRING_CMD)
476  {
477    FreeL((ADDRESS)IDSTRING(h));
478    //IDSTRING(h)=NULL;
479  }
480  // proc ---------------------------------------------------------------
481  else if (IDTYP(h) == PROC_CMD)
482  {
483    if (piKill(IDPROC(h))) return;
484  }
485  // number -------------------------------------------------------------
486  else if (IDTYP(h) == NUMBER_CMD)
487  {
488    nDelete(&IDNUMBER(h));
489  }
490  // intvec / intmat  ---------------------------------------------------
491  else if ((IDTYP(h) == INTVEC_CMD)||(IDTYP(h) == INTMAT_CMD))
492  {
493    delete IDINTVEC(h);
494  }
495  // list  -------------------------------------------------------------
496  else if (IDTYP(h)==LIST_CMD)
497  {
498    IDLIST(h)->Clean();
499    //Free((ADDRESS)IDLIST(h)->m, (IDLIST(h)->nr+1)*sizeof(sleftv));
500    //FreeSizeOf((ADDRESS)IDLIST(h), slists);
501  }
502  // link  -------------------------------------------------------------
503  else if (IDTYP(h)==LINK_CMD)
504  {
505    slKill(IDLINK(h));
506  }
507  else if((IDTYP(h)==RESOLUTION_CMD)&&(IDDATA(h)!=NULL))
508  {
509    syKillComputation((syStrategy)IDDATA(h));
510  }
511#ifdef TEST
512  else if ((IDTYP(h)!= INT_CMD)&&(IDTYP(h)!=DEF_CMD) && (IDTYP(h)!=NONE))
513    Warn("unknown type to kill: %s(%d)",Tok2Cmdname(IDTYP(h)),IDTYP(h));
514#endif
515
516  //  general  -------------------------------------------------------------
517  // now dechain it and delete idrec
518#ifdef KAI_
519  if(h->next != NULL)
520    Print("=======>%s(%x) -> %s<====\n", IDID(h), IDID(h), IDID(h->next));
521  else
522    Print("=======>%s(%x)<====\n", IDID(h), IDID(h));
523#endif
524
525  FreeL((ADDRESS)IDID(h));
526  //IDID(h)=NULL;
527  if (h == (*ih))
528  {
529    // h is at the beginning of the list
530    *ih = IDNEXT(*ih);
531  }
532  else
533  {
534    // h is somethere in the list:
535    hh = *ih;
536    loop
537    {
538      idhdl hhh = IDNEXT(hh);
539      if (hhh == h)
540      {
541        IDNEXT(hh) = IDNEXT(hhh);
542        break;
543      }
544      hh = hhh;
545    }
546  }
547  FreeSizeOf((ADDRESS)h,idrec);
548}
549
550idhdl ggetid(const char *n, BOOLEAN local, idhdl *packhdl)
551{
552#ifdef HAVE_NAMESPACES
553  idhdl h =namespaceroot->get(n,myynest, TRUE); // search in toplevel namespace
554  idhdl h2=namespaceroot->get(n,myynest); // search in current namespace
555  idhdl h3=NULL;
556  if ((currRing!=NULL) && ((h2==NULL)||(IDLEV(h2)!=myynest)))
557  {
558    h3 = currRing->idroot->get(n,myynest);
559  }
560  if (h3==NULL) {
561    if (h2!=NULL) {
562      *packhdl=namespaceroot->get(namespaceroot->name,0, TRUE);
563      return h2;
564    }
565    if(!local) {
566      if(h!=NULL)*packhdl=namespaceroot->get("Top",0, TRUE);
567      return h;
568    }
569  }
570  if(h3!=NULL) *packhdl = currRingHdl;
571  else *packhdl = NULL;
572  return h3;
573#else /* HAVE_NAMESPACES */
574  idhdl h = idroot->get(n,myynest);
575  idhdl h2=NULL;
576  *packhdl = NULL;
577  if ((currRing!=NULL) && ((h==NULL)||(IDLEV(h)!=myynest)))
578  {
579    h2 = currRing->idroot->get(n,myynest);
580  }
581  if (h2==NULL) return h;
582  return h2;
583#endif /* HAVE_NAMESPACES */
584}
585
586idhdl ggetid(const char *n, BOOLEAN local)
587{
588#ifdef HAVE_NAMESPACES
589  idhdl h =namespaceroot->get(n,myynest, TRUE); // search in toplevel namespace
590  idhdl h2=namespaceroot->get(n,myynest); // search in current namespace
591  idhdl h3=NULL;
592  if ((currRing!=NULL) && ((h2==NULL)||(IDLEV(h2)!=myynest)))
593  {
594    h3 = currRing->idroot->get(n,myynest);
595  }
596  if (h3==NULL) {
597    if (h2!=NULL) return h2;
598    if(!local) return h;
599  }
600  return h3;
601#else /* HAVE_NAMESPACES */
602  idhdl h = idroot->get(n,myynest);
603  idhdl h2=NULL;
604  if ((currRing!=NULL) && ((h==NULL)||(IDLEV(h)!=myynest)))
605  {
606    h2 = currRing->idroot->get(n,myynest);
607  }
608  if (h2==NULL) return h;
609  return h2;
610#endif /* HAVE_NAMESPACES */
611}
612
613void ipListFlag(idhdl h)
614{
615  if (hasFlag(h,FLAG_STD)) PrintS(" (SB)");
616  if (hasFlag(h,FLAG_DRING)) PrintS(" (D)");
617}
618
619lists ipNameList(idhdl root)
620{
621  idhdl h=root;
622  /* compute the length */
623  int l=0;
624  while (h!=NULL) { l++; h=IDNEXT(h); }
625  /* allocate list */
626  lists L=(lists)AllocSizeOf(slists);
627  L->Init(l);
628  /* copy names */
629  h=root;
630  l=0;
631  while (h!=NULL)
632  {
633    /* list is initialized with 0 => no need to clear anything */
634    L->m[l].rtyp=STRING_CMD;
635    L->m[l].data=mstrdup(IDID(h));
636    l++;
637    h=IDNEXT(h);
638  }
639  return L;
640}
641
642/*
643* move 'tomove' from root1 list to root2 list
644*/
645static void ipSwapId(idhdl tomove, idhdl &root1, idhdl &root2)
646{
647  idhdl h;
648  /* search 'tomove' in root2 : if found -> do nothing */
649  h=root2;
650  while ((h!=NULL) && (h!=tomove)) h=IDNEXT(h);
651  if (h!=NULL) return;
652  /* search predecessor of h in root1, remove 'tomove' */
653  h=root1;
654  if (tomove==h)
655  {
656    root1=IDNEXT(h);
657  }
658  else
659  {
660    while ((h!=NULL) && (IDNEXT(h)!=tomove)) h=IDNEXT(h);
661    if (h==NULL) return; /* not in the list root1 -> do nothing */
662    IDNEXT(h)=IDNEXT(tomove);
663  }
664  /* add to root2 list */
665  IDNEXT(tomove)=root2;
666  root2=tomove;
667}
668
669void  ipMoveId(idhdl tomove)
670{
671  if ((currRing!=NULL)&&(tomove!=NULL))
672  {
673    if (((QRING_CMD!=IDTYP(tomove)) && (BEGIN_RING<IDTYP(tomove)) && (IDTYP(tomove)<END_RING))
674    || ((IDTYP(tomove)==LIST_CMD) && (lRingDependend(IDLIST(tomove)))))
675    {
676      /*move 'tomove' to ring id's*/
677      ipSwapId(tomove,IDROOT,currRing->idroot);
678    }
679    else
680    {
681      /*move 'tomove' to global id's*/
682      ipSwapId(tomove,currRing->idroot,IDROOT);
683    }
684  }
685}
686
687char * piProcinfo(procinfov pi, char *request)
688{
689  if(pi == NULL) return "empty proc";
690  else if (strcmp(request, "libname")  == 0) return pi->libname;
691  else if (strcmp(request, "procname") == 0) return pi->procname;
692  else if (strcmp(request, "type")     == 0) {
693    switch (pi->language) {
694      case LANG_SINGULAR: return "singular"; break;
695      case LANG_C:        return "object";   break;
696      case LANG_NONE:     return "none";     break;
697      default:            return "unknow language";
698    }
699  } else if (strcmp(request, "ref")      == 0) {
700    char p[8];
701    sprintf(p, "%d", pi->ref);
702    return mstrdup(p);  // MEMORY-LEAK
703  }
704  return "??";
705}
706
707void piCleanUp(procinfov pi)
708{
709  (pi->ref)--;
710  if (pi->ref <= 0)
711  {
712    FreeL((ADDRESS)pi->libname);
713    FreeL((ADDRESS)pi->procname);
714    if( pi->language == LANG_SINGULAR)
715    {
716      FreeL((ADDRESS)pi->data.s.body);
717    }
718    if( pi->language == LANG_C)
719    {
720    }
721    memset((void *) pi, 0, sizeof(procinfo));
722    pi->language=LANG_NONE;
723  }
724}
725
726BOOLEAN piKill(procinfov pi)
727{
728  Voice *p=currentVoice;
729  while (p!=NULL)
730  {
731    if (p->pi==pi && pi->ref <= 1)
732    {
733      Warn("`%s` in use, can not be killed",pi->procname);
734      return TRUE;
735    }
736    p=p->next;
737  }
738  piCleanUp(pi);
739  if (pi->ref <= 0)
740    FreeSizeOf((ADDRESS)pi, procinfo);
741  return FALSE;
742}
743
744void paCleanUp(package pack)
745{
746  (pack->ref)--;
747  if (pack->ref < 0)
748  {
749    if( pack->language == LANG_C)
750    {
751      Print("//dlclose(%s)\n",pack->libname);
752#ifdef HAVE_DYNAMIC_LOADING
753      extern int dynl_close (void *handle);
754      dynl_close (pack->handle);
755#endif /* HAVE_DYNAMIC_LOADING */
756    }
757    FreeL((ADDRESS)pack->libname);
758    memset((void *) pack, 0, sizeof(sip_package));
759    pack->language=LANG_NONE;
760  }
761}
762
763#ifdef HAVE_NAMESPACES
764BOOLEAN paKill(package pack, BOOLEAN force_top)
765{
766  if (pack->ref <= 0 || force_top) {
767    idhdl hdh = pack->idroot;
768    idhdl temp;
769    while (hdh!=NULL)
770    {
771      temp = IDNEXT(hdh);
772      if((IDTYP(hdh)!=PACKAGE_CMD) ||
773         (IDTYP(hdh)==PACKAGE_CMD && IDPACKAGE(hdh)->language!=LANG_TOP) ||
774         (IDTYP(hdh)==PACKAGE_CMD && IDPACKAGE(hdh)->language==LANG_TOP &&
775         IDPACKAGE(hdh)->ref>0 ))
776        killhdl(hdh,&(pack->idroot));
777      hdh = temp;
778    }
779    if(checkPackage(pack)) {
780      paCleanUp(pack);
781      FreeSizeOf((ADDRESS)pack, sip_package);
782    } else return FALSE;
783  } else paCleanUp(pack);
784  return TRUE;
785}
786#endif /* HAVE_NAMESPACES */
787
788char *idhdl2id(idhdl pck, idhdl h)
789{
790  char *name = (char *)AllocL(strlen(pck->id) + strlen(h->id) + 3);
791  sprintf(name, "%s::%s", pck->id, h->id);
792  return(name);
793}
794
795void iiname2hdl(const char *name, idhdl *pck, idhdl *h)
796{
797  const char *q = strchr(name, ':');
798  char *p, *i;
799
800  if(q==NULL)
801  {
802    p = mstrdup("");
803    i = (char *)AllocL(strlen(name)+1);
804    *i = '\0';
805    sscanf(name, "%s", i);
806#ifdef HAVE_NAMESPACES
807    *h = namespaceroot->get(i, myynest);
808    if(*h == NULL) { *h = namespaceroot->get(i, myynest, TRUE); }
809#else /* HAVE_NAMESPACES */
810#endif /* HAVE_NAMESPACES */
811  }
812  else {
813    if( *(q+1) != ':') return;
814    i = (char *)AllocL(strlen(name)+1);
815    *i = '\0';
816    if(name == q)
817    {
818      p = mstrdup("");
819      sscanf(name, "::%s", i);
820#ifdef HAVE_NAMESPACES
821      *h =namespaceroot->get(i, myynest, TRUE); // search in toplevel namespace
822#else /* HAVE_NAMESPACES */
823#endif /* HAVE_NAMESPACES */
824    }
825    else
826    {
827      p = (char *)AllocL(strlen(name)+1);
828      sscanf(name, "%[^:]::%s", p, i);
829#ifdef HAVE_NAMESPACES
830      *pck =namespaceroot->get(p, myynest, TRUE); // search in toplevel namespace
831      namespaceroot->push(IDPACKAGE(*pck), IDID(*pck));
832      *h =namespaceroot->get(i, myynest); // search in toplevel namespace
833      namespaceroot->pop();
834#else /* HAVE_NAMESPACES */
835#endif /* HAVE_NAMESPACES */
836    }
837  }
838  //printf("Package: '%s'\n", p);
839  //printf("Id Rec : '%s'\n", i);
840  FreeL(p);
841  FreeL(i);
842}
843
844#if 0
845char *getnamelev()
846{
847  char buf[256];
848  sprintf(buf, "(%s:%d)", namespaceroot->name,namespaceroot->lev);
849  return(buf);
850}
851// warning: address of local variable `buf' returned
852#endif
853
854namehdl namerec::push(package pack, char *name, int nesting, BOOLEAN init)
855{
856  //printf("PUSH: put entry (%s) on stack\n", name);
857  namehdl ns = (namerec *)Alloc0SizeOf(namerec);
858  extern int myynest;
859  if(nesting<0) nesting = myynest;
860  ns->next   = this;
861  if(this==NULL && !init)
862  {
863    printf("PUSH: this is NULL and init not set.\n");
864    init=TRUE;
865  }
866  if(init)
867  {
868    ns->next    = NULL;
869#ifdef HAVE_NAMESPACES
870    ns->pack    = (ip_package *)Alloc0SizeOf(ip_package);
871#endif /* HAVE_NAMESPACES */
872    ns->isroot  = TRUE;
873    ns->lev     = 1;
874    //ns->myynest = 0;
875  }
876  else
877  {
878    extern ring currRing;
879#ifdef HAVE_NAMESPACES
880    ns->pack   = pack;
881#endif /* HAVE_NAMESPACES */
882    ns->lev    = this->lev+1;
883    //ns->myynest = myynest+1;
884    this->currRing = currRing;
885    //printf("Saving Ring %x, %x\n", this->currRing, currRing);
886  }
887  ns->name    = mstrdup(name);
888  ns->myynest = nesting;
889
890  //ns->currRing = currRing;
891  //ns->currRingHdl = currRingHdl;
892  if(ns->isroot) ns->root=ns; else ns->root = this->root;
893  namespaceroot = ns;
894#if 0
895  if(init && ns->isroot) {
896    idhdl pl = enterid( mstrdup("Top"),0, PACKAGE_CMD,
897                      &NSROOT(namespaceroot), TRUE );
898    if(pl != NULL) {
899      FreeSizeOf((ADDRESS)IDPACKAGE(pl), ip_package);
900      IDPACKAGE(pl) = ns->pack;
901    }
902  }
903#endif
904  //Print("NSPUSH: done\n");
905  return(namespaceroot);
906}
907
908namehdl namerec::pop(BOOLEAN change_nesting)
909{
910  namehdl ns;
911  //printf("POP: remove entry (%s)\n", this->name);
912  if(this==NULL) return NULL;
913  if(isroot) {
914    //printf("POP: base. woul'd do it.\n");
915    return this;
916  }
917  if(!change_nesting && this->myynest!=this->next->myynest) {
918    return(this);
919  }
920  ns = this;
921  namespaceroot = this->next;
922  FreeL((ADDRESS)ns->name);
923  FreeSizeOf((ADDRESS)ns, namerec);
924  return(namespaceroot);
925}
926
927#ifdef HAVE_NAMESPACES
928idhdl namerec::get(const char * s, int lev, BOOLEAN root)
929{
930  namehdl ns;
931  if(root) {
932    ns = this->root;
933  } else {
934    ns = this;
935  }
936  //printf("//====== namerec::get(%s, %d) from '%s'\n", s, lev, ns->name);
937  if(ns==NULL) {
938    //printf("//======== namerec::get() from null\n");
939    return NULL;
940  }
941  return( NSROOT(ns)->get(s, lev));
942}
943
944BOOLEAN checkPackage(package pack)
945{
946  namehdl nshdl = namespaceroot;
947
948  for(nshdl=namespaceroot; nshdl->isroot != TRUE; nshdl = nshdl->next) {
949    //Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
950    if (nshdl->pack==pack)
951    {
952      Warn("package '%s' still in use on level %d",nshdl->name, nshdl->lev);
953      return FALSE;
954    }
955  }
956  if (nshdl->pack==pack)
957  {
958    //Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
959    Warn("package '%s' still in use on level %d",nshdl->name, nshdl->lev);
960    return FALSE;
961  }
962  return TRUE;
963
964}
965#endif /* HAVE_NAMESPACES */
Note: See TracBrowser for help on using the repository browser.