source: git/Singular/iplib.cc @ b44622

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