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

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