source: git/Singular/iplib.cc @ 09ab91d

spielwiese
Last change on this file since 09ab91d was 09ab91d, checked in by Hans Schönemann <hannes@…>, 24 years ago
* hannes: fixed: example p; if p does not have one git-svn-id: file:///usr/local/Singular/svn/trunk@3448 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 30.6 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: iplib.cc,v 1.60 1999-08-16 12:39:57 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
36static char *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    if (procbuflen<5)
165      return NULL; // help part does not exist
166    //Print("Help=%ld-%ld=%d\n", pi->data.s.body_start,
167    //    pi->data.s.proc_start, procbuflen);
168    s = (char *)AllocL(procbuflen+head+3);
169    myfread(s, head, 1, fp);
170    s[head] = '\n';
171    fseek(fp, pi->data.s.help_start, SEEK_SET);
172    myfread(s+head+1, procbuflen, 1, fp);
173    s[procbuflen+head+1] = '\n';
174    s[procbuflen+head+2] = '\0';
175    offset=0;
176    for(i=0;i<=procbuflen+head+2; i++)
177    {
178      if(s[i]=='\\' &&
179         (s[i+1]=='"' || s[i+1]=='{' || s[i+1]=='}' || s[i+1]=='\\'))
180      {
181        i++;
182        offset++;
183      }
184      if(offset>0) s[i-offset] = s[i];
185    }
186    return(s);
187  }
188  else if(part==1)
189  { // load proc part - must exist
190    procbuflen = pi->data.s.def_end - pi->data.s.proc_start;
191    //fgets(buf, sizeof(buf), fp);
192    myfread( buf, procbuflen, 1, fp);
193    char ct;
194    char *e;
195    s=iiProcName(buf,ct,e);
196    char *argstr=NULL;
197    *e=ct;
198    argstr=iiProcArgs(e,TRUE);
199    procbuflen = pi->data.s.body_end - pi->data.s.body_start;
200    pi->data.s.body = (char *)AllocL( strlen(argstr)+procbuflen+15+
201                                      strlen(pi->libname) );
202    //Print("Body=%ld-%ld=%d\n", pi->data.s.body_end,
203    //    pi->data.s.body_start, procbuflen);
204    if (pi->data.s.body==NULL)
205    {
206      Werror( "unable to allocate proc buffer `%s`", pi->procname );
207      return NULL;
208    }
209    fseek(fp, pi->data.s.body_start, SEEK_SET);
210    strcpy(pi->data.s.body,argstr);
211    myfread( pi->data.s.body+strlen(argstr), procbuflen, 1, fp);
212    procbuflen+=strlen(argstr);
213    FreeL(argstr);
214    fclose( fp );
215    pi->data.s.body[procbuflen] = '\0';
216    strcat( pi->data.s.body+procbuflen, "\n;return();\n\n" );
217    strcat( pi->data.s.body+procbuflen+13,pi->libname);
218    s=strchr(pi->data.s.body,'{');
219    if (s!=NULL) *s=' ';
220    return NULL;
221  }
222  else if(part==2)
223  { // example
224    if ( pi->data.s.example_lineno == 0)
225      return NULL; // example part does not exist
226    // load example
227    fseek(fp, pi->data.s.example_start, SEEK_SET);
228    fgets(buf, sizeof(buf), fp); // skip line with "example"
229    procbuflen = pi->data.s.proc_end - pi->data.s.example_start - strlen(buf);
230    //Print("Example=%ld-%ld=%d\n", pi->data.s.proc_end,
231    //  pi->data.s.example_start, procbuflen);
232    s = (char *)AllocL(procbuflen+14);
233    myfread(s, procbuflen, 1, fp);
234    s[procbuflen] = '\0';
235    strcat(s+procbuflen-3, "\n;return();\n\n" );
236    p=strchr(s,'{');
237    if (p!=NULL) *p=' ';
238    return(s);
239  }
240  return NULL;
241}
242
243/*2
244* start a proc
245* parameters are built as exprlist
246* TODO:interrupt
247* return FALSE on success, TRUE if an error occurs
248*/
249BOOLEAN iiPStart(idhdl pn, sleftv  * v)
250{
251  char * str;
252  BOOLEAN err=FALSE;
253  int old_echo=si_echo;
254  char save_flags=0;
255  procinfov pi=NULL;
256
257  /* init febase ======================================== */
258  /* we do not enter this case if filename != NULL !! */
259  if (pn!=NULL)
260  {
261    pi = IDPROC(pn);
262    if(pi!=NULL)
263    {
264      save_flags=pi->trace_flag;
265      if( pi->data.s.body==NULL )
266      {
267        iiGetLibProcBuffer(pi);
268        if (pi->data.s.body==NULL) return TRUE;
269      }
270      newBuffer( mstrdup(pi->data.s.body), BT_proc,
271                 pi, pi->data.s.body_lineno-(v!=NULL) );
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  err=yyparse();
288  killlocals(myynest);
289  myynest--;
290  si_echo=old_echo;
291  if (pi!=NULL)
292    pi->trace_flag=save_flags;
293  return err;
294}
295
296#ifdef USE_IILOCALRING
297ring    *iiLocalRing
298#ifdef TEST
299                    =NULL
300#endif
301                   ;
302#endif
303sleftv  *iiRETURNEXPR
304#ifdef TEST
305                    =NULL
306#endif
307                   ;
308int     iiRETURNEXPR_len=0;
309
310#ifdef RDEBUG
311static void iiShowLevRings()
312{
313#ifdef USE_IILOCALRING
314  int i;
315  for (i=1;i<=myynest;i++)
316  {
317    Print("lev %d:",i);
318    if (iiLocalRing[i]==NULL) PrintS("NULL");
319    else                      Print("%d",iiLocalRing[i]);
320    PrintLn();
321  }
322#endif
323  {
324    namehdl nshdl;
325    for(nshdl=namespaceroot; nshdl->isroot != TRUE; nshdl = nshdl->next)
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    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  {
615    sprintf(libname, "%s%s", id, suffix[i]);
616    *libname = mytolower(*libname);
617    if((LT = type_of_LIB(libname, libnamebuf)) != LT_NONE)
618    {
619      if(!(LoadResult = iiLibCmd(mstrdup(libname), FALSE)))
620      {
621        v->name = iiConvName(libname);
622        break;
623      }
624    }
625  }
626  FreeL(libname);
627#else /* HAVE_NAMESPACES */
628#endif /* HAVE_NAMESPACES */
629  return LoadResult;
630}
631
632BOOLEAN iiReLoadLib(idhdl packhdl)
633{
634  BOOLEAN LoadResult = TRUE;
635#ifdef HAVE_NAMESPACES
636  char libnamebuf[128];
637  package pack = IDPACKAGE(packhdl);
638
639  if(pack->language == LANG_NONE) return FALSE;
640
641  FILE * fp = feFopen( pack->libname, "r", libnamebuf, FALSE);
642  if (fp==NULL)
643  {
644    return TRUE;
645  }
646  namespaceroot->push(IDPACKAGE(packhdl), IDID(packhdl));
647  LoadResult = iiLoadLIB(fp, libnamebuf, IDPACKAGE(packhdl)->libname,
648                         packhdl, FALSE, FALSE);
649  namespaceroot->pop();
650#else /* HAVE_NAMESPACES */
651#endif /* HAVE_NAMESPACES */
652  return LoadResult;
653}
654
655/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
656#ifdef HAVE_NAMESPACES
657BOOLEAN iiLibCmd( char *newlib, BOOLEAN autoexport, BOOLEAN tellerror )
658#else /* HAVE_NAMESPACES */
659BOOLEAN iiLibCmd( char *newlib, BOOLEAN tellerror )
660#endif /* HAVE_NAMESPACES */
661{
662  char buf[256];
663  char libnamebuf[128];
664  idhdl h,hl;
665  BOOLEAN LoadResult = TRUE;
666#ifdef HAVE_NAMESPACES
667  idhdl pl;
668#endif /* HAVE_NAMESPACES */
669  int lines = 1;
670  long pos = 0L;
671  procinfov pi;
672#ifdef HAVE_NAMESPACES
673  char *plib = iiConvName(newlib);
674#endif /* HAVE_NAMESPACES */
675  FILE * fp = feFopen( newlib, "r", libnamebuf, tellerror );
676  if (fp==NULL)
677  {
678    return TRUE;
679  }
680#ifdef HAVE_NAMESPACES
681  int token = 0;
682
683  if(IsCmd(plib, token))
684  {
685    Werror("'%s' is resered identifier\n", plib);
686    fclose(fp);
687    return TRUE;
688  }
689  hl = namespaceroot->get("LIB",0, TRUE);
690#else /* HAVE_NAMESPACES */
691  hl = idroot->get("LIB",0);
692#endif /* HAVE_NAMESPACES */
693  if (hl==NULL)
694  {
695#ifdef HAVE_NAMESPACES
696    hl = enterid( mstrdup("LIB"),0, STRING_CMD,
697                  &NSROOT(namespaceroot->root), FALSE );
698#else /* HAVE_NAMESPACES */
699    hl = enterid( mstrdup("LIB"),0, STRING_CMD, &idroot, FALSE );
700#endif /* HAVE_NAMESPACES */
701    IDSTRING(hl) = mstrdup(newlib);
702  }
703  else
704  {
705#ifdef TEST
706    if (IDSTRING(hl) != NULL)
707#endif
708    {
709      char *s = (char *)AllocL( strlen(newlib) + strlen(IDSTRING(hl)) + 2 );
710      strcpy(s,IDSTRING(hl));
711      BOOLEAN f=FALSE;
712      if(strchr(s,',')==NULL)
713      {
714        if (strcmp(s,newlib)==0)
715          f=TRUE;
716      }
717      else
718      {
719        char *p=strtok(s,",");
720        do
721        {
722          if(strcmp(p,newlib)==0)
723          {
724            f=TRUE;
725            break;
726          }
727          p=strtok(NULL,",");
728        } while (p!=NULL);
729      }
730      if (f)
731        FreeL((ADDRESS)s);
732      else
733      {
734        sprintf( s, "%s,%s", IDSTRING(hl), newlib);
735        FreeL((ADDRESS)IDSTRING(hl));
736        IDSTRING(hl) = s;
737      }
738    }
739#ifdef TEST
740    else
741    {
742      PrintS("## empty LIB string\n");
743      IDSTRING(hl) = mstrdup(newlib);
744    }
745#endif
746  }
747#ifdef HAVE_TCL
748  if (tclmode)
749  {
750    PrintTCLS('L',newlib);
751  }
752#endif
753#ifdef HAVE_NAMESPACES
754  pl = namespaceroot->get(plib,0, TRUE);
755  if (pl==NULL)
756  {
757    pl = enterid( mstrdup(plib),0, PACKAGE_CMD,
758                  &NSROOT(namespaceroot->root), TRUE );
759    IDPACKAGE(pl)->language = LANG_SINGULAR;
760    IDPACKAGE(pl)->libname=mstrdup(newlib);
761  }
762  else
763  {
764    if(IDTYP(pl)!=PACKAGE_CMD)
765    {
766      Warn("not of typ package.");
767      fclose(fp);
768      return TRUE;
769    }
770  }
771  namespaceroot->push(IDPACKAGE(pl), IDID(pl));
772  LoadResult = iiLoadLIB(fp, libnamebuf, newlib, pl, autoexport, tellerror);
773#else /* HAVE_NAMESPACES */
774  LoadResult = iiLoadLIB(fp, libnamebuf, newlib, NULL, FALSE, tellerror);
775#endif /* HAVE_NAMESPACES */
776
777#ifdef HAVE_NAMESPACES
778  if(!LoadResult) IDPACKAGE(pl)->loaded = TRUE;
779  namespaceroot->pop();
780#endif /* HAVE_NAMESPACES */
781
782  FreeL((ADDRESS)newlib);
783#ifdef HAVE_NAMESPACES
784  FreeL((ADDRESS)plib);
785#endif /* HAVE_LIBPARSER */
786 return LoadResult;
787}
788
789/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
790static BOOLEAN iiLoadLIB(FILE *fp, char *libnamebuf, char*newlib,
791             idhdl pl, BOOLEAN autoexport, BOOLEAN tellerror)
792{
793  char buf[256];
794  extern FILE *yylpin;
795  libstackv ls_start = library_stack;
796  lib_style_types lib_style;
797
798  yylpin = fp;
799#if YYLPDEBUG > 1
800  print_init();
801#endif
802  extern int lpverbose;
803  if (BVERBOSE(V_DEBUG_LIB)) lpverbose=1; else lpverbose=0;
804#ifdef HAVE_NAMESPACES
805   yylplex(newlib, libnamebuf, &lib_style, pl, autoexport);
806#else /* HAVE_NAMESPACES */
807  yylplex(newlib, libnamebuf, &lib_style);
808#endif /* HAVE_NAMESPACES */
809  if(yylp_errno)
810  {
811    Werror("Library %s: ERROR occured: in line %d, %d.", newlib, yylplineno,
812         current_pos(0));
813    if(yylp_errno==YYLP_BAD_CHAR)
814    {
815      Werror(yylp_errlist[yylp_errno], *text_buffer, yylplineno);
816      FreeL((ADDRESS)text_buffer);
817      text_buffer=NULL;
818    }
819    else
820      Werror(yylp_errlist[yylp_errno], yylplineno);
821    Werror("Cannot load library,... aborting.");
822    reinit_yylp();
823    fclose( yylpin );
824    return TRUE;
825  }
826#ifdef HAVE_NAMESPACES
827  if (BVERBOSE(V_LOAD_LIB))
828  {
829    idhdl versionhdl  = namespaceroot->get("version",0);
830    if(versionhdl != NULL)
831      Print( "// ** loaded %s %s\n", libnamebuf, IDSTRING(versionhdl));
832    else
833      Print( "// ** loaded %s\n", libnamebuf);
834  }
835#else /* HAVE_NAMESPACES */
836  if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s %s\n", libnamebuf,
837                                   text_buffer);
838#endif /* HAVE_NAMESPACES */
839  if( (lib_style == OLD_LIBSTYLE) && (BVERBOSE(V_LOAD_LIB)))
840  {
841    Warn( "library %s has old format. This format is still accepted,", newlib);
842    Warn( "but for functionality you may wish to change to the new");
843    Warn( "format. Please refer to the manual for further information.");
844  }
845  reinit_yylp();
846  fclose( yylpin );
847  fp = NULL;
848
849#ifdef HAVE_NAMESPACES
850  namespaceroot->pop();
851#endif /* HAVE_NAMESPACES */
852  {
853    libstackv ls;
854    for(ls = library_stack; (ls != NULL) && (ls != ls_start); )
855    {
856      if(ls->to_be_done)
857      {
858        ls->to_be_done=FALSE;
859#ifdef HAVE_NAMESPACES
860        iiLibCmd(ls->get(), autoexport);
861#else /* HAVE_NAMESPACES */
862        iiLibCmd(ls->get());
863#endif /* HAVE_NAMESPACES */
864        ls = ls->pop(newlib);
865      }
866    }
867#if 0
868    PrintS("--------------------\n");
869    for(ls = library_stack; ls != NULL; ls = ls->next)
870    {
871      Print("%s: LIB-stack:(%d), %s %s\n", newlib, ls->cnt, ls->get(),
872        ls->to_be_done ? "not loaded" : "loaded");
873    }
874    PrintS("--------------------\n");
875#endif
876  }
877
878  if(fp != NULL) fclose(fp);
879  return FALSE;
880}
881
882
883/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
884procinfo *iiInitSingularProcinfo(procinfov pi, char *libname, char *procname,
885                                 int line, long pos, BOOLEAN pstatic)
886{
887  pi->libname = mstrdup(libname);
888
889  if( strcmp(procname,"_init")==0)
890  {
891    pi->procname = iiConvName(libname);
892  }
893  else
894    pi->procname = mstrdup(procname);
895  pi->language = LANG_SINGULAR;
896  pi->ref = 1;
897  pi->is_static = pstatic;
898  pi->data.s.proc_start = pos;
899  pi->data.s.def_end    = 0L;
900  pi->data.s.help_start = 0L;
901  pi->data.s.help_end   = 0L;
902  pi->data.s.body_start = 0L;
903  pi->data.s.body_end   = 0L;
904  pi->data.s.example_start = 0L;
905  pi->data.s.proc_lineno = line;
906  pi->data.s.body_lineno = 0;
907  pi->data.s.example_lineno = 0;
908  pi->data.s.body = NULL;
909  pi->data.s.help_chksum = 0;
910  return(pi);
911}
912
913#ifdef HAVE_DYNAMIC_LOADING
914/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
915int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
916               BOOLEAN(*func)(leftv res, leftv v))
917{
918  procinfov pi;
919  idhdl h;
920
921  h = enterid(mstrdup(procname),0, PROC_CMD, &IDROOT, TRUE);
922  if ( h!= NULL )
923  {
924    pi = IDPROC(h);
925    pi->libname = mstrdup(libname);
926    pi->procname = mstrdup(procname);
927    pi->language = LANG_C;
928    pi->ref = 1;
929    pi->is_static = pstatic;
930    pi->data.o.function = func;
931    return(1);
932  }
933  else
934  {
935    PrintS("iiAddCproc: failed.\n");
936  }
937  return(0);
938}
939
940/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
941BOOLEAN load_modules(char *newlib, char *fullname, BOOLEAN tellerror)
942{
943  int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
944                 BOOLEAN(*func)(leftv res, leftv v));
945  int (*fktn)(int(*iiAddCproc)(char *libname, char *procname,
946                               BOOLEAN pstatic,
947                               BOOLEAN(*func)(leftv res, leftv v)));
948  idhdl pl;
949  char *plib = iiConvName(newlib);
950  BOOLEAN RET=TRUE;
951  int token;
952  char FullName[256];
953
954  if( *fullname != '/' &&  *fullname != '.' )
955    sprintf(FullName, "./%s", newlib);
956  else strcpy(FullName, fullname);
957
958
959  if(IsCmd(plib, &token))
960  {
961    Werror("'%s' is resered identifier\n", plib);
962    goto load_modules_end;
963  }
964
965  pl = namespaceroot->get(plib,0, TRUE);
966  if (pl==NULL)
967  {
968    pl = enterid( mstrdup(plib),0, PACKAGE_CMD,
969                  &NSROOT(namespaceroot->root), TRUE );
970    IDPACKAGE(pl)->language = LANG_C;
971    IDPACKAGE(pl)->libname=mstrdup(newlib);
972  }
973  else
974  {
975    if(IDTYP(pl)!=PACKAGE_CMD)
976    {
977      Warn("not of typ package.");
978      goto load_modules_end;
979    }
980  }
981  namespaceroot->push(IDPACKAGE(pl), IDID(pl));
982
983  if((IDPACKAGE(pl)->handle=dynl_open(FullName))==(void *)NULL)
984  {
985    WerrorS("dynl_open failed");
986    Werror("%s not found", newlib);
987    goto load_modules_end;
988  }
989  else
990  {
991    fktn = dynl_sym(IDPACKAGE(pl)->handle, "mod_init");
992    if( fktn!= NULL) (*fktn)(iiAddCproc);
993    else Werror("mod_init: %s\n", dynl_error());
994    if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s \n", fullname);
995  }
996  RET=FALSE;
997
998  load_modules_end:
999  namespaceroot->pop();
1000  return RET;
1001
1002}
1003#endif /* HAVE_DYNAMIC_LOADING */
1004
1005/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1006char mytoupper(char c)
1007{
1008  if(c>=97 && c<=(97+26)) c-=32;
1009  return(c);
1010}
1011
1012char mytolower(char c)
1013{
1014  if(c>=65 && c<=(65+26)) c+=32;
1015  return(c);
1016}
1017
1018/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1019//#if defined(WINNT)
1020//#  define  FS_SEP '\\'
1021//#elif defined(macintosh)
1022//#  define FS_SEP ','
1023//#else
1024//#  define FS_SEP '/'
1025//#endif
1026
1027static char *iiConvName(char *libname)
1028{
1029  char *tmpname = mstrdup(libname);
1030  char *p = strrchr(tmpname, DIR_SEP);
1031  char *r;
1032  if(p==NULL) p = tmpname;
1033  else p++;
1034  r = strchr(p, '.');
1035  if( r!= NULL) *r = '\0';
1036  r = mstrdup(p);
1037  *r = mytoupper(*r);
1038  // printf("iiConvName: '%s' '%s' => '%s'\n", libname, tmpname, r);
1039  FreeL((ADDRESS)tmpname);
1040
1041  return(r);
1042}
1043
1044/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1045void piShowProcList()
1046{
1047  idhdl h;
1048#ifdef HAVE_NAMESPACES
1049  idhdl pl;
1050#endif /* HAVE_NAMESPACES */
1051  procinfo *proc;
1052  char *name;
1053
1054  Print( "%-15s  %20s      %s,%s  %s,%s   %s,%s\n", "Library", "function",
1055         "line", "start", "line", "body", "line", "example");
1056#ifdef HAVE_NAMESPACES
1057//  for(pl = IDROOT; pl != NULL; pl = IDNEXT(pl))
1058//{
1059    for(pl = NSROOT(namespaceroot->root); pl != NULL; pl = IDNEXT(pl))
1060    {
1061    if(IDTYP(pl) == PACKAGE_CMD)
1062    {
1063      for(h = IDPACKAGE(pl)->idroot; h != NULL; h = IDNEXT(h))
1064#else /* HAVE_NAMESPACES */
1065  for(h = IDROOT; h != NULL; h = IDNEXT(h))
1066#endif /* HAVE_NAMESPACES */
1067  {
1068    if(IDTYP(h) == PROC_CMD)
1069    {
1070      proc = IDPROC(h);
1071      if(strcmp(proc->procname, IDID(h))!=0)
1072      {
1073        name = (char *)AllocL(strlen(IDID(h))+strlen(proc->procname)+4);
1074        sprintf(name, "%s -> %s", IDID(h), proc->procname);
1075        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname, name);
1076        FreeL((ADDRESS)name);
1077      }
1078      else
1079        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname,
1080               proc->procname);
1081      if(proc->language==LANG_SINGULAR)
1082        Print("line %4d,%-5ld  %4d,%-5ld  %4d,%-5ld\n",
1083              proc->data.s.proc_lineno, proc->data.s.proc_start,
1084              proc->data.s.body_lineno, proc->data.s.body_start,
1085              proc->data.s.example_lineno, proc->data.s.example_start);
1086      else if(proc->language==LANG_C)
1087        Print("type: object\n");
1088#ifdef HAVE_NAMESPACES
1089          }
1090      }
1091#endif /* HAVE_NAMESPACES */
1092    }
1093  }
1094}
1095
1096/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1097//char *iiLineNo(char *procname, int lineno)
1098//{
1099//  char buf[256];
1100//  idhdl pn = ggetid(procname);
1101//  procinfo *pi = IDPROC(pn);
1102//
1103//  sprintf(buf, "%s %3d\0", procname, lineno);
1104//  //sprintf(buf, "%s::%s %3d\0", pi->libname, pi->procname,
1105//  //  lineno + pi->data.s.body_lineno);
1106//  return(buf);
1107//}
1108/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1109#ifdef HAVE_LIBPARSER
1110void libstack::push(char *p, char *libname)
1111{
1112#  ifdef HAVE_NAMESPACES
1113  idhdl hl = namespaceroot->get("LIB",0, TRUE);
1114#  else /* HAVE_NAMESPACES */
1115  idhdl hl = idroot->get("LIB",0);
1116#  endif /* HAVE_NAMESPACES */
1117  libstackv lp;
1118  char *f = NULL;
1119  if(hl!=NULL) f = strstr(IDSTRING(hl),libname);
1120  if( (hl==NULL) || (f == NULL))
1121  {
1122    for(lp = this;lp!=NULL;lp=lp->next)
1123    {
1124      if(strcmp(lp->get(), libname)==0) break;
1125    }
1126    if(lp==NULL)
1127    {
1128      libstackv ls = (libstack *)Alloc0(sizeof(libstack));
1129      ls->next = this;
1130      ls->libname = mstrdup(libname);
1131      ls->to_be_done = TRUE;
1132      if(this != NULL) ls->cnt = this->cnt+1; else ls->cnt = 0;
1133      library_stack = ls;
1134    }
1135  }
1136}
1137
1138libstackv libstack::pop(char *p)
1139{
1140  libstackv ls = this;
1141  //FreeL((ADDRESS)ls->libname);
1142  library_stack = ls->next;
1143  Free((ADDRESS)ls, sizeof(libstack));
1144  return(library_stack);
1145}
1146
1147#endif /* HAVE_LIBPARSER */
1148/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1149#ifndef HOWMANY
1150# define HOWMANY 8192           /* how much of the file to look at */
1151#endif
1152
1153lib_types type_of_LIB(char *newlib, char *libnamebuf)
1154{
1155  char        buf[HOWMANY+1];        /* one extra for terminating '\0' */
1156  struct stat sb;
1157  int nbytes = 0;
1158  int ret;
1159  lib_types LT=LT_NONE;
1160
1161  FILE * fp = feFopen( newlib, "r", libnamebuf, FALSE );
1162  ret = stat(libnamebuf, &sb);
1163
1164  if (fp==NULL)
1165  {
1166    return LT;
1167  }
1168  if((sb.st_mode & S_IFMT) != S_IFREG)
1169  {
1170    goto lib_type_end;
1171  }
1172  if ((nbytes = fread((char *)buf, sizeof(char), HOWMANY, fp)) == -1)
1173  {
1174    goto lib_type_end;
1175    /*NOTREACHED*/
1176  }
1177  if (nbytes == 0)
1178    goto lib_type_end;
1179  else
1180  {
1181    buf[nbytes++] = '\0';        /* null-terminate it */
1182  }
1183  if( (strncmp(buf, "\177ELF\01\01\01", 7)==0) && buf[16]=='\03')
1184  {
1185    LT = LT_ELF;
1186    FreeL(newlib);
1187    newlib = mstrdup(libnamebuf);
1188    goto lib_type_end;
1189  }
1190  if( (strncmp(buf, "\02\020\01\016\05\022@", 7)==0))
1191  {
1192    LT = LT_HPUX;
1193    FreeL(newlib);
1194    newlib = mstrdup(libnamebuf);
1195    goto lib_type_end;
1196  }
1197  if(isprint(buf[0]) || buf[0]=='\n')
1198  { LT = LT_SINGULAR; goto lib_type_end; }
1199
1200  lib_type_end:
1201  fclose(fp);
1202  return LT;
1203}
1204/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
Note: See TracBrowser for help on using the repository browser.