source: git/Singular/iplib.cc @ b78b73

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