source: git/Singular/iplib.cc @ f2dff02

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