source: git/Singular/iplib.cc @ 1c17b6

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