source: git/Singular/iplib.cc @ 50a84c

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