source: git/Singular/iplib.cc @ 341696

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