source: git/Singular/iplib.cc @ 237b3e4

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