source: git/Singular/iplib.cc @ 5121f6

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