source: git/Singular/iplib.cc @ 7a9a32

fieker-DuValspielwiese
Last change on this file since 7a9a32 was 46d09b, checked in by Kai Krüger <krueger@…>, 26 years ago
Added developpement for Namespaces. Need to define HAVE_NAMESPACES first to activate it. git-svn-id: file:///usr/local/Singular/svn/trunk@2138 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 25.5 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4/* $Id: iplib.cc,v 1.30 1998-06-13 12:44:42 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    int i, offset=0;
143    long head = pi->data.s.def_end - pi->data.s.proc_start;
144    procbuflen = pi->data.s.help_end - pi->data.s.help_start;
145    //Print("Help=%ld-%ld=%d\n", pi->data.s.body_start,
146    //    pi->data.s.proc_start, procbuflen);
147    s = (char *)AllocL(procbuflen+head+3);
148    myfread(s, head, 1, fp);
149    s[head] = '\n';
150    fseek(fp, pi->data.s.help_start, SEEK_SET);
151    myfread(s+head+1, procbuflen, 1, fp);
152    s[procbuflen+head+1] = '\n';
153    s[procbuflen+head+2] = '\0';
154    offset=0;
155    for(i=0;i<=procbuflen+head+2; i++) {
156      if(s[i]=='\\' &&
157         (s[i+1]=='"' || s[i+1]=='{' || s[i+1]=='}' || s[i+1]=='\\')) {
158        i++;
159        offset++;
160      }
161      if(offset>0) s[i-offset] = s[i];
162    }
163    return(s);
164  }
165  if(part==1)
166  { // load proc part
167    procbuflen = pi->data.s.def_end - pi->data.s.proc_start;
168    //fgets(buf, sizeof(buf), fp);
169    myfread( buf, procbuflen, 1, fp);
170    char ct;
171    char *e;
172    s=iiProcName(buf,ct,e);
173    char *argstr=NULL;
174    *e=ct;
175    argstr=iiProcArgs(e,TRUE);
176    procbuflen = pi->data.s.body_end - pi->data.s.body_start;
177    pi->data.s.body = (char *)AllocL( strlen(argstr)+procbuflen+15+
178                                      strlen(pi->libname) );
179    //Print("Body=%ld-%ld=%d\n", pi->data.s.body_end,
180    //    pi->data.s.body_start, procbuflen);
181    if (pi->data.s.body==NULL)
182    {
183      Werror( "unable to allocate proc buffer `%s`", pi->procname );
184      return NULL;
185    }
186    fseek(fp, pi->data.s.body_start, SEEK_SET);
187    strcpy(pi->data.s.body,argstr);
188    myfread( pi->data.s.body+strlen(argstr), procbuflen, 1, fp);
189    procbuflen+=strlen(argstr);
190    FreeL(argstr);
191    fclose( fp );
192    pi->data.s.body[procbuflen] = '\0';
193    strcat( pi->data.s.body+procbuflen, "\n;return();\n\n" );
194    strcat( pi->data.s.body+procbuflen+13,pi->libname);
195    s=strchr(pi->data.s.body,'{');
196    if (s!=NULL) *s=' ';
197    return NULL;
198  }
199  if(part==2)
200  { // load example
201    fseek(fp, pi->data.s.example_start, SEEK_SET);
202    fgets(buf, sizeof(buf), fp);
203    procbuflen = pi->data.s.proc_end - pi->data.s.example_start - strlen(buf);
204    //Print("Example=%ld-%ld=%d\n", pi->data.s.proc_end,
205    //  pi->data.s.example_start, procbuflen);
206    s = (char *)AllocL(procbuflen+14);
207    myfread(s, procbuflen, 1, fp);
208    s[procbuflen] = '\0';
209    strcat(s+procbuflen-3, "\n;return();\n\n" );
210    p=strchr(s,'{');
211    if (p!=NULL) *p=' ';
212    return(s);
213  }
214  return NULL;
215}
216
217/*2
218* start a proc
219* parameters are built as exprlist
220* TODO:interrupt
221* return FALSE on success, TRUE if an error occurs
222*/
223BOOLEAN iiPStart(idhdl pn, sleftv  * v)
224{
225  char * str;
226  BOOLEAN err=FALSE;
227  int old_echo=si_echo;
228
229  /* init febase ======================================== */
230  /* we do not enter this case if filename != NULL !! */
231  if (pn!=NULL)
232  {
233    procinfov pi;
234    pi = IDPROC(pn);
235    if(pi!=NULL)
236    {
237      if( pi->data.s.body==NULL )
238      {
239        iiGetLibProcBuffer(IDPROC(pn));
240        if (IDPROC(pn)->data.s.body==NULL) return TRUE;
241      }
242      newBuffer( mstrdup(IDPROC(pn)->data.s.body), BT_proc,
243                 pi, IDPROC(pn)->data.s.body_lineno );
244    }
245    //else
246    //{ // for security only
247    //  newBuffer( mstrdup(IDSTRING(pn)), BT_proc, IDID(pn) );
248    //}
249  }
250  /* generate argument list ======================================*/
251  if (v!=NULL)
252  {
253    iiCurrArgs=(leftv)Alloc(sizeof(sleftv));
254    memcpy(iiCurrArgs,v,sizeof(sleftv));
255    memset(v,0,sizeof(sleftv));
256  }
257  else
258  {
259    iiCurrArgs=NULL;
260  }
261  /* start interpreter ======================================*/
262  myynest++;
263  //Print("%-*.*s PStart <<%s>>, level:%d\n",2*myynest,2*myynest," ",IDID(pn),myynest);
264  err=yyparse();
265  killlocals(myynest);
266  myynest--;
267  si_echo=old_echo;
268  //Print("%-*.*s PEnd  <<%s>>, level:%d\n",2*myynest,2*myynest," ",IDID(pn),myynest);
269
270  return err;
271}
272
273ring    *iiLocalRing
274#ifdef TEST
275                    =NULL
276#endif
277                   ;
278sleftv  *iiRETURNEXPR
279#ifdef TEST
280                    =NULL
281#endif
282                   ;
283int     iiRETURNEXPR_len=0;
284
285#ifdef RDEBUG
286static void iiShowLevRings()
287{
288  int i;
289  for (i=1;i<=myynest;i++)
290  {
291    Print("lev %d:",i);
292    if (iiLocalRing[i]==NULL) PrintS("NULL");
293    else                      Print("%d",iiLocalRing[i]);
294    Print("\n");
295  }
296  if (currRing==NULL) PrintS("curr:NULL\n");
297  else                Print ("curr:%d\n",currRing->no);
298}
299#endif
300
301static void iiCheckNest()
302{
303  if (myynest >= iiRETURNEXPR_len-1)
304  {
305    iiRETURNEXPR=(sleftv *)ReAlloc(iiRETURNEXPR,
306                                   iiRETURNEXPR_len*sizeof(sleftv),
307                                   (iiRETURNEXPR_len+16)*sizeof(sleftv));
308    iiLocalRing=(ring *)ReAlloc(iiLocalRing,
309                                   iiRETURNEXPR_len*sizeof(ring),
310                                   (iiRETURNEXPR_len+16)*sizeof(ring));
311    iiRETURNEXPR_len+=16;
312  }
313}
314sleftv * iiMake_proc(idhdl pn, sleftv* sl)
315{
316  int err;
317  procinfov pi = IDPROC(pn);
318#ifdef HAVE_NAMESPACES
319  char *plib = iiConvName(pi->libname);
320  idhdl ns = namespaceroot->get(plib,0, TRUE);
321  FreeL(plib);
322  if(ns != NULL) {
323    namespaceroot->push(IDPACKAGE(ns), IDID(ns));
324    //printf("iiMake_proc: namespace found.\n");
325  } else {
326    namespaceroot->push(namespaceroot->root->pack, "toplevel");
327    //printf("iiMake_proc: staying in TOP-LEVEL\n");
328  }
329#else /* HAVE_NAMESPACES */
330  if(pi->is_static && myynest==0) {
331    Werror("'%s::%s()' is a local procedure and cannot be accessed by an user.",
332           pi->libname, pi->procname);
333    return NULL;
334  }
335#endif /* HAVE_NAMESPACES */
336  iiCheckNest();
337  iiLocalRing[myynest]=currRing;
338  iiRETURNEXPR[myynest+1].Init();
339  if (traceit&TRACE_SHOW_PROC)
340  {
341    if (traceit&TRACE_SHOW_LINENO) PrintLn();
342    Print("entering%-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
343  }
344#ifdef RDEBUG
345  if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
346#endif
347#if 1
348  if(pi->language == LANG_SINGULAR) err=iiPStart(pn,sl);
349  if(pi->language == LANG_C)
350  {
351    leftv res = (leftv)Alloc0(sizeof(sleftv));
352    res->rtyp=NONE;
353    err = (pi->data.o.function)(res, sl);
354    iiRETURNEXPR[myynest+1].Copy(res);
355    Free((ADDRESS)res, sizeof(sleftv));
356  }
357#else
358  switch (pi->language)
359  {
360    case LANG_SINGULAR: err=iiPStart(pn,sl); break;
361    case LANG_C: leftv res = (leftv)Alloc0(sizeof(sleftv));
362      err = (pi->data.o.function)(res, sl);
363      iiRETURNEXPR[myynest+1].Copy(res);
364      Free((ADDRESS)res, sizeof(sleftv));
365      break;
366    default: err=TRUE;
367  }
368#endif
369  if (traceit&TRACE_SHOW_PROC)
370  {
371    if (traceit&TRACE_SHOW_LINENO) PrintLn();
372    Print("leaving %-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
373  }
374#ifdef RDEBUG
375  if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
376#endif
377  if (err)
378  {
379    iiRETURNEXPR[myynest+1].CleanUp();
380    iiRETURNEXPR[myynest+1].Init();
381  }
382  if (iiLocalRing[myynest] != currRing)
383  {
384    if (((iiRETURNEXPR[myynest+1].Typ()>BEGIN_RING)
385      && (iiRETURNEXPR[myynest+1].Typ()<END_RING))
386    || ((iiRETURNEXPR[myynest+1].Typ()==LIST_CMD)
387      && (lRingDependend((lists)iiRETURNEXPR[myynest+1].Data()))))
388    {
389      //idhdl hn;
390      char *n;
391      char *o;
392      if (iiLocalRing[myynest]!=NULL) o=rFindHdl(iiLocalRing[myynest],NULL)->id;
393      else                            o="none";
394      if (currRing!=NULL)             n=rFindHdl(currRing,NULL)->id;
395      else                            n="none";
396      Werror("ring change during procedure call: %s -> %s",o,n);
397      iiRETURNEXPR[myynest+1].CleanUp();
398      err=TRUE;
399    }
400    if (iiLocalRing[myynest]!=NULL)
401    {
402      rSetHdl(rFindHdl(iiLocalRing[myynest],NULL),TRUE);
403      iiLocalRing[myynest]=NULL;
404    }
405    else
406    { currRingHdl=NULL; currRing=NULL; }
407  }
408  if (iiCurrArgs!=NULL)
409  {
410    Warn("too many arguments for %s",IDID(pn));
411    iiCurrArgs->CleanUp();
412    Free((ADDRESS)iiCurrArgs,sizeof(sleftv));
413    iiCurrArgs=NULL;
414  }
415#ifdef HAVE_NAMESPACES
416  namespaceroot->pop();
417#endif /* HAVE_NAMESPACES */
418  if (err) return NULL;
419  return &iiRETURNEXPR[myynest+1];
420}
421
422/*2
423* start an example (as a proc),
424* destroys the string 'example'
425*/
426BOOLEAN iiEStart(char* example, procinfo *pi)
427{
428  BOOLEAN err;
429  int old_echo=si_echo;
430
431  newBuffer( example, BT_example, pi, pi->data.s.example_lineno );
432  iiCheckNest();
433  iiLocalRing[myynest]=currRing;
434  if (traceit&TRACE_SHOW_PROC)
435  {
436    if (traceit&TRACE_SHOW_LINENO) printf("\n");
437    printf("entering example (level %d)\n",myynest);
438  }
439  myynest++;
440  err=yyparse();
441  killlocals(myynest);
442  myynest--;
443  si_echo=old_echo;
444  if (traceit&TRACE_SHOW_PROC)
445  {
446    if (traceit&TRACE_SHOW_LINENO) printf("\n");
447    printf("leaving  -example- (level %d)\n",myynest);
448  }
449  if (iiLocalRing[myynest] != currRing)
450  {
451    if (iiLocalRing[myynest]!=NULL)
452    {
453      rSetHdl(rFindHdl(iiLocalRing[myynest],NULL),TRUE);
454      iiLocalRing[myynest]=NULL;
455    }
456    else
457    {
458      currRingHdl=NULL;
459      currRing=NULL;
460    }
461  }
462  return err;
463}
464
465/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
466BOOLEAN iiLibCmd( char *newlib, BOOLEAN tellerror )
467{
468  char buf[256];
469  char libnamebuf[128];
470  idhdl h,hl;
471#ifdef HAVE_NAMESPACES
472  idhdl pl;
473#endif /* HAVE_NAMESPACES */
474  int lines = 1;
475  long pos = 0L;
476  procinfov pi;
477#ifdef HAVE_NAMESPACES
478  char *plib = iiConvName(newlib);
479#endif /* HAVE_NAMESPACES */
480  FILE * fp = feFopen( newlib, "r", libnamebuf, tellerror );
481  if (fp==NULL)
482  {
483    return TRUE;
484  }
485#ifdef HAVE_NAMESPACES
486  hl = namespaceroot->get("LIB",0, TRUE);
487#else /* HAVE_NAMESPACES */
488  hl = idroot->get("LIB",0);
489#endif /* HAVE_NAMESPACES */
490  if (hl==NULL)
491  {
492#ifdef HAVE_NAMESPACES
493    hl = enterid( mstrdup("LIB"),0, STRING_CMD,
494                  &NSROOT(namespaceroot->root), FALSE );
495#else /* HAVE_NAMESPACES */
496    hl = enterid( mstrdup("LIB"),0, STRING_CMD, &idroot, FALSE );
497#endif /* HAVE_NAMESPACES */
498    IDSTRING(hl) = mstrdup(newlib);
499  }
500  else
501  {
502#ifdef TEST
503    if (IDSTRING(hl) != NULL)
504#endif
505    {
506      char *s = (char *)AllocL( strlen(newlib) + strlen(IDSTRING(hl)) + 2 );
507      strcpy(s,IDSTRING(hl));
508      BOOLEAN f=FALSE;
509      if(strchr(s,',')==NULL)
510      {
511        if (strcmp(s,newlib)==0)
512          f=TRUE;
513      }
514      else
515      {
516        char *p=strtok(s,",");
517        do
518        {
519          if(strcmp(p,newlib)==0)
520          {
521            f=TRUE;
522            break;
523          }
524          p=strtok(NULL,",");
525        } while (p!=NULL);
526      }
527      if (f)
528        FreeL(s);
529      else
530      {
531        sprintf( s, "%s,%s", IDSTRING(hl), newlib);
532        FreeL((ADDRESS)IDSTRING(hl));
533        IDSTRING(hl) = s;
534      }
535    }
536#ifdef TEST
537    else
538    {
539      PrintS("## empty LIB string\n");
540      IDSTRING(hl) = mstrdup(newlib);
541    }
542#endif
543  }
544#ifdef HAVE_NAMESPACES
545  pl = namespaceroot->get(plib,0, TRUE);
546  if (pl==NULL)
547  {
548    pl = enterid( mstrdup(plib),0, PACKAGE_CMD,
549                  &NSROOT(namespaceroot->root), TRUE );
550  } else {
551    Print("Found.\n");
552    if(IDTYP(pl)!=PACKAGE_CMD) Print("not of typ package.\n");
553  }
554  namespaceroot->push(IDPACKAGE(pl), IDID(pl));
555#endif /* HAVE_NAMESPACES */
556
557#ifdef HAVE_LIBPARSER
558  extern FILE *yylpin;
559  libstackv ls_start = library_stack;
560  lib_style_types lib_style;
561
562  yylpin = fp;
563# if YYLPDEBUG > 1
564  print_init();
565#  endif
566//  if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loading %s...", libnamebuf);
567  extern int lpverbose;
568  if (BVERBOSE(V_DEBUG_LIB)) lpverbose=1; else lpverbose=0;
569# ifdef HAVE_NAMESPACES
570   yylplex(newlib, libnamebuf, &lib_style, pl);
571# else /* HAVE_NAMESPACES */
572  yylplex(newlib, libnamebuf, &lib_style);
573# endif /* HAVE_NAMESPACES */
574  if(yylp_errno) {
575    Werror("Library %s: ERROR occured: in line %d, %d.", newlib, yylplineno,
576         current_pos(0));
577    if(yylp_errno==YYLP_BAD_CHAR) {
578      Werror(yylp_errlist[yylp_errno], *text_buffer, yylplineno);
579      FreeL(text_buffer);
580    } else
581      Werror(yylp_errlist[yylp_errno], yylplineno);
582    Werror("Cannot load library,... aborting.");
583    reinit_yylp();
584    fclose( yylpin );
585    FreeL((ADDRESS)newlib);
586    return TRUE;
587  }
588  if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s %s\n", libnamebuf,
589                                   text_buffer);
590  if( (lib_style == OLD_LIBSTYLE) && (BVERBOSE(V_LOAD_LIB))) {
591    Warn( "library %s has old format. This format is still accepted,", newlib);
592    Warn( "but for functionality you may wish to change to the new");
593    Warn( "format. Please refer to the manual for further information.");
594  } // else {
595//     if (BVERBOSE(V_LOAD_LIB)) Print("\n");
596//   }
597  reinit_yylp();
598  fclose( yylpin );
599#ifdef HAVE_NAMESPACES
600   namespaceroot->pop();
601#endif /* HAVE_NAMESPACES */
602  {
603    libstackv ls;
604    for(ls = library_stack; (ls != NULL) && (ls != ls_start); ) {
605      if(ls->to_be_done) {
606        //Print("// Processing id %d LIB:%s\n", ls->cnt, ls->get());
607        ls->to_be_done=FALSE;
608        iiLibCmd(ls->get());
609        ls = ls->pop(newlib);
610        //Print("Done\n");
611      }
612    }
613#if 0
614    Print("--------------------\n");
615    for(ls = library_stack; ls != NULL; ls = ls->next) {
616      Print("%s: LIB-stack:(%d), %s %s\n", newlib, ls->cnt, ls->get(),
617        ls->to_be_done ? "not loaded" : "loaded");
618    }
619    Print("--------------------\n");
620#endif
621  }
622#else /* HAVE_LIBPARSER */
623  // processing head section
624  if (fgets( buf, sizeof(buf), fp))
625  {
626    if (BVERBOSE(V_LOAD_LIB))
627    {
628      if (strncmp( buf, "// $Id", 5) == 0)
629      {
630        char ver[10];
631        char date[16];
632        ver[0]='?'; ver[1]='.'; ver[2]='?'; ver[3]='\0';
633        date[0]='?'; date[1]='\0';
634        sscanf(buf,"// %*s %*s %10s %16s",ver,date);
635        strcat(libnamebuf,"(");
636        strcat(libnamebuf,ver);
637        strcat(libnamebuf,",");
638        strcat(libnamebuf,date);
639        strcat(libnamebuf,")");
640      }
641      else
642      {
643        strcat(libnamebuf,"(**unknown version**)");
644      }
645      Warn( "loading %s", libnamebuf );
646    }
647  }
648
649  #define IN_HEADER 1
650  #define IN_BODY   2
651  #define IN_EXAMPLE      3
652  #define IN_EXAMPLE_BODY 4
653  #define IN_LIB_HEADER   5
654  int v=-1,otherLines=0,inBlock=IN_LIB_HEADER;
655  do /*while (fgets( buf, sizeof(buf), fp))*/
656  {
657    int  offset;
658    if (buf[0]!='\n')
659    {
660      if ((inBlock==0)||(inBlock==IN_LIB_HEADER))
661      {
662        if (strncmp( buf, "LIB ", 4) == 0)
663        {
664          char *s=buf+5;
665          char *f=strchr(s,'"');
666          if (f!=NULL)
667            *f='\0';
668          else
669            return TRUE;
670          // if (BVERBOSE(V_LOAD_LIB)) Print("// requires %s",s);
671          f=strstr(IDSTRING(hl),s);
672          if (f == NULL)
673          {
674            // if (BVERBOSE(V_LOAD_LIB)) PrintLn();
675            iiLibCmd(mstrdup(s));
676            // if (BVERBOSE(V_LOAD_LIB)) Print( "// loading %s\n", newlib);
677          }
678          //else if (BVERBOSE(V_LOAD_LIB)) PrintS(" -> already loaded\n");
679        }
680        else if (strncmp( buf, "proc ", 5) == 0)
681        {
682          char proc[256];
683          char ct1, *e;
684          sscanf( buf, "proc %s", proc);
685          offset = 2;
686          char *ct=strchr(proc,'(');
687          if (ct!=NULL) { *ct='\0'; offset=3; }
688          sprintf( buf, "LIB:%s", newlib);
689#if 0
690          if(strcmp(proc, "_init")==0)
691          {
692            char *p =  iiConvName(newlib);
693            Print("Init found:%s;\n", p);
694#ifdef HAVE_NAMESPACES
695             h = enterid( mstrdup(p), myynest, PROC_CMD, IDPACKAGE(pl), FALSE );
696#else /* HAVE_NAMESPACES */
697             h = enterid( mstrdup(p), myynest, PROC_CMD, &idroot, FALSE );
698#endif /* HAVE_NAMESPACES */
699            FreeL((ADDRESS)p);
700          } else
701#endif
702#ifdef HAVE_NAMESPACES
703            h = enterid(mstrdup(proc), myynest, PROC_CMD,
704                      &IDPACKAGE(pl)->idroot, FALSE);
705#else /* HAVE_NAMESPACES */
706            h = enterid( mstrdup(proc), myynest, PROC_CMD, &idroot, FALSE);
707#endif /* HAVE_NAMESPACES */
708          if (h!=NULL)
709          {
710            iiInitSingularProcinfo(IDPROC(h),newlib,proc,lines,pos);
711            if (BVERBOSE(V_LOAD_PROC)) Warn( "     proc %s loaded", proc );
712          }
713          inBlock=IN_HEADER;
714        }
715        else if (strncmp( buf, "// ver:", 7) == 0)
716        {
717          v=0;
718          sscanf( buf+7, "%d", &v);
719          if(v!=(SINGULAR_VERSION/100))
720            Warn("version mismatch - library `%s` requires:%d.%d",
721                  newlib,v/1000,(v%1000)/100);
722        }
723        else if (strncmp( buf, "example", 7) == 0)
724        {
725          IDPROC(h)->data.s.example_start = pos;
726          IDPROC(h)->data.s.example_lineno = lines;
727          inBlock=IN_EXAMPLE;
728        }
729        else if (strncmp( buf, "//", 2) != 0)
730        {
731          if (inBlock==0)
732          {
733            otherLines++;
734          }
735        }
736      }
737      else if ((inBlock==IN_HEADER) || (inBlock==IN_EXAMPLE))
738      {
739        if (buf[0]=='{')
740        {
741          if(inBlock==IN_HEADER)
742          {
743            IDPROC(h)->data.s.body_start = pos;
744            IDPROC(h)->data.s.body_lineno = lines-offset;
745            // Print("%s: %d-%d\n", pi->procname, lines, offset);
746          }
747          inBlock=IN_BODY;
748        }
749      }
750      else if ((inBlock==IN_BODY) || (inBlock==IN_EXAMPLE_BODY))
751      {
752        if (buf[0]=='}')
753        {
754          if(IDPROC(h)->data.s.example_start==0)
755            IDPROC(h)->data.s.example_start=pos;
756          if(IDPROC(h)->data.s.body_end==0) IDPROC(h)->data.s.body_end=pos;
757          IDPROC(h)->data.s.proc_end = pos;
758          inBlock=0;
759        }
760      }
761    }
762    lines++;
763    pos = ftell(fp);
764  } while (fgets( buf, sizeof(buf), fp));
765  fclose( fp );
766#ifdef HAVE_NAMESPACES
767  namespaceroot->pop();
768#endif /* HAVE_NAMESPACES */
769
770  //if (h!=NULL) IDPROC(h) = pi;
771  if (BVERBOSE(V_DEBUG_LIB))
772  {
773    if (inBlock!=0)
774      Warn("LIB `%s` ends within block",newlib);
775    if (otherLines!=0)
776      Warn("%d lines not recognised in LIB `%s`",otherLines,newlib);
777    if(v==-1)
778      Warn("LIB `%s` has no version flag",newlib);
779  }
780#endif /* HAVE_LIBPARSER */
781  FreeL((ADDRESS)newlib);
782#ifdef HAVE_NAMESPACES
783   FreeL((ADDRESS)plib);
784#endif /* HAVE_LIBPARSER */
785  return FALSE;
786}
787
788/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
789procinfo *iiInitSingularProcinfo(procinfov pi, char *libname, char *procname,
790                                 int line, long pos, BOOLEAN pstatic)
791{
792  pi->libname = mstrdup(libname);
793
794  if( strcmp(procname,"_init")==0)
795  {
796    char *p = iiConvName(libname);
797    pi->procname = mstrdup(p);
798    FreeL((ADDRESS)p);
799  } else pi->procname = mstrdup(procname);
800  pi->language = LANG_SINGULAR;
801  pi->ref = 1;
802  pi->is_static = pstatic;
803  pi->data.s.proc_start = pos;
804  pi->data.s.def_end    = 0L;
805  pi->data.s.help_start = 0L;
806  pi->data.s.help_end   = 0L;
807  pi->data.s.body_start = 0L;
808  pi->data.s.body_end   = 0L;
809  pi->data.s.example_start = 0L;
810  pi->data.s.proc_lineno = line;
811  pi->data.s.body_lineno = 0;
812  pi->data.s.example_lineno = 0;
813  pi->data.s.body = NULL;
814  return(pi);
815}
816
817#ifdef HAVE_DYNAMIC_LOADING
818/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
819int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
820               BOOLEAN(*func)(leftv res, leftv v))
821{
822  procinfov pi;
823  idhdl h;
824
825  h = enterid(mstrdup(procname),0, PROC_CMD, &IDROOT, FALSE);
826  if ( h!= NULL ) {
827    Print("register binary proc: %s::%s\n", libname, procname);
828    pi = IDPROC(h);
829    pi->libname = mstrdup(libname);
830    pi->procname = mstrdup(procname);
831    pi->language = LANG_C;
832    pi->ref = 1;
833    pi->is_static = pstatic;
834    pi->data.o.function = func;
835    return(1);
836  } else {
837    Print("iiAddCproc: failed.\n");
838  }
839  return(0);
840}
841#endif /* HAVE_DYNAMIC_LOADING */
842
843/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
844char *iiConvName(char *libname)
845{
846  int l=strlen(libname)+7;
847  char *p = (char *)AllocL(l);
848  char *r;
849
850  memset(p,0,l);
851  //sprintf(p, "%s_init", libname);
852  sprintf(p, "%s", libname);
853  for(r=p; *r!='\0'; r++)
854  {
855    if(*r=='.') *r='_';
856    if(*r==':') *r='_';
857  }
858  return(p);
859}
860
861/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
862void piShowProcList()
863{
864  idhdl h;
865#ifdef HAVE_NAMESPACES
866  idhdl pl;
867#endif /* HAVE_NAMESPACES */
868  procinfo *proc;
869  char *name;
870
871  Print( "%-15s  %20s      %s,%s  %s,%s   %s,%s\n", "Library", "function",
872         "line", "start", "line", "body", "line", "example");
873#ifdef HAVE_NAMESPACES
874  for(pl = IDROOT; pl != NULL; pl = IDNEXT(pl)) {
875    if(IDTYP(pl) == PACKAGE_CMD) {
876      for(h = IDPACKAGE(pl)->idroot; h != NULL; h = IDNEXT(h))
877#else /* HAVE_NAMESPACES */
878  for(h = IDROOT; h != NULL; h = IDNEXT(h))
879#endif /* HAVE_NAMESPACES */
880  {
881    if(IDTYP(h) == PROC_CMD)
882    {
883      proc = IDPROC(h);
884      if(strcmp(proc->procname, IDID(h))!=0)
885      {
886        name = (char *)AllocL(strlen(IDID(h))+strlen(proc->procname)+4);
887        sprintf(name, "%s -> %s", IDID(h), proc->procname);
888        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname, name);
889        FreeL(name);
890      }
891      else
892        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname,
893               proc->procname);
894      if(proc->language==LANG_SINGULAR)
895        Print("line %4d,%-5ld  %4d,%-5ld  %4d,%-5ld\n",
896              proc->data.s.proc_lineno, proc->data.s.proc_start,
897              proc->data.s.body_lineno, proc->data.s.body_start,
898              proc->data.s.example_lineno, proc->data.s.example_start);
899      else if(proc->language==LANG_C)
900        Print("type: object\n");
901#ifdef HAVE_NAMESPACES
902          }
903      }
904#endif /* HAVE_NAMESPACES */
905    }
906  }
907}
908
909/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
910//char *iiLineNo(char *procname, int lineno)
911//{
912//  char buf[256];
913//  idhdl pn = ggetid(procname);
914//  procinfo *pi = IDPROC(pn);
915//
916//  sprintf(buf, "%s %3d\0", procname, lineno);
917//  //sprintf(buf, "%s::%s %3d\0", pi->libname, pi->procname,
918//  //  lineno + pi->data.s.body_lineno);
919//  return(buf);
920//}
921/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
922#ifdef HAVE_LIBPARSER
923void libstack::push(char *p, char *libname)
924{
925#  ifdef HAVE_NAMESPACES
926  idhdl hl = namespaceroot->get("LIB",0, TRUE);
927#  else /* HAVE_NAMESPACES */
928  idhdl hl = idroot->get("LIB",0);
929#  endif /* HAVE_NAMESPACES */
930  libstackv lp;
931  char *f = NULL;
932  if(hl!=NULL) f = strstr(IDSTRING(hl),libname);
933  if( (hl==NULL) || (f == NULL)) {
934    for(lp = this;lp!=NULL;lp=lp->next) {
935      if(strcmp(lp->get(), libname)==0) break;
936    }
937    if(lp==NULL) {
938      libstackv ls = (libstack *)Alloc0(sizeof(libstack));
939      ls->next = this;
940      ls->libname = mstrdup(libname);
941      ls->to_be_done = TRUE;
942      if(this != NULL) ls->cnt = this->cnt+1; else ls->cnt = 0;
943      library_stack = ls;
944    }
945  }
946}
947
948libstackv libstack::pop(char *p)
949{
950  libstackv ls = this;
951  //FreeL(ls->libname);
952  library_stack = ls->next;
953  Free((ADDRESS)ls, sizeof(libstack));
954  return(library_stack);
955}
956
957#endif /* HAVE_LIBPARSER */
958/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
Note: See TracBrowser for help on using the repository browser.