source: git/Singular/iplib.cc @ 573da6

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