source: git/Singular/ipid.cc @ 38c769

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