source: git/Singular/iplib.cc @ c599b4

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