source: git/Singular/ipid.cc @ c4bbf1f

spielwiese
Last change on this file since c4bbf1f was 66e574, checked in by Hans Schönemann <hannes@…>, 26 years ago
* hannes: cleanup ipid.cc git-svn-id: file:///usr/local/Singular/svn/trunk@1350 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 11.8 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: ipid.cc,v 1.11 1998-04-07 17:52:45 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
29idhdl idroot = NULL;
30idhdl currRingHdl = NULL;
31ring  currRing = NULL;
32ideal currQuotient = NULL;
33char* iiNoName="_";
34
35/*0 implementation*/
36
37idhdl idrec::get(const char * s, int lev)
38{
39  idhdl h = this;
40  idhdl found=NULL;
41  int l;
42  while (h!=NULL)
43  {
44    l=IDLEV(h);
45    mmTestLP(IDID(h));
46    if ((l==lev) && (0 == strcmp(s,IDID(h)))) return h;
47    if ((l==0) && (found==NULL) && (0 == strcmp(s,IDID(h))))
48    {
49      found=h;
50    }
51    h = IDNEXT(h);
52  }
53  return found;
54}
55
56//idrec::~idrec()
57//{
58//  if (id!=NULL)
59//  {
60//    FreeL((ADDRESS)id);
61//    id=NULL;
62//  }
63//  /* much more !! */
64//}
65
66idhdl idrec::set(char * s, int lev, idtyp t, BOOLEAN init)
67{
68  //printf("define %s, %x, lev: %d, typ: %d\n", s,s,lev,t);
69  idhdl h = (idrec *)Alloc0(sizeof(idrec));
70  int   len = 0;
71  IDID(h)   = s;
72  IDTYP(h)  = t;
73  IDLEV(h)  = lev;
74  IDNEXT(h) = this;
75  if (init)
76  {
77    switch (t)
78    {
79    //the type with init routines:
80      case INTVEC_CMD:
81      case INTMAT_CMD:
82        IDINTVEC(h) = new intvec();
83        break;
84      case NUMBER_CMD:
85        IDNUMBER(h) = nInit(0);
86        break;
87      case IDEAL_CMD:
88      case MODUL_CMD:
89        IDFLAG(h) = Sy_bit(FLAG_STD);
90      case MATRIX_CMD:
91        IDIDEAL(h) = idInit(1,1);
92        break;
93      case MAP_CMD:
94        IDIDEAL(h) = idInit(1,1);
95        IDMAP(h)->preimage = mstrdup(IDID(currRingHdl));
96        break;
97      case STRING_CMD:
98        IDSTRING(h) = mstrdup("");
99        break;
100      case LIST_CMD:
101        IDLIST(h)=(lists)Alloc(sizeof(slists));
102        IDLIST(h)->Init();
103        break;
104    //the types with the standard init: set the struct to zero
105      case LINK_CMD:
106        len=sizeof(ip_link);
107        break;
108      case RING_CMD:
109      case QRING_CMD:
110        len = sizeof(ip_sring);
111        break;
112      case PACKAGE_CMD:
113        len = sizeof(ip_package);
114        break;
115      case RESOLUTION_CMD:
116        len=sizeof(ssyStrategy);
117        break;   
118    //other types: without init (int,script,poly,def,package)
119    }
120    if (len!=0)
121    {
122      IDSTRING(h) = (char *)Alloc0(len);
123    }
124  }
125  if(t == PROC_CMD)
126  {
127    IDPROC(h) = (procinfo *)Alloc(sizeof(procinfo));
128    memset(IDPROC(h),0,sizeof(*IDPROC(h)));
129    IDPROC(h)->language=LANG_NONE;
130  }
131  return  h;
132}
133
134idhdl enterid(char * s, int lev, idtyp t, idhdl* root, BOOLEAN init)
135{
136  idhdl h;
137  // is it the currRing - id ?
138  if ((currRingHdl!=NULL)
139  &&(IDLEV(currRingHdl)!=lev)
140  &&(s==IDID(currRingHdl)))
141  {
142    s=mstrdup(s);
143  }
144  // is it already defined in root ?
145  else if ((h=(*root)->get(s,lev))!=NULL)
146  {
147    if (IDLEV(h)!=lev)
148    {
149      s=mstrdup(s);
150    }
151    else if ((IDTYP(h) == t)||(t==DEF_CMD))
152    {
153      if (BVERBOSE(V_REDEFINE))
154        Warn("redefining %s **",s);
155      if (s==IDID(h))
156        IDID(h)=NULL;
157      killhdl(h,root);
158    }
159    else
160      goto errlabel;
161  }
162  // is it already defined in idroot ?
163  else if (*root != idroot)
164  {
165    if ((h=idroot->get(s,lev))!=NULL)
166    {
167      if (IDLEV(h)!=lev)
168      {
169        s=mstrdup(s);
170      }
171      else if ((IDTYP(h) == t)||(t==DEF_CMD))
172      {
173        if (BVERBOSE(V_REDEFINE))
174          Warn("redefining %s **",s);
175        IDID(h)=NULL;
176        killhdl(h,&idroot);
177      }
178      else
179      {
180        goto errlabel;
181      }
182    }
183  }
184  // is it already defined in currRing->idroot ?
185  else if ((currRing!=NULL)&&((*root) != currRing->idroot))
186  {
187    if ((h=currRing->idroot->get(s,lev))!=NULL)
188    {
189      if (IDLEV(h)!=lev)
190      {
191        s=mstrdup(s);
192      }
193      else if ((IDTYP(h) == t)||(t==DEF_CMD))
194      {
195        if (BVERBOSE(V_REDEFINE))
196          Warn("redefining %s **",s);
197        IDID(h)=NULL;
198        killhdl(h,&currRing->idroot);
199      }
200      else
201      {
202        goto errlabel;
203      }
204    }
205  }
206  return *root = (*root)->set(s, lev, t, init);
207
208  errlabel:
209    Werror("identifier `%s` in use",s);
210    return NULL;
211}
212
213void killid(char * id, idhdl * ih)
214{
215  if (id!=NULL)
216  {
217    idhdl h = (*ih)->get(id,myynest);
218
219    // id not found in global list, is it defined in current ring ?
220    if (h==NULL)
221    {
222      if ((currRing!=NULL) && (*ih != (currRing->idroot)))
223      {
224        h = currRing->idroot->get(id,myynest);
225        if (h!=NULL)
226        {
227          killhdl(h,&(currRing->idroot));
228          return;
229        }
230      }
231      Werror("`%s` is not defined",id);
232      return;
233    }
234    killhdl(h,ih);
235  }
236  else
237    Werror("kill what ?");
238}
239
240void killhdl(idhdl h)
241{
242  int t=IDTYP(h);
243  if ((BEGIN_RING<t) && (t<END_RING) && (t!=QRING_CMD))
244    killhdl(h,&currRing->idroot);
245  else
246  {
247    idhdl s=idroot;
248    while ((s!=h) && (s!=NULL)) s=s->next;
249    if (s==NULL) killhdl(h,&currRing->idroot);
250    else killhdl(h,&idroot);
251  }
252}
253
254void killhdl(idhdl h, idhdl * ih)
255{
256  //printf("kill %s, id %x, typ %d lev: %d\n",IDID(h),(int)IDID(h),IDTYP(h),IDLEV(h));
257  idhdl hh;
258  BOOLEAN killOtherRing = TRUE;
259  BOOLEAN needResetRing = FALSE;
260
261  if (h->attribute!=NULL)
262  {
263    atKillAll(h);
264    //h->attribute=NULL;
265  }
266  // ring / qring  --------------------------------------------------------
267  // package  -------------------------------------------------------------
268  if ((IDTYP(h) == RING_CMD) || (IDTYP(h) == QRING_CMD)
269  || (IDTYP(h) == PACKAGE_CMD) )
270  {
271    idhdl savecurrRingHdl = currRingHdl;
272    ring  savecurrRing = currRing;
273
274    // any objects defined for this ring ?
275    if (((IDTYP(h)==PACKAGE_CMD) || (IDRING(h)->ref<=0))
276    &&  (IDRING(h)->idroot!=NULL))
277    {
278      idhdl * hd = &IDRING(h)->idroot;
279      idhdl  hdh = IDNEXT(*hd);
280      idhdl  temp;
281      killOtherRing=(IDTYP(h)!=PACKAGE_CMD) && (IDRING(h)!=currRing);
282      if (killOtherRing) //we are not killing the base ring, so switch
283      {
284        needResetRing=TRUE;
285        rSetHdl(h,FALSE);
286        /* no complete init*/
287      }
288      while (hdh!=NULL)
289      {
290        temp = IDNEXT(hdh);
291        killhdl(hdh,&(IDRING(h)->idroot));
292        hdh = temp;
293      }
294      killhdl(*hd,hd);
295    }
296    // reset currRing ?
297    if (needResetRing) // && (killOtherRing)
298    {
299      //we have to switch back to the base ring
300      //currRing = savecurrRing;
301      //currRingHdl = savecurrRingHdl;
302      if (savecurrRing!=NULL)
303      {
304        rSetHdl(savecurrRingHdl,TRUE);
305      }
306    }
307    rKill(h);
308  }
309  // poly / vector -------------------------------------------------------
310  else if ((IDTYP(h) == POLY_CMD) || (IDTYP(h) == VECTOR_CMD))
311  {
312    pDelete(&IDPOLY(h));
313  }
314  // ideal / module/ matrix / map ----------------------------------------
315  else if ((IDTYP(h) == IDEAL_CMD)
316           || (IDTYP(h) == MODUL_CMD)
317           || (IDTYP(h) == MATRIX_CMD)
318           || (IDTYP(h) == MAP_CMD))
319  {
320    ideal iid = IDIDEAL(h);
321    if (IDTYP(h) == MAP_CMD)
322    {
323      map im = IDMAP(h);
324      FreeL((ADDRESS)im->preimage);
325    }
326    idDelete(&iid);
327  }
328  // string -------------------------------------------------------------
329  else if (IDTYP(h) == STRING_CMD)
330  {
331    FreeL((ADDRESS)IDSTRING(h));
332    //IDSTRING(h)=NULL;
333  }
334  // proc ---------------------------------------------------------------
335  else if (IDTYP(h) == PROC_CMD)
336  {
337    piKill(IDPROC(h));
338  }
339  // number -------------------------------------------------------------
340  else if (IDTYP(h) == NUMBER_CMD)
341  {
342    nDelete(&IDNUMBER(h));
343  }
344  // intvec / intmat  ---------------------------------------------------
345  else if ((IDTYP(h) == INTVEC_CMD)||(IDTYP(h) == INTMAT_CMD))
346  {
347    delete IDINTVEC(h);
348  }
349  // list  -------------------------------------------------------------
350  else if (IDTYP(h)==LIST_CMD)
351  {
352    IDLIST(h)->Clean();
353    //Free((ADDRESS)IDLIST(h)->m, (IDLIST(h)->nr+1)*sizeof(sleftv));
354    //Free((ADDRESS)IDLIST(h), sizeof(slists));
355  }
356  // link  -------------------------------------------------------------
357  else if (IDTYP(h)==LINK_CMD)
358  {
359    slKill(IDLINK(h));
360  }
361  else if((IDTYP(h)==RESOLUTION_CMD)&&(IDDATA(h)!=NULL))
362  {
363    syKillComputation((syStrategy)IDDATA(h));
364  }
365#ifdef TEST
366  else if ((IDTYP(h)!= INT_CMD)&&(IDTYP(h)!=DEF_CMD))
367    Warn("unknown type to kill: %s(%d)",Tok2Cmdname(IDTYP(h)),IDTYP(h));
368#endif
369
370  //  general  -------------------------------------------------------------
371  // now dechain it and delete idrec
372  FreeL((ADDRESS)IDID(h));
373  //IDID(h)=NULL;
374  if (h == (*ih))
375  {
376    // h is at the beginning of the list
377    *ih = IDNEXT(*ih);
378  }
379  else
380  {
381    // h is somethere in the list:
382    hh = *ih;
383    loop
384    {
385      idhdl hhh = IDNEXT(hh);
386      if (hhh == h)
387      {
388        IDNEXT(hh) = IDNEXT(hhh);
389        break;
390      }
391      hh = hhh;
392    }
393  }
394  Free((ADDRESS)h,sizeof(idrec));
395}
396
397idhdl ggetid(const char *n)
398{
399  idhdl h = idroot->get(n,myynest);
400  idhdl h2=NULL;
401  if ((currRing!=NULL) && ((h==NULL)||(IDLEV(h)!=myynest)))
402  {
403    h2 = currRing->idroot->get(n,myynest);
404  }
405  if (h2==NULL) return h;
406  return h2;
407}
408
409void ipListFlag(idhdl h)
410{
411  if (hasFlag(h,FLAG_STD)) PrintS(" (SB)");
412  if (hasFlag(h,FLAG_DRING)) PrintS(" (D)");
413}
414
415lists ipNameList(idhdl root)
416{
417  idhdl h=root;
418  /* compute the length */
419  int l=0;
420  while (h!=NULL) { l++; h=IDNEXT(h); }
421  /* allocate list */
422  lists L=(lists)Alloc(sizeof(slists));
423  L->Init(l);
424  /* copy names */
425  h=root;
426  l=0;
427  while (h!=NULL)
428  {
429    /* list is initialized with 0 => no need to clear anything */
430    L->m[l].rtyp=STRING_CMD;
431    L->m[l].data=mstrdup(IDID(h));
432    l++;
433    h=IDNEXT(h);
434  }
435  return L;
436}
437
438/*
439* move 'tomove' from root1 list to root2 list
440*/
441static void ipSwapId(idhdl tomove, idhdl &root1, idhdl &root2)
442{
443  idhdl h;
444  /* search 'tomove' in root2 : if found -> do nothing */
445  h=root2;
446  while ((h!=NULL) && (h!=tomove)) h=IDNEXT(h);
447  if (h!=NULL) return;
448  /* search predecessor of h in root1, remove 'tomove' */
449  h=root1;
450  if (tomove==h)
451  {
452    root1=IDNEXT(h);
453  }
454  else
455  {
456    while ((h!=NULL) && (IDNEXT(h)!=tomove)) h=IDNEXT(h);
457    if (h==NULL) return; /* not in the list root1 -> do nothing */
458    IDNEXT(h)=IDNEXT(tomove);
459  }
460  /* add to root2 list */
461  IDNEXT(tomove)=root2;
462  root2=tomove;
463}
464
465void  ipMoveId(idhdl tomove)
466{
467  if ((currRing!=NULL)&&(tomove!=NULL))
468  {
469    if (((QRING_CMD!=IDTYP(tomove)) && (BEGIN_RING<IDTYP(tomove)) && (IDTYP(tomove)<END_RING))
470    || ((IDTYP(tomove)==LIST_CMD) && (lRingDependend(IDLIST(tomove)))))
471    {
472      /*move 'tomove' to ring id's*/
473      ipSwapId(tomove,idroot,currRing->idroot);
474    }
475    else
476    {
477      /*move 'tomove' to global id's*/
478      ipSwapId(tomove,currRing->idroot,idroot);
479    }
480  }
481}
482
483char * piProcinfo(procinfov pi, char *request)
484{
485  if(pi == NULL) return "empty proc";
486  else if (strcmp(request, "libname")  == 0) return pi->libname;
487  else if (strcmp(request, "procname") == 0) return pi->procname;
488  else if (strcmp(request, "type")     == 0) {
489    switch (pi->language) {
490      case LANG_SINGULAR: return "singular"; break;
491      case LANG_C:        return "object";   break;
492      case LANG_NONE:     return "none";     break;
493      default:            return "unknow language";
494    }
495  } else if (strcmp(request, "ref")      == 0) {
496    char p[8];
497    sprintf(p, "%d", pi->ref);
498    return mstrdup(p);  // MEMORY-LEAK
499  }
500  return "??";
501}
502
503void piCleanUp(procinfov pi)
504{
505  (pi->ref)--;
506  if (pi->ref <= 0)
507  {
508    FreeL((ADDRESS)pi->libname);
509    FreeL((ADDRESS)pi->procname);
510    if( pi->language == LANG_SINGULAR) { 
511      FreeL((ADDRESS)pi->data.s.body);
512    }
513    if( pi->language == LANG_C) {
514    }
515    memset((void *) pi, 0, sizeof(procinfo));
516    pi->language=LANG_NONE;
517  }
518}
519
520void piKill(procinfov pi)
521{
522  piCleanUp(pi);
523  if (pi->ref <= 0)
524    Free((ADDRESS)pi, sizeof(procinfo));
525}
526
Note: See TracBrowser for help on using the repository browser.