source: git/Singular/iplib.cc @ 24c186a

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