source: git/Singular/iplib.cc @ ec7aac

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