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

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