source: git/Singular/iplib.cc @ f09b51

spielwiese
Last change on this file since f09b51 was f09b51, checked in by Hans Schönemann <hannes@…>, 18 years ago
*hannes: debug code for memory leaks (inactiv) git-svn-id: file:///usr/local/Singular/svn/trunk@8761 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 31.6 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: iplib.cc,v 1.120 2005-10-28 14:56:12 Singular Exp $ */
5/*
6* ABSTRACT: interpreter: LIB and help
7*/
8
9//#include <stdlib.h>
10#include <stdio.h>
11#include <string.h>
12#include <ctype.h>
13#include <sys/stat.h>
14
15#include "mod2.h"
16#include "static.h"
17#include "tok.h"
18#include "ipid.h"
19#include "omalloc.h"
20#include "febase.h"
21#include "ring.h"
22#include "subexpr.h"
23#include "ipshell.h"
24#include "lists.h"
25
26#ifdef HAVE_DYNAMIC_LOADING
27BOOLEAN load_modules(char *newlib, char *fullname, BOOLEAN autoexport);
28#endif
29
30#ifdef HAVE_LIBPARSER
31#  include "libparse.h"
32#else /* HAVE_LIBPARSER */
33   procinfo *iiInitSingularProcinfo(procinfov pi, char *libname,
34                                    char *procname, int line, long pos,
35                                    BOOLEAN pstatic = FALSE);
36#endif /* HAVE_LIBPARSER */
37#define NS_LRING (procstack->cRing)
38
39#include "mod_raw.h"
40
41#ifdef HAVE_LIBPARSER
42void yylprestart (FILE *input_file );
43int current_pos(int i=0);
44extern int yylp_errno;
45extern int yylplineno;
46extern char *yylp_errlist[];
47void print_init();
48libstackv library_stack;
49#endif
50
51//int IsCmd(char *n, int tok);
52char mytolower(char c);
53
54/*2
55* return TRUE if the libray libname is already loaded
56*/
57BOOLEAN iiGetLibStatus(char *lib)
58{
59  idhdl hl;
60
61#ifndef HAVE_NS
62  char *p;
63
64  hl = IDROOT->get("LIB", 0);
65  if (hl == NULL || (p=strstr(IDSTRING(hl), lib)) == NULL) return FALSE;
66  if ((p!=IDSTRING(hl)) && (*(p-1)!=',')) return FALSE;
67
68  return TRUE;
69#else
70  char *plib = iiConvName(lib);
71  hl = basePack->idroot->get(plib,0);
72  if((hl==NULL) ||(IDTYP(hl)!=PACKAGE_CMD))
73  {
74    omFree(plib);
75    return FALSE;
76  }
77  omFree(plib);
78  return (strcmp(lib,IDPACKAGE(hl)->libname)==0);
79#endif
80}
81
82/*2
83* find the library of an proc:
84*  => return (pi->libname)
85*/
86char * iiGetLibName(procinfov pi)
87{
88  return pi->libname;
89}
90
91/*2
92* given a line 'proc[ ]+{name}[ \t]*'
93* return a pointer to name and set the end of '\0'
94* changes the input!
95* returns: e: pointer to 'end of name'
96*          ct: changed char at the end of s
97*/
98char* iiProcName(char *buf, char & ct, char* &e)
99{
100  char *s=buf+5;
101  while (*s==' ') s++;
102  e=s+1;
103  while ((*e>' ') && (*e!='(')) e++;
104  ct=*e;
105  *e='\0';
106  return s;
107}
108
109/*2
110* given a line with args, return the argstr
111*/
112char * iiProcArgs(char *e,BOOLEAN withParenth)
113{
114  while ((*e==' ') || (*e=='\t') || (*e=='(')) e++;
115  if (*e<' ')
116  {
117    if (withParenth)
118    {
119      // no argument list, allow list #
120      return omStrDup("parameter list #;");
121    }
122    else
123    {
124      // empty list
125      return omStrDup("");
126    }
127  }
128  BOOLEAN in_args;
129  BOOLEAN args_found;
130  char *s;
131  char *argstr=(char *)omAlloc(127); // see ../omalloc/omTables.inc
132  int argstrlen=127;
133  *argstr='\0';
134  int par=0;
135  do
136  {
137    args_found=FALSE;
138    s=e; // set s to the starting point of the arg
139         // and search for the end
140    while ((*e!=',')
141    &&((par!=0) || (*e!=')'))
142    &&(*e!='\0'))
143    {
144      if (*e=='(') par++;
145      else if (*e==')') par--;
146      args_found=args_found || (*e>' ');
147      e++;
148    }
149    in_args=(*e==',');
150    if (args_found)
151    {
152      *e='\0';
153      // check for space:
154      if ((int)strlen(argstr)+12 /* parameter + ;*/ +(int)strlen(s)>= argstrlen)
155      {
156        argstrlen*=2;
157        char *a=(char *)omAlloc( argstrlen);
158        strcpy(a,argstr);
159        omFree((ADDRESS)argstr);
160        argstr=a;
161      }
162      // copy the result to argstr
163      strcat(argstr,"parameter ");
164      strcat(argstr,s);
165      strcat(argstr,"; ");
166      e++; // e was pointing to ','
167    }
168  } while (in_args);
169  return argstr;
170}
171
172/*2
173* locate `procname` in lib `libname` and find the part `part`:
174*  part=0: help, between, but excluding the line "proc ..." and "{...":
175*    => return
176*  part=1: body, between "{ ..." and "}", including the 1. line, w/o "{"
177*    => set pi->data.s.body, return NULL
178*  part=2: example, between, but excluding the line "exapmle {..." and "}":
179*    => return
180*/
181char* iiGetLibProcBuffer(procinfo *pi, int part )
182{
183  char buf[256], *s = NULL, *p;
184  long procbuflen;
185
186  FILE * fp = feFopen( pi->libname, "rb", NULL, TRUE );
187  if (fp==NULL)
188  {
189    return NULL;
190  }
191
192  fseek(fp, pi->data.s.proc_start, SEEK_SET);
193  if(part==0)
194  { // load help string
195    int i, offset=0;
196    long head = pi->data.s.def_end - pi->data.s.proc_start;
197    procbuflen = pi->data.s.help_end - pi->data.s.help_start;
198    if (procbuflen<5)
199    {
200      fclose(fp);
201      return NULL; // help part does not exist
202    }
203    //Print("Help=%ld-%ld=%d\n", pi->data.s.body_start,
204    //    pi->data.s.proc_start, procbuflen);
205    s = (char *)omAlloc(procbuflen+head+3);
206    myfread(s, head, 1, fp);
207    s[head] = '\n';
208    fseek(fp, pi->data.s.help_start, SEEK_SET);
209    myfread(s+head+1, procbuflen, 1, fp);
210    fclose(fp);
211    s[procbuflen+head+1] = '\n';
212    s[procbuflen+head+2] = '\0';
213    offset=0;
214    for(i=0;i<=procbuflen+head+2; i++)
215    {
216      if(s[i]=='\\' &&
217         (s[i+1]=='"' || s[i+1]=='{' || s[i+1]=='}' || s[i+1]=='\\'))
218      {
219        i++;
220        offset++;
221      }
222      if(offset>0) s[i-offset] = s[i];
223    }
224    return(s);
225  }
226  else if(part==1)
227  { // load proc part - must exist
228    procbuflen = pi->data.s.def_end - pi->data.s.proc_start;
229    char *ss=(char *)omAlloc(procbuflen+2);
230    //fgets(buf, sizeof(buf), fp);
231    myfread( ss, procbuflen, 1, fp);
232    char ct;
233    char *e;
234    s=iiProcName(ss,ct,e);
235    char *argstr=NULL;
236    *e=ct;
237    argstr=iiProcArgs(e,TRUE);
238
239    assume(pi->data.s.body_end > pi->data.s.body_start);
240
241    procbuflen = pi->data.s.body_end - pi->data.s.body_start;
242    pi->data.s.body = (char *)omAlloc( strlen(argstr)+procbuflen+15+
243                                      strlen(pi->libname) );
244    //Print("Body=%ld-%ld=%d\n", pi->data.s.body_end,
245    //    pi->data.s.body_start, procbuflen);
246    assume(pi->data.s.body != NULL);
247    fseek(fp, pi->data.s.body_start, SEEK_SET);
248    strcpy(pi->data.s.body,argstr);
249    myfread( pi->data.s.body+strlen(argstr), procbuflen, 1, fp);
250    fclose( fp );
251    procbuflen+=strlen(argstr);
252    omFree(argstr);
253    omFree(ss);
254    pi->data.s.body[procbuflen] = '\0';
255    strcat( pi->data.s.body+procbuflen, "\n;return();\n\n" );
256    strcat( pi->data.s.body+procbuflen+13,pi->libname);
257    s=strchr(pi->data.s.body,'{');
258    if (s!=NULL) *s=' ';
259    return NULL;
260  }
261  else if(part==2)
262  { // example
263    if ( pi->data.s.example_lineno == 0)
264      return NULL; // example part does not exist
265    // load example
266    fseek(fp, pi->data.s.example_start, SEEK_SET);
267    fgets(buf, sizeof(buf), fp); // skip line with "example"
268    procbuflen = pi->data.s.proc_end - pi->data.s.example_start - strlen(buf);
269    //Print("Example=%ld-%ld=%d\n", pi->data.s.proc_end,
270    //  pi->data.s.example_start, procbuflen);
271    s = (char *)omAlloc(procbuflen+14);
272    myfread(s, procbuflen, 1, fp);
273    s[procbuflen] = '\0';
274    strcat(s+procbuflen-3, "\n;return();\n\n" );
275    p=strchr(s,'{');
276    if (p!=NULL) *p=' ';
277    return(s);
278  }
279  return NULL;
280}
281
282/*2
283* start a proc
284* parameters are built as exprlist
285* TODO:interrupt
286* return FALSE on success, TRUE if an error occurs
287*/
288BOOLEAN iiPStart(idhdl pn, sleftv  * v)
289{
290  char * str;
291  BOOLEAN err=FALSE;
292  int old_echo=si_echo;
293  char save_flags=0;
294  procinfov pi=NULL;
295
296  /* init febase ======================================== */
297  /* we do not enter this case if filename != NULL !! */
298  if (pn!=NULL)
299  {
300    pi = IDPROC(pn);
301    if(pi!=NULL)
302    {
303      save_flags=pi->trace_flag;
304      if( pi->data.s.body==NULL )
305      {
306        iiGetLibProcBuffer(pi);
307        if (pi->data.s.body==NULL) return TRUE;
308      }
309//      omUpdateInfo();
310//      int m=om_Info.UsedBytes;
311//      Print("proc %s, mem=%d\n",IDID(pn),m);
312      newBuffer( omStrDup(pi->data.s.body), BT_proc,
313                 pi, pi->data.s.body_lineno-(v!=NULL) );
314    }
315  }
316  /* generate argument list ======================================*/
317  if (v!=NULL)
318  {
319    iiCurrArgs=(leftv)omAllocBin(sleftv_bin);
320    memcpy(iiCurrArgs,v,sizeof(sleftv));
321    memset(v,0,sizeof(sleftv));
322  }
323  else
324  {
325    iiCurrArgs=NULL;
326  }
327  /* start interpreter ======================================*/
328  myynest++;
329  if (myynest > 1000)
330  {
331    WerrorS("nesting too deep (>1000)");
332    err=TRUE;
333  }
334  else
335  {
336    err=yyparse();
337#ifdef HAVE_NS
338#ifndef NDEBUG
339    checkall();
340#endif
341#endif
342    if (sLastPrinted.rtyp!=0)
343    {
344      sLastPrinted.CleanUp();
345    }
346    //Print("kill locals for %s (level %d)\n",IDID(pn),myynest);
347    killlocals(myynest);
348#ifdef HAVE_NS
349#ifndef NDEBUG
350    checkall();
351#endif
352#endif
353    //Print("end kill locals for %s (%d)\n",IDID(pn),myynest);
354  }
355  myynest--;
356  si_echo=old_echo;
357  if (pi!=NULL)
358    pi->trace_flag=save_flags;
359//  omUpdateInfo();
360//  int m=om_Info.UsedBytes;
361//  Print("exit %s, mem=%d\n",IDID(pn),m);
362  return err;
363}
364
365#ifdef USE_IILOCALRING
366ring    *iiLocalRing;
367#endif
368sleftv  *iiRETURNEXPR;
369int     iiRETURNEXPR_len=0;
370
371#ifdef RDEBUG
372static void iiShowLevRings()
373{
374  int i;
375#ifdef USE_IILOCALRING
376  for (i=0;i<=myynest;i++)
377  {
378    Print("lev %d:",i);
379    if (iiLocalRing[i]==NULL) PrintS("NULL");
380    else                      Print("%x",iiLocalRing[i]);
381    PrintLn();
382  }
383#endif
384#if  0
385//#ifdef HAVE_NS
386  i=myynest;
387  proclevel *p=procstack;
388  while (p!=NULL)
389  {
390    Print("lev %d:",i);
391    if (p->cRingHdl==NULL) PrintS("NULL");
392    else                   Print("%s",IDID(p->cRingHdl));
393    PrintLn();
394    p=p->next;
395  }
396#endif
397  if (currRing==NULL) PrintS("curr:NULL\n");
398  else                Print ("curr:%x\n",currRing);
399}
400#endif /* RDEBUG */
401
402static void iiCheckNest()
403{
404  if (myynest >= iiRETURNEXPR_len-1)
405  {
406    iiRETURNEXPR=(sleftv *)omreallocSize(iiRETURNEXPR,
407                                   iiRETURNEXPR_len*sizeof(sleftv),
408                                   (iiRETURNEXPR_len+16)*sizeof(sleftv));
409    omMarkAsStaticAddr(iiRETURNEXPR);
410    memset(&(iiRETURNEXPR[iiRETURNEXPR_len]),0,16*sizeof(sleftv));
411#ifdef USE_IILOCALRING
412    iiLocalRing=(ring *)omreallocSize(iiLocalRing,
413                                   iiRETURNEXPR_len*sizeof(ring),
414                                   (iiRETURNEXPR_len+16)*sizeof(ring));
415    memset(&(iiLocalRing[iiRETURNEXPR_len]),0,16*sizeof(ring));
416#endif
417    iiRETURNEXPR_len+=16;
418  }
419}
420#ifdef HAVE_NS
421sleftv * iiMake_proc(idhdl pn, package pack, sleftv* sl)
422#else /* HAVE_NS */
423sleftv * iiMake_proc(idhdl pn, sleftv* sl)
424#endif /* HAVE_NS */
425{
426  int err;
427  procinfov pi = IDPROC(pn);
428  char *plib = iiConvName(pi->libname);
429  omFree((ADDRESS)plib);
430  if(pi->is_static && myynest==0)
431  {
432    Werror("'%s::%s()' is a local procedure and cannot be accessed by an user.",
433           pi->libname, pi->procname);
434    return NULL;
435  }
436  iiCheckNest();
437#ifdef USE_IILOCALRING
438  iiLocalRing[myynest]=currRing;
439  //Print("currRing(%d):%s(%x) in %s\n",myynest,IDID(currRingHdl),currRing,IDID(pn));
440#endif
441  iiRETURNEXPR[myynest+1].Init();
442  procstack->push(pi->procname);
443  if ((traceit&TRACE_SHOW_PROC)
444  || (pi->trace_flag&TRACE_SHOW_PROC))
445  {
446    if (traceit&TRACE_SHOW_LINENO) PrintLn();
447    Print("entering%-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
448  }
449#ifdef RDEBUG
450  if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
451#endif
452  switch (pi->language)
453  {
454      default:
455      case LANG_NONE:
456                 err=TRUE;
457                 break;
458
459    case LANG_SINGULAR:
460                 #ifdef HAVE_NS
461                 if ((pi->pack!=NULL)&&(currPack!=pi->pack))
462                 {
463                   currPack=pi->pack;
464                   iiCheckPack(currPack);
465                   currPackHdl=packFindHdl(currPack);
466                   //Print("set pack=%s\n",IDID(currPackHdl));
467                 }
468                 else if ((pack!=NULL)&&(currPack!=pack))
469                 {
470                   currPack=pack;
471                   iiCheckPack(currPack);
472                   currPackHdl=packFindHdl(currPack);
473                   //Print("set pack=%s\n",IDID(currPackHdl));
474                 }
475                 #endif
476                 err=iiPStart(pn,sl);
477                 #ifdef HAVE_NS
478                 #endif
479                 break;
480    case LANG_C:
481                 leftv res = (leftv)omAlloc0Bin(sleftv_bin);
482                 err = (pi->data.o.function)(res, sl);
483                 iiRETURNEXPR[myynest+1].Copy(res);
484                 omFreeBin((ADDRESS)res,  sleftv_bin);
485                 break;
486  }
487  if ((traceit&TRACE_SHOW_PROC)
488  || (pi->trace_flag&TRACE_SHOW_PROC))
489  {
490    if (traceit&TRACE_SHOW_LINENO) PrintLn();
491    Print("leaving %-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
492  }
493  //char *n="NULL";
494  //if (currRingHdl!=NULL) n=IDID(currRingHdl);
495  //Print("currRing(%d):%s(%x) after %s\n",myynest,n,currRing,IDID(pn));
496#ifdef RDEBUG
497  if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
498#endif
499  if (err)
500  {
501    iiRETURNEXPR[myynest+1].CleanUp();
502    //iiRETURNEXPR[myynest+1].Init(); //done by CleanUp
503  }
504#ifdef USE_IILOCALRING
505#if 0
506  if(procstack->cRing != iiLocalRing[myynest]) Print("iiMake_proc: 1 ring not saved procs:%x, iiLocal:%x\n",procstack->cRing, iiLocalRing[myynest]);
507#endif
508  if (iiLocalRing[myynest] != currRing)
509  {
510    if (currRing!=NULL)
511    { 
512      if (((iiRETURNEXPR[myynest+1].Typ()>BEGIN_RING)
513        && (iiRETURNEXPR[myynest+1].Typ()<END_RING))
514      || ((iiRETURNEXPR[myynest+1].Typ()==LIST_CMD)
515        && (lRingDependend((lists)iiRETURNEXPR[myynest+1].Data()))))
516      {
517        //idhdl hn;
518        char *n;
519        char *o;
520        idhdl nh=NULL, oh=NULL;
521        if (iiLocalRing[myynest]!=NULL)
522          oh=rFindHdl(iiLocalRing[myynest],NULL, NULL);
523        if (oh!=NULL)          o=oh->id;
524        else                   o="none";
525        if (currRing!=NULL)
526          nh=rFindHdl(currRing,NULL, NULL);
527        if (nh!=NULL)          n=nh->id;
528        else                   n="none";
529        Werror("ring change during procedure call: %s -> %s (level %d)",o,n,myynest);
530        iiRETURNEXPR[myynest+1].CleanUp();
531        err=TRUE;
532      }
533    }
534    currRing=iiLocalRing[myynest];
535  }
536  if ((currRing==NULL)
537  && (currRingHdl!=NULL))
538    currRing=IDRING(currRingHdl);
539  else
540  if ((currRing!=NULL) &&
541    ((currRingHdl==NULL)||(IDRING(currRingHdl)!=currRing)
542     ||(IDLEV(currRingHdl)>=myynest)))
543  {
544    rSetHdl(rFindHdl(currRing,NULL, NULL));
545    iiLocalRing[myynest]=NULL;
546  }
547#else /* USE_IILOCALRING */
548  if (procstack->cRing != currRing)
549  {
550    //if (procstack->cRingHdl!=NULL)
551    //Print("procstack:%s,",IDID(procstack->cRingHdl));
552    //if (currRingHdl!=NULL)
553    //Print(" curr:%s\n",IDID(currRingHdl));
554    //Print("pr:%x, curr: %x\n",procstack->cRing,currRing);
555    if (((iiRETURNEXPR[myynest+1].Typ()>BEGIN_RING)
556      && (iiRETURNEXPR[myynest+1].Typ()<END_RING))
557    || ((iiRETURNEXPR[myynest+1].Typ()==LIST_CMD)
558      && (lRingDependend((lists)iiRETURNEXPR[myynest+1].Data()))))
559    {
560      //idhdl hn;
561      char *n;
562      char *o;
563      if (procstack->cRing!=NULL)
564      {
565        //PrintS("reset ring\n");
566        procstack->cRingHdl=rFindHdl(procstack->cRing,NULL, NULL);
567        #ifdef HAVE_NS
568        if (procstack->cRingHdl==NULL)
569          procstack->cRingHdl=
570           rFindHdl(procstack->cRing,NULL,procstack->currPack->idroot);
571        if (procstack->cRingHdl==NULL)
572          procstack->cRingHdl=
573           rFindHdl(procstack->cRing,NULL,basePack->idroot);
574        #endif
575        o=IDID(procstack->cRingHdl);
576        currRing=procstack->cRing;
577        currRingHdl=procstack->cRingHdl;
578      }
579      else                            o="none";
580      if (currRing!=NULL)             n=IDID(currRingHdl);
581      else                            n="none";
582      if (currRing==NULL)
583      {
584        Werror("ring change during procedure call: %s -> %s",o,n);
585        iiRETURNEXPR[myynest+1].CleanUp();
586        err=TRUE;
587      }
588    }
589    if (procstack->cRingHdl!=NULL)
590    {
591      rSetHdl(procstack->cRingHdl);
592    }
593    else
594    { currRingHdl=NULL; currRing=NULL; }
595  }
596#endif /* USE_IILOCALRING */
597  if (iiCurrArgs!=NULL)
598  {
599    if (!err) Warn("too many arguments for %s",IDID(pn));
600    iiCurrArgs->CleanUp();
601    omFreeBin((ADDRESS)iiCurrArgs, sleftv_bin);
602    iiCurrArgs=NULL;
603  }
604  procstack->pop();
605  if (err)
606    return NULL;
607  return &iiRETURNEXPR[myynest+1];
608}
609
610/*2
611* start an example (as a proc),
612* destroys the string 'example'
613*/
614BOOLEAN iiEStart(char* example, procinfo *pi)
615{
616  BOOLEAN err;
617  int old_echo=si_echo;
618
619  newBuffer( example, BT_example, pi,
620             (pi != NULL ? pi->data.s.example_lineno: 0));
621
622  iiCheckNest();
623  procstack->push(example);
624#ifdef USE_IILOCALRING
625  iiLocalRing[myynest]=currRing;
626#endif
627  if (traceit&TRACE_SHOW_PROC)
628  {
629    if (traceit&TRACE_SHOW_LINENO) printf("\n");
630    printf("entering example (level %d)\n",myynest);
631  }
632  myynest++;
633  err=yyparse();
634  if (sLastPrinted.rtyp!=0)
635  {
636    sLastPrinted.CleanUp();
637    //memset(&sLastPrinted,0,sizeof(sleftv)); //done by CleanUp
638  }
639  killlocals(myynest);
640  myynest--;
641  si_echo=old_echo;
642  if (traceit&TRACE_SHOW_PROC)
643  {
644    if (traceit&TRACE_SHOW_LINENO) printf("\n");
645    printf("leaving  -example- (level %d)\n",myynest);
646  }
647#ifdef USE_IILOCALRING
648  if (iiLocalRing[myynest] != currRing)
649  {
650    if (iiLocalRing[myynest]!=NULL)
651    {
652      rSetHdl(rFindHdl(iiLocalRing[myynest],NULL, NULL));
653      iiLocalRing[myynest]=NULL;
654    }
655    else
656    {
657      currRingHdl=NULL;
658      currRing=NULL;
659    }
660  }
661#else /* USE_IILOCALRING */
662#endif /* USE_IILOCALRING */
663  if (NS_LRING != currRing)
664  {
665    if (NS_LRING!=NULL)
666    {
667      idhdl rh=procstack->cRingHdl;
668      if ((rh==NULL)||(IDRING(rh)!=NS_LRING))
669        rh=rFindHdl(NS_LRING,NULL, NULL);
670      rSetHdl(rh);
671    }
672    else
673    {
674      currRingHdl=NULL;
675      currRing=NULL;
676    }
677  }
678//#endif /* USE_IILOCALRING */
679  procstack->pop();
680  return err;
681}
682
683/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
684BOOLEAN iiTryLoadLib(leftv v, char *id)
685{
686  BOOLEAN LoadResult = TRUE;
687#ifdef HAVE_NS
688  char libnamebuf[128];
689  char *libname = (char *)omAlloc(strlen(id)+5);
690  char *suffix[] = { "", ".lib", ".so", ".sl", NULL };
691  int i = 0;
692  FILE *fp;
693  package pack;
694  idhdl packhdl;
695  lib_types LT;
696
697  for(i=0; suffix[i] != NULL; i++)
698  {
699    sprintf(libname, "%s%s", id, suffix[i]);
700    *libname = mytolower(*libname);
701    if((LT = type_of_LIB(libname, libnamebuf)) > LT_NOTFOUND)
702    {
703      char *s=omStrDup(libname);
704      char libnamebuf[256];
705
706      if (LT==LT_SINGULAR)
707        LoadResult = iiLibCmd(s, FALSE, FALSE,TRUE);
708      #ifdef HAVE_DYNAMIC_LOADING
709      else if ((LT==LT_ELF) || (LT==LT_HPUX))
710        LoadResult = load_modules(s,libnamebuf,FALSE);
711      #endif
712      if(!LoadResult )
713      {
714        v->name = iiConvName(libname);
715        break;
716      }
717    }
718  }
719  omFree(libname);
720#endif /* HAVE_NS */
721  return LoadResult;
722}
723
724BOOLEAN iiReLoadLib(idhdl packhdl)
725{
726  BOOLEAN LoadResult = TRUE;
727#ifdef HAVE_NAMESPACES
728  char libnamebuf[128];
729  package pack = IDPACKAGE(packhdl);
730
731  if(pack->language == LANG_NONE) return FALSE;
732
733  FILE * fp = feFopen( pack->libname, "r", libnamebuf, FALSE);
734  if (fp==NULL)
735  {
736    return TRUE;
737  }
738  namespaceroot->push(IDPACKAGE(packhdl), IDID(packhdl));
739  LoadResult = iiLoadLIB(fp, libnamebuf, IDPACKAGE(packhdl)->libname,
740                         packhdl, FALSE, FALSE);
741  namespaceroot->pop();
742#else /* HAVE_NAMESPACES */
743#endif /* HAVE_NAMESPACES */
744  return LoadResult;
745}
746
747/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
748/* check, if library lib has already been loaded
749   if yes, writes filename of lib into where and returns TRUE,
750      no, returns FALSE
751*/
752BOOLEAN iiLocateLib(const char* lib, char* where)
753{
754  idhdl hl;
755
756  char *p;
757
758  hl = IDROOT->get("LIB", 0);
759  if (hl == NULL || (p=strstr(IDSTRING(hl), lib)) == NULL) return FALSE;
760  if ((p!=IDSTRING(hl)) && (*(p-1)!=',')) return FALSE;
761
762  if (strstr(IDSTRING(hl), ",") == NULL)
763  {
764    strcpy(where, IDSTRING(hl));
765  }
766  else
767  {
768    char* tmp = omStrDup(IDSTRING(hl));
769    char* tok = strtok(tmp, ",");
770    do
771    {
772      if (strstr(tok, lib) != NULL) break;
773      tok = strtok(NULL, ",");
774    }
775    while (tok != NULL);
776    assume(tok != NULL);
777    strcpy(where, tok);
778    omFree(tmp);
779  }
780  return TRUE;
781}
782
783BOOLEAN iiLibCmd( char *newlib, BOOLEAN autoexport, BOOLEAN tellerror, BOOLEAN force )
784{
785  char buf[256];
786  char libnamebuf[128];
787  idhdl h;
788  BOOLEAN LoadResult = TRUE;
789#ifdef HAVE_NS
790  idhdl pl;
791#endif
792  idhdl hl;
793  int lines = 1;
794  long pos = 0L;
795  procinfov pi;
796#ifdef HAVE_NS
797  char *plib = iiConvName(newlib);
798#endif
799  FILE * fp = feFopen( newlib, "r", libnamebuf, tellerror );
800  if (fp==NULL)
801  {
802    return TRUE;
803  }
804#ifndef HAVE_NS
805  hl = idroot->get("LIB",0);
806  if (hl==NULL)
807  {
808    hl = enterid( "LIB",0, STRING_CMD, &idroot, FALSE );
809    IDSTRING(hl) = omStrDup(newlib);
810  }
811  else
812  {
813#ifdef TEST
814    if (IDSTRING(hl) != NULL)
815#endif
816    {
817      char *s = (char *)omAlloc( strlen(newlib) + strlen(IDSTRING(hl)) + 2 );
818      strcpy(s,IDSTRING(hl));
819      BOOLEAN f=FALSE;
820      if(strchr(s,',')==NULL)
821      {
822        if (strcmp(s,newlib)==0)
823          f=TRUE;
824      }
825      else
826      {
827        char *p=strtok(s,",");
828        do
829        {
830          if(strcmp(p,newlib)==0)
831          {
832            f=TRUE;
833            break;
834          }
835          p=strtok(NULL,",");
836        } while (p!=NULL);
837      }
838      if (f)
839        omFree((ADDRESS)s);
840      else
841      {
842        sprintf( s, "%s,%s", IDSTRING(hl), newlib);
843        omFree((ADDRESS)IDSTRING(hl));
844        IDSTRING(hl) = s;
845      }
846    }
847#ifdef TEST
848    else
849    {
850      PrintS("## empty LIB string\n");
851      IDSTRING(hl) = omStrDup(newlib);
852    }
853#endif
854  }
855#endif /* HAVE_NS */
856#ifdef HAVE_TCL
857  if (tclmode)
858  {
859    PrintTCLS('L',newlib);
860  }
861#endif
862#ifdef HAVE_NS
863  pl = basePack->idroot->get(plib,0);
864  if (pl==NULL)
865  {
866    pl = enterid( plib,0, PACKAGE_CMD,
867                  &(basePack->idroot), TRUE );
868    IDPACKAGE(pl)->language = LANG_SINGULAR;
869    IDPACKAGE(pl)->libname=omStrDup(newlib);
870  }
871  else
872  {
873    if(IDTYP(pl)!=PACKAGE_CMD)
874    {
875      WarnS("not of type package.");
876      fclose(fp);
877      return TRUE;
878    }
879    if (!force) return FALSE;
880  }
881  LoadResult = iiLoadLIB(fp, libnamebuf, newlib, pl, autoexport, tellerror);
882#else /* HAVE_NS */
883  LoadResult = iiLoadLIB(fp, libnamebuf, newlib, NULL, FALSE, tellerror);
884#endif /* HAVE_NS */
885
886  omFree((ADDRESS)newlib);
887
888#ifdef HAVE_NS
889  if(!LoadResult) IDPACKAGE(pl)->loaded = TRUE;
890  omFree((ADDRESS)plib);
891#endif /* HAVE_NS */
892
893 return LoadResult;
894}
895/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
896static void iiCleanProcs(idhdl &root)
897{
898  idhdl prev=NULL;
899  loop
900  {
901    if (root==NULL) return;
902    if (IDTYP(root)==PROC_CMD)
903    {
904      procinfo *pi=(procinfo*)IDDATA(root);
905      if ((pi->language == LANG_SINGULAR)
906      && (pi->data.s.body_start == 0L))
907      {
908        // procinfo data incorrect:
909        // - no proc body can start at the beginning of the file
910        killhdl(root);
911        if (prev==NULL)
912          root=IDROOT;
913        else
914        {
915          root=prev;
916          prev=NULL;
917        }
918        continue;
919      }
920    }
921    prev=root;
922    root=IDNEXT(root);
923  }
924}
925/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
926BOOLEAN iiLoadLIB(FILE *fp, char *libnamebuf, char*newlib,
927             idhdl pl, BOOLEAN autoexport, BOOLEAN tellerror)
928{
929  char buf[256];
930  extern FILE *yylpin;
931  libstackv ls_start = library_stack;
932  lib_style_types lib_style;
933
934  yylpin = fp;
935  #if YYLPDEBUG > 1
936  print_init();
937  #endif
938  extern int lpverbose;
939  if (BVERBOSE(V_DEBUG_LIB)) lpverbose=1;
940  else lpverbose=0;
941  #ifdef HAVE_NS
942    yylplex(newlib, libnamebuf, &lib_style, pl, autoexport);
943  #else
944    yylplex(newlib, libnamebuf, &lib_style);
945  #endif /* HAVE_NS */
946  if(yylp_errno)
947  {
948    Werror("Library %s: ERROR occured: in line %d, %d.", newlib, yylplineno,
949         current_pos(0));
950    if(yylp_errno==YYLP_BAD_CHAR)
951    {
952      Werror(yylp_errlist[yylp_errno], *text_buffer, yylplineno);
953      omFree((ADDRESS)text_buffer);
954      text_buffer=NULL;
955    }
956    else
957      Werror(yylp_errlist[yylp_errno], yylplineno);
958    Werror("Cannot load library,... aborting.");
959    reinit_yylp();
960    fclose( yylpin );
961    iiCleanProcs(IDROOT);
962    return TRUE;
963  }
964  if (BVERBOSE(V_LOAD_LIB))
965    Print( "// ** loaded %s %s\n", libnamebuf, text_buffer);
966  if( (lib_style == OLD_LIBSTYLE) && (BVERBOSE(V_LOAD_LIB)))
967  {
968    Warn( "library %s has old format. This format is still accepted,", newlib);
969    Warn( "but for functionality you may wish to change to the new");
970    Warn( "format. Please refer to the manual for further information.");
971  }
972  reinit_yylp();
973  fclose( yylpin );
974  fp = NULL;
975
976  {
977    libstackv ls;
978    for(ls = library_stack; (ls != NULL) && (ls != ls_start); )
979    {
980      if(ls->to_be_done)
981      {
982        ls->to_be_done=FALSE;
983        iiLibCmd(ls->get(),autoexport,tellerror,FALSE);
984        ls = ls->pop(newlib);
985      }
986    }
987#if 0
988    PrintS("--------------------\n");
989    for(ls = library_stack; ls != NULL; ls = ls->next)
990    {
991      Print("%s: LIB-stack:(%d), %s %s\n", newlib, ls->cnt, ls->get(),
992        ls->to_be_done ? "not loaded" : "loaded");
993    }
994    PrintS("--------------------\n");
995#endif
996  }
997
998  if(fp != NULL) fclose(fp);
999  return FALSE;
1000}
1001
1002
1003/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1004procinfo *iiInitSingularProcinfo(procinfov pi, char *libname, char *procname,
1005                                 int line, long pos, BOOLEAN pstatic)
1006{
1007  pi->libname = omStrDup(libname);
1008
1009  if( strcmp(procname,"_init")==0)
1010  {
1011    pi->procname = iiConvName(libname);
1012  }
1013  else
1014    pi->procname = omStrDup(procname);
1015  pi->language = LANG_SINGULAR;
1016  pi->ref = 1;
1017#ifdef HAVE_NS
1018  pi->pack = NULL;
1019#endif
1020  pi->is_static = pstatic;
1021  pi->data.s.proc_start = pos;
1022  pi->data.s.def_end    = 0L;
1023  pi->data.s.help_start = 0L;
1024  pi->data.s.help_end   = 0L;
1025  pi->data.s.body_start = 0L;
1026  pi->data.s.body_end   = 0L;
1027  pi->data.s.example_start = 0L;
1028  pi->data.s.proc_lineno = line;
1029  pi->data.s.body_lineno = 0;
1030  pi->data.s.example_lineno = 0;
1031  pi->data.s.body = NULL;
1032  pi->data.s.help_chksum = 0;
1033  return(pi);
1034}
1035
1036#ifdef HAVE_DYNAMIC_LOADING
1037/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1038int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
1039               BOOLEAN(*func)(leftv res, leftv v))
1040{
1041  procinfov pi;
1042  idhdl h;
1043
1044  h = enterid(procname,0, PROC_CMD, &IDROOT, TRUE);
1045  if ( h!= NULL )
1046  {
1047    pi = IDPROC(h);
1048    pi->libname = omStrDup(libname);
1049    pi->procname = omStrDup(procname);
1050    pi->language = LANG_C;
1051    pi->ref = 1;
1052    pi->is_static = pstatic;
1053    pi->data.o.function = func;
1054    return(1);
1055  }
1056  else
1057  {
1058    PrintS("iiAddCproc: failed.\n");
1059  }
1060  return(0);
1061}
1062
1063int iiAddCprocTop(char *libname, char *procname, BOOLEAN pstatic,
1064               BOOLEAN(*func)(leftv res, leftv v))
1065{
1066  int r=iiAddCproc(libname,procname,pstatic,func);
1067  #ifdef HAVE_NS
1068  package s=currPack;
1069  currPack=basePack;
1070  if (r) r=iiAddCproc(libname,procname,pstatic,func);
1071  currPack=s;
1072  #endif
1073  return r;
1074}
1075
1076/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1077BOOLEAN load_modules(char *newlib, char *fullname, BOOLEAN autoexport)
1078{
1079#ifdef HAVE_STATIC
1080  WerrorS("mod_init: static version can not load modules");
1081  return TRUE;
1082#else
1083  int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
1084                 BOOLEAN(*func)(leftv res, leftv v));
1085  typedef int (*fktn_t)(int(*iiAddCproc)(char *libname, char *procname,
1086                               BOOLEAN pstatic,
1087                               BOOLEAN(*func)(leftv res, leftv v)));
1088  fktn_t fktn;
1089  idhdl pl;
1090  char *plib = iiConvName(newlib);
1091  BOOLEAN RET=TRUE;
1092  int token;
1093  char FullName[256];
1094
1095  memset(FullName,0,256);
1096
1097  if( *fullname != '/' &&  *fullname != '.' )
1098    sprintf(FullName, "./%s", newlib);
1099  else strncpy(FullName, fullname,255);
1100
1101
1102  if(IsCmd(plib, token))
1103  {
1104    Werror("'%s' is resered identifier\n", plib);
1105    goto load_modules_end;
1106  }
1107  pl = IDROOT->get(plib,0);
1108  if (pl==NULL)
1109  {
1110    pl = enterid( plib,0, PACKAGE_CMD, &IDROOT,
1111                  TRUE );
1112    IDPACKAGE(pl)->language = LANG_C;
1113    IDPACKAGE(pl)->libname=omStrDup(newlib);
1114  }
1115  else
1116  {
1117    if(IDTYP(pl)!=PACKAGE_CMD)
1118    {
1119      Warn("not of type package.");
1120      goto load_modules_end;
1121    }
1122  }
1123  if((IDPACKAGE(pl)->handle=dynl_open(FullName))==(void *)NULL)
1124  {
1125    Werror("dynl_open failed:%s", dynl_error());
1126    Werror("%s not found", newlib);
1127    goto load_modules_end;
1128  }
1129  else
1130  {
1131#ifdef HAVE_NS
1132    package s=currPack;
1133    currPack=IDPACKAGE(pl);
1134#endif
1135    fktn = (fktn_t)dynl_sym(IDPACKAGE(pl)->handle, "mod_init");
1136    if( fktn!= NULL)
1137    {
1138      if (autoexport) (*fktn)(iiAddCprocTop);
1139      else            (*fktn)(iiAddCproc);
1140    }
1141    else Werror("mod_init: %s\n", dynl_error());
1142    if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s \n", fullname);
1143#ifdef HAVE_NS
1144    currPack->loaded=1;
1145    currPack=s;
1146#endif
1147  }
1148  RET=FALSE;
1149
1150  load_modules_end:
1151  return RET;
1152#endif /*STATIC */ 
1153}
1154#endif /* HAVE_DYNAMIC_LOADING */
1155
1156/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1157char mytoupper(char c)
1158{
1159  if(c>=97 && c<=(97+26)) c-=32;
1160  return(c);
1161}
1162
1163char mytolower(char c)
1164{
1165  if(c>=65 && c<=(65+26)) c+=32;
1166  return(c);
1167}
1168
1169/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1170//#if defined(WINNT)
1171//#  define  FS_SEP '\\'
1172//#else
1173//#  define FS_SEP '/'
1174//#endif
1175
1176char *iiConvName(const char *libname)
1177{
1178  char *tmpname = omStrDup(libname);
1179  char *p = strrchr(tmpname, DIR_SEP);
1180  char *r;
1181  if(p==NULL) p = tmpname;
1182  else p++;
1183  r = strchr(p, '.');
1184  if( r!= NULL) *r = '\0';
1185  r = omStrDup(p);
1186  *r = mytoupper(*r);
1187  // printf("iiConvName: '%s' '%s' => '%s'\n", libname, tmpname, r);
1188  omFree((ADDRESS)tmpname);
1189
1190  return(r);
1191}
1192
1193/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1194void piShowProcList()
1195{
1196  idhdl h;
1197  procinfo *proc;
1198  char *name;
1199
1200  Print( "%-15s  %20s      %s,%s  %s,%s   %s,%s\n", "Library", "function",
1201         "line", "start", "line", "body", "line", "example");
1202  for(h = IDROOT; h != NULL; h = IDNEXT(h))
1203  {
1204    if(IDTYP(h) == PROC_CMD)
1205    {
1206      proc = IDPROC(h);
1207      if(strcmp(proc->procname, IDID(h))!=0)
1208      {
1209        name = (char *)omAlloc(strlen(IDID(h))+strlen(proc->procname)+4);
1210        sprintf(name, "%s -> %s", IDID(h), proc->procname);
1211        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname, name);
1212        omFree((ADDRESS)name);
1213      }
1214      else
1215        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname,
1216               proc->procname);
1217      if(proc->language==LANG_SINGULAR)
1218        Print("line %4d,%-5ld  %4d,%-5ld  %4d,%-5ld\n",
1219              proc->data.s.proc_lineno, proc->data.s.proc_start,
1220              proc->data.s.body_lineno, proc->data.s.body_start,
1221              proc->data.s.example_lineno, proc->data.s.example_start);
1222      else if(proc->language==LANG_C)
1223        Print("type: object\n");
1224    }
1225  }
1226}
1227
1228/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1229//char *iiLineNo(char *procname, int lineno)
1230//{
1231//  char buf[256];
1232//  idhdl pn = ggetid(procname);
1233//  procinfo *pi = IDPROC(pn);
1234//
1235//  sprintf(buf, "%s %3d\0", procname, lineno);
1236//  //sprintf(buf, "%s::%s %3d\0", pi->libname, pi->procname,
1237//  //  lineno + pi->data.s.body_lineno);
1238//  return(buf);
1239//}
1240/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1241#ifdef HAVE_LIBPARSER
1242void libstack::push(char *p, char *libname)
1243{
1244  libstackv lp;
1245  if( !iiGetLibStatus(libname))
1246  {
1247    for(lp = this;lp!=NULL;lp=lp->next)
1248    {
1249      if(strcmp(lp->get(), libname)==0) break;
1250    }
1251    if(lp==NULL)
1252    {
1253      libstackv ls = (libstack *)omAlloc0Bin(libstack_bin);
1254      ls->next = this;
1255      ls->libname = omStrDup(libname);
1256      ls->to_be_done = TRUE;
1257      if(this != NULL) ls->cnt = this->cnt+1; else ls->cnt = 0;
1258      library_stack = ls;
1259    }
1260  }
1261}
1262
1263libstackv libstack::pop(char *p)
1264{
1265  libstackv ls = this;
1266  //omFree((ADDRESS)ls->libname);
1267  library_stack = ls->next;
1268  omFreeBin((ADDRESS)ls,  libstack_bin);
1269  return(library_stack);
1270}
1271
1272#endif /* HAVE_LIBPARSER */
1273/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
Note: See TracBrowser for help on using the repository browser.