source: git/Singular/iplib.cc @ 08c2d6

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