source: git/Singular/iplib.cc @ 69a954

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