source: git/kernel/iplib.cc @ 91f1a3

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