source: git/Singular/iplib.cc @ 8d525d

spielwiese
Last change on this file since 8d525d was 799ce1, checked in by Kai Krüger <krueger@…>, 26 years ago
Modified Files: iplib.cc libparse.l mod2.h.in libparse.cc Changed output of 'loading libraries' enabled option(debugLib) git-svn-id: file:///usr/local/Singular/svn/trunk@1607 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 22.1 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: iplib.cc,v 1.23 1998-05-05 13:46:37 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
14#include "mod2.h"
15#include "tok.h"
16#include "ipid.h"
17#include "mmemory.h"
18#include "febase.h"
19#include "ring.h"
20#include "subexpr.h"
21#include "ipshell.h"
22#include "lists.h"
23#ifdef HAVE_LIBPARSER
24#  include "libparse.h"
25#else /* HAVE_LIBPARSER */
26   procinfo *iiInitSingularProcinfo(procinfov pi, char *libname,
27                                    char *procname, int line, long pos,
28                                    BOOLEAN pstatic = FALSE);
29#endif /* HAVE_LIBPARSER */
30
31char *iiConvName(char *p);
32#ifdef HAVE_LIBPARSER
33void yylprestart (FILE *input_file );
34int current_pos(int i=0);
35extern int yylp_errno;
36extern int yylplineno;
37extern char *yylp_errlist[];
38void print_init();
39libstackv library_stack;
40#endif
41
42/*2
43* find the library of an proc:
44*  => return (pi->libname)
45*/
46char * iiGetLibName(procinfov pi)
47{
48  char *res=NULL;
49
50  res = pi->libname;
51  return res;
52}
53/*2
54* given a line 'proc[ ]+{name}[ \t]*'
55* return a pointer to name and set the end of '\0'
56* changes the input!
57* returns: e: pointer to 'end of name'
58*          ct: changed char at the end of s
59*/
60char* iiProcName(char *buf, char & ct, char* &e)
61{
62  char *s=buf+5;
63  while (*s==' ') s++;
64  e=s+1;
65  while ((*e>' ') && (*e!='(')) e++;
66  ct=*e;
67  *e='\0';
68  return s;
69}
70
71/*2
72* given a line with args, return the argstr
73*/
74char * iiProcArgs(char *e,BOOLEAN withParenth)
75{
76  while ((*e==' ') || (*e=='\t') || (*e=='(')) e++;
77  if (*e<' ')
78  {
79    if (withParenth)
80    {
81      // no argument list, allow list #
82      return mstrdup("parameter list #;");
83    }
84    else
85    {
86      // empty list
87      return mstrdup("");
88    }
89  }
90  BOOLEAN in_args;
91  BOOLEAN args_found;
92  char *s;
93  char *argstr=(char *)AllocL(200);
94  *argstr='\0';
95  do
96  {
97    args_found=FALSE;
98    s=e; // set s to the starting point of the arg
99         // and search for the end
100    while ((*e!=',')&&(*e!=')')&&(*e!='\0'))
101    {
102      args_found=args_found || (*e>' ');
103      e++;
104    }
105    in_args=(*e==',');
106    if (args_found)
107    {
108      *e='\0';
109      // copy the result to argstr
110      strcat(argstr,"parameter ");
111      strcat(argstr,s);
112      strcat(argstr,"; ");
113      e++; // e was pointing to ','
114    }
115  } while (in_args);
116  return argstr;
117}
118
119/*2
120* locate `procname` in lib `libname` and find the part `part`:
121*  part=0: help, between, but excluding the line "proc ..." and "{...":
122*    => return
123*  part=1: body, between "{ ..." and "}", including the 1. line, w/o "{"
124*    => set pi->data.s.body, return NULL
125*  part=2: example, between, but excluding the line "exapmle {..." and "}":
126*    => return
127*/
128char* iiGetLibProcBuffer(procinfo *pi, int part )
129{
130  char buf[256], *s = NULL, *p;
131  long procbuflen;
132
133  FILE * fp = feFopen( pi->libname, "rb", NULL, TRUE );
134  if (fp==NULL)
135  {
136    return NULL;
137  }
138
139  fseek(fp, pi->data.s.proc_start, SEEK_SET);
140  if(part==0)
141  { // load help string
142    procbuflen = pi->data.s.body_start - pi->data.s.proc_start;
143    //Print("Help=%ld-%ld=%d\n", pi->data.s.body_start,
144    //    pi->data.s.proc_start, procbuflen);
145    s = (char *)AllocL(procbuflen);
146    myfread(s, procbuflen, 1, fp);
147    s[procbuflen] = '\0';
148    return(s);
149  }
150  if(part==1)
151  { // load proc part
152    procbuflen = pi->data.s.def_end - pi->data.s.proc_start;
153    //fgets(buf, sizeof(buf), fp);
154    myfread( buf, procbuflen, 1, fp);
155    char ct;
156    char *e;
157    s=iiProcName(buf,ct,e);
158    char *argstr=NULL;
159    *e=ct;
160    argstr=iiProcArgs(e,TRUE);
161    procbuflen = pi->data.s.body_end - pi->data.s.body_start;
162    pi->data.s.body = (char *)AllocL( strlen(argstr)+procbuflen+15+
163                                      strlen(pi->libname) );
164    //Print("Body=%ld-%ld=%d\n", pi->data.s.body_end,
165    //    pi->data.s.body_start, procbuflen);
166    if (pi->data.s.body==NULL)
167    {
168      Werror( "unable to allocate proc buffer `%s`", pi->procname );
169      return NULL;
170    }
171    fseek(fp, pi->data.s.body_start, SEEK_SET);
172    strcpy(pi->data.s.body,argstr);
173    myfread( pi->data.s.body+strlen(argstr), procbuflen, 1, fp);
174    procbuflen+=strlen(argstr);
175    FreeL(argstr);
176    fclose( fp );
177    pi->data.s.body[procbuflen] = '\0';
178    strcat( pi->data.s.body+procbuflen, "\n;return();\n\n" );
179    strcat( pi->data.s.body+procbuflen+13,pi->libname);
180    s=strchr(pi->data.s.body,'{');
181    if (s!=NULL) *s=' ';
182    return NULL;
183  }
184  if(part==2)
185  { // load example
186    fseek(fp, pi->data.s.example_start, SEEK_SET);
187    fgets(buf, sizeof(buf), fp);
188    procbuflen = pi->data.s.proc_end - pi->data.s.example_start - strlen(buf);
189    //Print("Example=%ld-%ld=%d\n", pi->data.s.proc_end,
190    //  pi->data.s.example_start, procbuflen);
191    s = (char *)AllocL(procbuflen+14);
192    myfread(s, procbuflen, 1, fp);
193    s[procbuflen] = '\0';
194    strcat(s+procbuflen-3, "\n;return();\n\n" );
195    p=strchr(s,'{');
196    if (p!=NULL) *p=' ';
197    return(s);
198  }
199  return NULL;
200}
201
202/*2
203* start a proc
204* parameters are built as exprlist
205* TODO:interrupt
206* return FALSE on success, TRUE if an error occurs
207*/
208BOOLEAN iiPStart(idhdl pn, sleftv  * v)
209{
210  char * str;
211  BOOLEAN err=FALSE;
212  int old_echo=si_echo;
213
214  /* init febase ======================================== */
215  /* we do not enter this case if filename != NULL !! */
216  if (pn!=NULL)
217  {
218    procinfov pi;
219    pi = IDPROC(pn);
220    if(pi!=NULL)
221    {
222      if( pi->data.s.body==NULL )
223      {
224        iiGetLibProcBuffer(IDPROC(pn));
225        if (IDPROC(pn)->data.s.body==NULL) return TRUE;
226      }
227      newBuffer( mstrdup(IDPROC(pn)->data.s.body), BT_proc,
228                 pi, IDPROC(pn)->data.s.body_lineno );
229    }
230    //else
231    //{ // for security only
232    //  newBuffer( mstrdup(IDSTRING(pn)), BT_proc, IDID(pn) );
233    //}
234  }
235  /* generate argument list ======================================*/
236  if (v!=NULL)
237  {
238    iiCurrArgs=(leftv)Alloc(sizeof(sleftv));
239    memcpy(iiCurrArgs,v,sizeof(sleftv));
240    memset(v,0,sizeof(sleftv));
241  }
242  else
243  {
244    iiCurrArgs=NULL;
245  }
246  /* start interpreter ======================================*/
247  myynest++;
248  //Print("%-*.*s PStart <<%s>>, level:%d\n",2*myynest,2*myynest," ",IDID(pn),myynest);
249  err=yyparse();
250  killlocals(myynest);
251  myynest--;
252  si_echo=old_echo;
253  //Print("%-*.*s PEnd  <<%s>>, level:%d\n",2*myynest,2*myynest," ",IDID(pn),myynest);
254
255  return err;
256}
257
258ring    *iiLocalRing
259#ifdef TEST
260                    =NULL
261#endif
262                   ;
263sleftv  *iiRETURNEXPR
264#ifdef TEST
265                    =NULL
266#endif
267                   ;
268int     iiRETURNEXPR_len=0;
269
270#ifdef RDEBUG
271static void iiShowLevRings()
272{
273  int i;
274  for (i=1;i<=myynest;i++)
275  {
276    Print("lev %d:",i);
277    if (iiLocalRing[i]==NULL) PrintS("NULL");
278    else                      Print("%d",iiLocalRing[i]);
279    Print("\n");
280  }
281  if (currRing==NULL) PrintS("curr:NULL\n");
282  else                Print ("curr:%d\n",currRing->no);
283}
284#endif
285
286static void iiCheckNest()
287{
288  if (myynest >= iiRETURNEXPR_len-1)
289  {
290    iiRETURNEXPR=(sleftv *)ReAlloc(iiRETURNEXPR,
291                                   iiRETURNEXPR_len*sizeof(sleftv),
292                                   (iiRETURNEXPR_len+16)*sizeof(sleftv));
293    iiLocalRing=(ring *)ReAlloc(iiLocalRing,
294                                   iiRETURNEXPR_len*sizeof(ring),
295                                   (iiRETURNEXPR_len+16)*sizeof(ring));
296    iiRETURNEXPR_len+=16;
297  }
298}
299sleftv * iiMake_proc(idhdl pn, sleftv* sl)
300{
301  int err;
302  procinfov pi = IDPROC(pn);
303  if(pi->is_static && myynest==0) {
304    Werror("'%s::%s()' is a local procedure and cannot be accessed by an user.",
305           pi->libname, pi->procname);
306    return NULL;
307  }
308  iiCheckNest();
309  iiLocalRing[myynest]=currRing;
310  iiRETURNEXPR[myynest+1].Init();
311  if (traceit&TRACE_SHOW_PROC)
312  {
313    if (traceit&TRACE_SHOW_LINENO) PrintLn();
314    Print("entering%-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
315  }
316#ifdef RDEBUG
317  if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
318#endif
319#if 1
320  if(pi->language == LANG_SINGULAR) err=iiPStart(pn,sl);
321  if(pi->language == LANG_C)
322  {
323    leftv res = (leftv)Alloc0(sizeof(sleftv));
324    res->rtyp=NONE;
325    err = (pi->data.o.function)(res, sl);
326    iiRETURNEXPR[myynest+1].Copy(res);
327    Free((ADDRESS)res, sizeof(sleftv));
328  }
329#else
330  switch (pi->language)
331  {
332    case LANG_SINGULAR: err=iiPStart(pn,sl); break;
333    case LANG_C: leftv res = (leftv)Alloc0(sizeof(sleftv));
334      err = (pi->data.o.function)(res, sl);
335      iiRETURNEXPR[myynest+1].Copy(res);
336      Free((ADDRESS)res, sizeof(sleftv));
337      break;
338    default: err=TRUE;
339  }
340#endif
341  if (traceit&TRACE_SHOW_PROC)
342  {
343    if (traceit&TRACE_SHOW_LINENO) PrintLn();
344    Print("leaving %-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
345  }
346#ifdef RDEBUG
347  if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
348#endif
349  if (err)
350  {
351    iiRETURNEXPR[myynest+1].CleanUp();
352    iiRETURNEXPR[myynest+1].Init();
353  }
354  if (iiLocalRing[myynest] != currRing)
355  {
356    if (((iiRETURNEXPR[myynest+1].Typ()>BEGIN_RING)
357      && (iiRETURNEXPR[myynest+1].Typ()<END_RING))
358    || ((iiRETURNEXPR[myynest+1].Typ()==LIST_CMD)
359      && (lRingDependend((lists)iiRETURNEXPR[myynest+1].Data()))))
360    {
361      //idhdl hn;
362      char *n;
363      char *o;
364      if (iiLocalRing[myynest]!=NULL) o=rFindHdl(iiLocalRing[myynest],NULL)->id;
365      else                            o="none";
366      if (currRing!=NULL)             n=rFindHdl(currRing,NULL)->id;
367      else                            n="none";
368      Werror("ring change during procedure call: %s -> %s",o,n);
369      iiRETURNEXPR[myynest+1].CleanUp();
370      err=TRUE;
371    }
372    if (iiLocalRing[myynest]!=NULL)
373    {
374      rSetHdl(rFindHdl(iiLocalRing[myynest],NULL),TRUE);
375      iiLocalRing[myynest]=NULL;
376    }
377    else
378    { currRingHdl=NULL; currRing=NULL; }
379  }
380  if (iiCurrArgs!=NULL)
381  {
382    Warn("too many arguments for %s",IDID(pn));
383    iiCurrArgs->CleanUp();
384    Free((ADDRESS)iiCurrArgs,sizeof(sleftv));
385    iiCurrArgs=NULL;
386  }
387  if (err) return NULL;
388  return &iiRETURNEXPR[myynest+1];
389}
390
391/*2
392* start an example (as a proc),
393* destroys the string 'example'
394*/
395BOOLEAN iiEStart(char* example, procinfo *pi)
396{
397  BOOLEAN err;
398  int old_echo=si_echo;
399
400  newBuffer( example, BT_example, pi, pi->data.s.example_lineno );
401  iiCheckNest();
402  iiLocalRing[myynest]=currRing;
403  if (traceit&TRACE_SHOW_PROC)
404  {
405    if (traceit&TRACE_SHOW_LINENO) printf("\n");
406    printf("entering example (level %d)\n",myynest);
407  }
408  myynest++;
409  err=yyparse();
410  killlocals(myynest);
411  myynest--;
412  si_echo=old_echo;
413  if (traceit&TRACE_SHOW_PROC)
414  {
415    if (traceit&TRACE_SHOW_LINENO) printf("\n");
416    printf("leaving  -example- (level %d)\n",myynest);
417  }
418  if (iiLocalRing[myynest] != currRing)
419  {
420    if (iiLocalRing[myynest]!=NULL)
421    {
422      rSetHdl(rFindHdl(iiLocalRing[myynest],NULL),TRUE);
423      iiLocalRing[myynest]=NULL;
424    }
425    else
426    {
427      currRingHdl=NULL;
428      currRing=NULL;
429    }
430  }
431  return err;
432}
433
434/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
435BOOLEAN iiLibCmd( char *newlib, BOOLEAN tellerror )
436{
437  char buf[256];
438  char libnamebuf[128];
439  idhdl h,hl;
440  int lines = 1;
441  long pos = 0L;
442  procinfov pi;
443  FILE * fp = feFopen( newlib, "r", libnamebuf, tellerror );
444  if (fp==NULL)
445  {
446    return TRUE;
447  }
448  hl = idroot->get("LIB",0);
449  if (hl==NULL)
450  {
451    hl = enterid( mstrdup("LIB"),0, STRING_CMD, &idroot, FALSE );
452    IDSTRING(hl) = mstrdup(newlib);
453  }
454  else
455  {
456#ifdef TEST
457    if (IDSTRING(hl) != NULL)
458#endif
459    {
460      char *s = (char *)AllocL( strlen(newlib) + strlen(IDSTRING(hl)) + 2 );
461      strcpy(s,IDSTRING(hl));
462      BOOLEAN f=FALSE;
463      if(strchr(s,',')==NULL)
464      {
465        if (strcmp(s,newlib)==0)
466          f=TRUE;
467      }
468      else
469      {
470        char *p=strtok(s,",");
471        do
472        {
473          if(strcmp(p,newlib)==0)
474          {
475            f=TRUE;
476            break;
477          }
478          p=strtok(NULL,",");
479        } while (p!=NULL);
480      }
481      if (f)
482        FreeL(s);
483      else
484      {
485        sprintf( s, "%s,%s", IDSTRING(hl), newlib);
486        FreeL((ADDRESS)IDSTRING(hl));
487        IDSTRING(hl) = s;
488      }
489    }
490#ifdef TEST
491    else
492    {
493      PrintS("## empty LIB string\n");
494      IDSTRING(hl) = mstrdup(newlib);
495    }
496#endif
497  }
498
499#ifdef HAVE_LIBPARSER
500  extern FILE *yylpin;
501  libstackv ls_start = library_stack;
502  lib_style_types lib_style;
503
504  yylpin = fp;
505# if YYLPDEBUG > 1
506  print_init();
507#  endif
508//  if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loading %s...", libnamebuf);
509  extern int lpverbose;
510  if (BVERBOSE(V_DEBUG_LIB)) lpverbose=1; else lpverbose=0;
511  yylplex(newlib, libnamebuf, &lib_style);
512  if(yylp_errno) {
513    Werror("Library %s: ERROR occured: in line %d, %d.", newlib, yylplineno,
514         current_pos(0));
515    Werror(yylp_errlist[yylp_errno], yylplineno);
516    Werror("Cannot load library,... aborting.");
517    reinit_yylp();
518    fclose( yylpin );
519    FreeL((ADDRESS)newlib);
520    return TRUE;
521  }
522  if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s %s", libnamebuf,
523                                   text_buffer);
524  if( (lib_style == OLD_LIBSTYLE) && (BVERBOSE(V_LOAD_LIB)))
525    Warn( "library %s has an old format. Please fix it for the next time",
526          newlib);
527  else {
528    if (BVERBOSE(V_LOAD_LIB)) Print("\n");
529  }
530  reinit_yylp();
531  fclose( yylpin );
532  {
533    libstackv ls;
534    for(ls = library_stack; (ls != NULL) && (ls != ls_start); ) {
535      if(ls->to_be_done) {
536        //Print("// Processing id %d LIB:%s\n", ls->cnt, ls->get());
537        ls->to_be_done=FALSE;
538        iiLibCmd(ls->get());
539        ls = ls->pop(newlib);
540        //Print("Done\n");
541      }
542    }
543#if 0
544    Print("--------------------\n");
545    for(ls = library_stack; ls != NULL; ls = ls->next) {
546      Print("%s: LIB-stack:(%d), %s %s\n", newlib, ls->cnt, ls->get(),
547        ls->to_be_done ? "not loaded" : "loaded");
548    }
549    Print("--------------------\n");
550#endif
551  }
552#else /* HAVE_LIBPARSER */
553  // processing head section
554  if (fgets( buf, sizeof(buf), fp))
555  {
556    if (BVERBOSE(V_LOAD_LIB))
557    {
558      if (strncmp( buf, "// $Id", 5) == 0)
559      {
560        char ver[10];
561        char date[16];
562        ver[0]='?'; ver[1]='.'; ver[2]='?'; ver[3]='\0';
563        date[0]='?'; date[1]='\0';
564        sscanf(buf,"// %*s %*s %10s %16s",ver,date);
565        strcat(libnamebuf,"(");
566        strcat(libnamebuf,ver);
567        strcat(libnamebuf,",");
568        strcat(libnamebuf,date);
569        strcat(libnamebuf,")");
570      }
571      else
572      {
573        strcat(libnamebuf,"(**unknown version**)");
574      }
575      Warn( "loading %s", libnamebuf );
576    }
577  }
578
579  #define IN_HEADER 1
580  #define IN_BODY   2
581  #define IN_EXAMPLE      3
582  #define IN_EXAMPLE_BODY 4
583  #define IN_LIB_HEADER   5
584  int v=-1,otherLines=0,inBlock=IN_LIB_HEADER;
585  do /*while (fgets( buf, sizeof(buf), fp))*/
586  {
587    int  offset;
588    if (buf[0]!='\n')
589    {
590      if ((inBlock==0)||(inBlock==IN_LIB_HEADER))
591      {
592        if (strncmp( buf, "LIB ", 4) == 0)
593        {
594          char *s=buf+5;
595          char *f=strchr(s,'"');
596          if (f!=NULL)
597            *f='\0';
598          else
599            return TRUE;
600          // if (BVERBOSE(V_LOAD_LIB)) Print("// requires %s",s);
601          f=strstr(IDSTRING(hl),s);
602          if (f == NULL)
603          {
604            // if (BVERBOSE(V_LOAD_LIB)) PrintLn();
605            iiLibCmd(mstrdup(s));
606            // if (BVERBOSE(V_LOAD_LIB)) Print( "// loading %s\n", newlib);
607          }
608          //else if (BVERBOSE(V_LOAD_LIB)) PrintS(" -> already loaded\n");
609        }
610        else if (strncmp( buf, "proc ", 5) == 0)
611        {
612          char proc[256];
613          char ct1, *e;
614          sscanf( buf, "proc %s", proc);
615          offset = 2;
616          char *ct=strchr(proc,'(');
617          if (ct!=NULL) { *ct='\0'; offset=3; }
618          sprintf( buf, "LIB:%s", newlib);
619#if 0
620          if(strcmp(proc, "_init")==0)
621          {
622            char *p =  iiConvName(newlib);
623            Print("Init found:%s;\n", p);
624            h = enterid( mstrdup(p), myynest, PROC_CMD, &idroot, FALSE );
625            FreeL((ADDRESS)p);
626          } else
627#endif
628            h = enterid( mstrdup(proc), myynest, PROC_CMD, &idroot, FALSE );
629          if (h!=NULL)
630          {
631            iiInitSingularProcinfo(IDPROC(h),newlib,proc,lines,pos);
632            if (BVERBOSE(V_LOAD_PROC)) Warn( "     proc %s loaded", proc );
633          }
634          inBlock=IN_HEADER;
635        }
636        else if (strncmp( buf, "// ver:", 7) == 0)
637        {
638          v=0;
639          sscanf( buf+7, "%d", &v);
640          if(v!=(SINGULAR_VERSION/100))
641            Warn("version mismatch - library `%s` requires:%d.%d",
642                  newlib,v/1000,(v%1000)/100);
643        }
644        else if (strncmp( buf, "example", 7) == 0)
645        {
646          IDPROC(h)->data.s.example_start = pos;
647          IDPROC(h)->data.s.example_lineno = lines;
648          inBlock=IN_EXAMPLE;
649        }
650        else if (strncmp( buf, "//", 2) != 0)
651        {
652          if (inBlock==0)
653          {
654            otherLines++;
655          }
656        }
657      }
658      else if ((inBlock==IN_HEADER) || (inBlock==IN_EXAMPLE))
659      {
660        if (buf[0]=='{')
661        {
662          if(inBlock==IN_HEADER)
663          {
664            IDPROC(h)->data.s.body_start = pos;
665            IDPROC(h)->data.s.body_lineno = lines-offset;
666            // Print("%s: %d-%d\n", pi->procname, lines, offset);
667          }
668          inBlock=IN_BODY;
669        }
670      }
671      else if ((inBlock==IN_BODY) || (inBlock==IN_EXAMPLE_BODY))
672      {
673        if (buf[0]=='}')
674        {
675          if(IDPROC(h)->data.s.example_start==0)
676            IDPROC(h)->data.s.example_start=pos;
677          if(IDPROC(h)->data.s.body_end==0) IDPROC(h)->data.s.body_end=pos;
678          IDPROC(h)->data.s.proc_end = pos;
679          inBlock=0;
680        }
681      }
682    }
683    lines++;
684    pos = ftell(fp);
685  } while (fgets( buf, sizeof(buf), fp));
686  fclose( fp );
687
688  //if (h!=NULL) IDPROC(h) = pi;
689  if (BVERBOSE(V_DEBUG_LIB))
690  {
691    if (inBlock!=0)
692      Warn("LIB `%s` ends within block",newlib);
693    if (otherLines!=0)
694      Warn("%d lines not recognised in LIB `%s`",otherLines,newlib);
695    if(v==-1)
696      Warn("LIB `%s` has no version flag",newlib);
697  }
698#endif /* HAVE_LIBPARSER */
699  FreeL((ADDRESS)newlib);
700  return FALSE;
701}
702
703/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
704procinfo *iiInitSingularProcinfo(procinfov pi, char *libname, char *procname,
705                                 int line, long pos, BOOLEAN pstatic)
706{
707  pi->libname = mstrdup(libname);
708
709  if( strcmp(procname,"_init")==0)
710  {
711    char *p = iiConvName(libname);
712    pi->procname = mstrdup(p);
713    FreeL((ADDRESS)p);
714  } else pi->procname = mstrdup(procname);
715  pi->language = LANG_SINGULAR;
716  pi->ref = 1;
717  pi->is_static = pstatic;
718  pi->data.s.proc_start = pos;
719  pi->data.s.help_start = 0L;
720  pi->data.s.body_start = 0L;
721  pi->data.s.body_end   = 0L;
722  pi->data.s.example_start = 0L;
723  pi->data.s.proc_lineno = line;
724  pi->data.s.body_lineno = 0;
725  pi->data.s.example_lineno = 0;
726  pi->data.s.body = NULL;
727  return(pi);
728}
729
730#ifdef HAVE_DYNAMIC_LOADING
731/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
732int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
733               BOOLEAN(*func)(leftv res, leftv v))
734{
735  procinfov pi;
736  idhdl h;
737
738  h = enterid(mstrdup(procname),0, PROC_CMD, &idroot, FALSE);
739  if ( h!= NULL ) {
740    Print("register binary proc: %s::%s\n", libname, procname);
741    pi = IDPROC(h);
742    pi->libname = mstrdup(libname);
743    pi->procname = mstrdup(procname);
744    pi->language = LANG_C;
745    pi->ref = 1;
746    pi->is_static = pstatic;
747    pi->data.o.function = func;
748    return(1);
749  } else {
750    Print("iiAddCproc: failed.\n");
751  }
752  return(0);
753}
754#endif /* HAVE_DYNAMIC_LOADING */
755
756/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
757char *iiConvName(char *libname)
758{
759  char *p = (char *)AllocL(strlen(libname)+7);
760  char *q = mstrdup(libname);
761  char *r = q;
762  for(; *r!='\0'; r++)
763  {
764    if(*r=='.') *r='_';
765    if(*r==':') *r='_';
766  }
767  sprintf(p, "%s_init\0", q);
768  FreeL((ADDRESS)q);
769  return(p);
770}
771
772/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
773void piShowProcList()
774{
775  idhdl h;
776  procinfo *proc;
777  char *name;
778
779  Print( "%-15s  %20s      %s,%s  %s,%s   %s,%s\n", "Library", "function",
780         "line", "start", "line", "body", "line", "example");
781  for(h = idroot; h != NULL; h = IDNEXT(h))
782  {
783    if(IDTYP(h) == PROC_CMD)
784    {
785      proc = IDPROC(h);
786      if(strcmp(proc->procname, IDID(h))!=0)
787      {
788        name = (char *)AllocL(strlen(IDID(h))+strlen(proc->procname)+4);
789        sprintf(name, "%s -> %s", IDID(h), proc->procname);
790        Print( "%-15s  %20s ", proc->libname, name);
791        FreeL(name);
792      }
793      else
794        Print( "%-15s  %20s ", proc->libname, proc->procname);
795      if(proc->language==LANG_SINGULAR)
796        Print("line %4d,%-5ld  %4d,%-5ld  %4d,%-5ld\n",
797              proc->data.s.proc_lineno, proc->data.s.proc_start,
798              proc->data.s.body_lineno, proc->data.s.body_start,
799              proc->data.s.example_lineno, proc->data.s.example_start);
800      else if(proc->language==LANG_C)
801        Print("type: object\n");
802
803    }
804  }
805}
806
807/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
808//char *iiLineNo(char *procname, int lineno)
809//{
810//  char buf[256];
811//  idhdl pn = ggetid(procname);
812//  procinfo *pi = IDPROC(pn);
813//
814//  sprintf(buf, "%s %3d\0", procname, lineno);
815//  //sprintf(buf, "%s::%s %3d\0", pi->libname, pi->procname,
816//  //  lineno + pi->data.s.body_lineno);
817//  return(buf);
818//}
819/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
820#ifdef HAVE_LIBPARSER
821void libstack::push(char *p, char *libname)
822{
823  idhdl hl = idroot->get("LIB",0);
824  libstackv lp;
825  char *f = NULL;
826  if(hl!=NULL) f = strstr(IDSTRING(hl),libname);
827  if( (hl==NULL) || (f == NULL)) {
828    for(lp = this;lp!=NULL;lp=lp->next) {
829      if(strcmp(lp->get(), libname)==0) break;
830    }
831    if(lp==NULL) {
832      libstackv ls = (libstack *)Alloc0(sizeof(libstack));
833      ls->next = this;
834      ls->libname = mstrdup(libname);
835      ls->to_be_done = TRUE;
836      if(this != NULL) ls->cnt = this->cnt+1; else ls->cnt = 0;
837      library_stack = ls;
838    }
839  }
840}
841
842libstackv libstack::pop(char *p)
843{
844  libstackv ls = this;
845  //FreeL(ls->libname);
846  library_stack = ls->next;
847  Free((ADDRESS)ls, sizeof(libstack));
848  return(library_stack);
849}
850
851#endif /* HAVE_LIBPARSER */
852/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
Note: See TracBrowser for help on using the repository browser.