source: git/Singular/iplib.cc @ 64d729

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