source: git/Singular/iplib.cc @ 7497447

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