source: git/Singular/iplib.cc @ 551fd7

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