source: git/Singular/iplib.cc @ daeb6d

spielwiese
Last change on this file since daeb6d was daeb6d, checked in by Kai Krüger <krueger@…>, 26 years ago
tesths.cc subexpr.h subexpr.cc ipshell.h ipshell.cc iplib.cc ipid.h ipid.cc ipassign.cc iparith.cc ChangeLog - Added assignment <package>=<package> via ref-counter rewriten killhdl for packages - Added libname,language to packages - exportto(Up,...) 'Up' defined in syMake - listvar() shows toplevel-packages too. git-svn-id: file:///usr/local/Singular/svn/trunk@2589 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.38 1998-10-22 12:26:12 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#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    IDPACKAGE(pl)->libname=mstrdup(newlib);
677  } else {
678    if(IDTYP(pl)!=PACKAGE_CMD) {
679      Warn("not of typ package.");
680      return TRUE;
681    }
682  }
683  namespaceroot->push(IDPACKAGE(pl), IDID(pl));
684#endif /* HAVE_NAMESPACES */
685
686#ifdef HAVE_LIBPARSER
687  extern FILE *yylpin;
688  libstackv ls_start = library_stack;
689  lib_style_types lib_style;
690
691  yylpin = fp;
692# if YYLPDEBUG > 1
693  print_init();
694#  endif
695  extern int lpverbose;
696  if (BVERBOSE(V_DEBUG_LIB)) lpverbose=1; else lpverbose=0;
697# ifdef HAVE_NAMESPACES
698   yylplex(newlib, libnamebuf, &lib_style, pl, autoexport);
699# else /* HAVE_NAMESPACES */
700  yylplex(newlib, libnamebuf, &lib_style);
701# endif /* HAVE_NAMESPACES */
702  if(yylp_errno) {
703    Werror("Library %s: ERROR occured: in line %d, %d.", newlib, yylplineno,
704         current_pos(0));
705    if(yylp_errno==YYLP_BAD_CHAR) {
706      Werror(yylp_errlist[yylp_errno], *text_buffer, yylplineno);
707      FreeL(text_buffer);
708    } else
709      Werror(yylp_errlist[yylp_errno], yylplineno);
710    Werror("Cannot load library,... aborting.");
711    reinit_yylp();
712    fclose( yylpin );
713    FreeL((ADDRESS)newlib);
714    return TRUE;
715  }
716  if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s %s\n", libnamebuf,
717                                   text_buffer);
718  if( (lib_style == OLD_LIBSTYLE) && (BVERBOSE(V_LOAD_LIB))) {
719    Warn( "library %s has old format. This format is still accepted,", newlib);
720    Warn( "but for functionality you may wish to change to the new");
721    Warn( "format. Please refer to the manual for further information.");
722  }
723  reinit_yylp();
724  fclose( yylpin );
725#ifdef HAVE_NAMESPACES
726   namespaceroot->pop();
727#endif /* HAVE_NAMESPACES */
728  {
729    libstackv ls;
730    for(ls = library_stack; (ls != NULL) && (ls != ls_start); ) {
731      if(ls->to_be_done) {
732        //Print("// Processing id %d LIB:%s\n", ls->cnt, ls->get());
733        ls->to_be_done=FALSE;
734#ifdef HAVE_NAMESPACES
735        iiLibCmd(ls->get(), autoexport);
736#else /* HAVE_NAMESPACES */
737        iiLibCmd(ls->get());
738#endif /* HAVE_NAMESPACES */
739        ls = ls->pop(newlib);
740        //Print("Done\n");
741      }
742    }
743#if 0
744    Print("--------------------\n");
745    for(ls = library_stack; ls != NULL; ls = ls->next) {
746      Print("%s: LIB-stack:(%d), %s %s\n", newlib, ls->cnt, ls->get(),
747        ls->to_be_done ? "not loaded" : "loaded");
748    }
749    Print("--------------------\n");
750#endif
751  }
752#else /* HAVE_LIBPARSER */
753  // processing head section
754  if (fgets( buf, sizeof(buf), fp))
755  {
756    if (BVERBOSE(V_LOAD_LIB))
757    {
758      if (strncmp( buf, "// $Id", 5) == 0)
759      {
760        char ver[10];
761        char date[16];
762        ver[0]='?'; ver[1]='.'; ver[2]='?'; ver[3]='\0';
763        date[0]='?'; date[1]='\0';
764        sscanf(buf,"// %*s %*s %10s %16s",ver,date);
765        strcat(libnamebuf,"(");
766        strcat(libnamebuf,ver);
767        strcat(libnamebuf,",");
768        strcat(libnamebuf,date);
769        strcat(libnamebuf,")");
770      }
771      else
772      {
773        strcat(libnamebuf,"(**unknown version**)");
774      }
775      Warn( "loading %s", libnamebuf );
776    }
777  }
778
779  #define IN_HEADER 1
780  #define IN_BODY   2
781  #define IN_EXAMPLE      3
782  #define IN_EXAMPLE_BODY 4
783  #define IN_LIB_HEADER   5
784  int v=-1,otherLines=0,inBlock=IN_LIB_HEADER;
785  do /*while (fgets( buf, sizeof(buf), fp))*/
786  {
787    int  offset;
788    if (buf[0]!='\n')
789    {
790      if ((inBlock==0)||(inBlock==IN_LIB_HEADER))
791      {
792        if (strncmp( buf, "LIB ", 4) == 0)
793        {
794          char *s=buf+5;
795          char *f=strchr(s,'"');
796          if (f!=NULL)
797            *f='\0';
798          else
799            return TRUE;
800          // if (BVERBOSE(V_LOAD_LIB)) Print("// requires %s",s);
801          f=strstr(IDSTRING(hl),s);
802          if (f == NULL)
803          {
804            // if (BVERBOSE(V_LOAD_LIB)) PrintLn();
805            iiLibCmd(mstrdup(s));
806            // if (BVERBOSE(V_LOAD_LIB)) Print( "// loading %s\n", newlib);
807          }
808          //else if (BVERBOSE(V_LOAD_LIB)) PrintS(" -> already loaded\n");
809        }
810        else if (strncmp( buf, "proc ", 5) == 0)
811        {
812          char proc[256];
813          char ct1, *e;
814          sscanf( buf, "proc %s", proc);
815          offset = 2;
816          char *ct=strchr(proc,'(');
817          if (ct!=NULL) { *ct='\0'; offset=3; }
818          sprintf( buf, "LIB:%s", newlib);
819#if 0
820          if(strcmp(proc, "_init")==0)
821          {
822            char *p =  iiConvName(newlib);
823            Print("Init found:%s;\n", p);
824#ifdef HAVE_NAMESPACES
825             h = enterid( mstrdup(p), myynest, PROC_CMD, IDPACKAGE(pl), FALSE );
826#else /* HAVE_NAMESPACES */
827             h = enterid( mstrdup(p), myynest, PROC_CMD, &idroot, FALSE );
828#endif /* HAVE_NAMESPACES */
829            FreeL((ADDRESS)p);
830          } else
831#endif
832#ifdef HAVE_NAMESPACES
833            h = enterid(mstrdup(proc), myynest, PROC_CMD,
834                      &IDPACKAGE(pl)->idroot, FALSE);
835#else /* HAVE_NAMESPACES */
836            h = enterid( mstrdup(proc), myynest, PROC_CMD, &idroot, FALSE);
837#endif /* HAVE_NAMESPACES */
838          if (h!=NULL)
839          {
840            iiInitSingularProcinfo(IDPROC(h),newlib,proc,lines,pos);
841            if (BVERBOSE(V_LOAD_PROC)) Warn( "     proc %s loaded", proc );
842          }
843          inBlock=IN_HEADER;
844        }
845        else if (strncmp( buf, "// ver:", 7) == 0)
846        {
847          v=0;
848          sscanf( buf+7, "%d", &v);
849          if(v!=(SINGULAR_VERSION/100))
850            Warn("version mismatch - library `%s` requires:%d.%d",
851                  newlib,v/1000,(v%1000)/100);
852        }
853        else if (strncmp( buf, "example", 7) == 0)
854        {
855          IDPROC(h)->data.s.example_start = pos;
856          IDPROC(h)->data.s.example_lineno = lines;
857          inBlock=IN_EXAMPLE;
858        }
859        else if (strncmp( buf, "//", 2) != 0)
860        {
861          if (inBlock==0)
862          {
863            otherLines++;
864          }
865        }
866      }
867      else if ((inBlock==IN_HEADER) || (inBlock==IN_EXAMPLE))
868      {
869        if (buf[0]=='{')
870        {
871          if(inBlock==IN_HEADER)
872          {
873            IDPROC(h)->data.s.body_start = pos;
874            IDPROC(h)->data.s.body_lineno = lines-offset;
875            // Print("%s: %d-%d\n", pi->procname, lines, offset);
876          }
877          inBlock=IN_BODY;
878        }
879      }
880      else if ((inBlock==IN_BODY) || (inBlock==IN_EXAMPLE_BODY))
881      {
882        if (buf[0]=='}')
883        {
884          if(IDPROC(h)->data.s.example_start==0)
885            IDPROC(h)->data.s.example_start=pos;
886          if(IDPROC(h)->data.s.body_end==0) IDPROC(h)->data.s.body_end=pos;
887          IDPROC(h)->data.s.proc_end = pos;
888          inBlock=0;
889        }
890      }
891    }
892    lines++;
893    pos = ftell(fp);
894  } while (fgets( buf, sizeof(buf), fp));
895  fclose( fp );
896#ifdef HAVE_NAMESPACES
897  namespaceroot->pop();
898#endif /* HAVE_NAMESPACES */
899
900  //if (h!=NULL) IDPROC(h) = pi;
901  if (BVERBOSE(V_DEBUG_LIB))
902  {
903    if (inBlock!=0)
904      Warn("LIB `%s` ends within block",newlib);
905    if (otherLines!=0)
906      Warn("%d lines not recognised in LIB `%s`",otherLines,newlib);
907    if(v==-1)
908      Warn("LIB `%s` has no version flag",newlib);
909  }
910#endif /* HAVE_LIBPARSER */
911  FreeL((ADDRESS)newlib);
912#ifdef HAVE_NAMESPACES
913   FreeL((ADDRESS)plib);
914#endif /* HAVE_LIBPARSER */
915  return FALSE;
916}
917
918/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
919procinfo *iiInitSingularProcinfo(procinfov pi, char *libname, char *procname,
920                                 int line, long pos, BOOLEAN pstatic)
921{
922  pi->libname = mstrdup(libname);
923
924  if( strcmp(procname,"_init")==0)
925  {
926    char *p = iiConvName(libname);
927    pi->procname = mstrdup(p);
928    FreeL((ADDRESS)p);
929  } else pi->procname = mstrdup(procname);
930  pi->language = LANG_SINGULAR;
931  pi->ref = 1;
932  pi->is_static = pstatic;
933  pi->data.s.proc_start = pos;
934  pi->data.s.def_end    = 0L;
935  pi->data.s.help_start = 0L;
936  pi->data.s.help_end   = 0L;
937  pi->data.s.body_start = 0L;
938  pi->data.s.body_end   = 0L;
939  pi->data.s.example_start = 0L;
940  pi->data.s.proc_lineno = line;
941  pi->data.s.body_lineno = 0;
942  pi->data.s.example_lineno = 0;
943  pi->data.s.body = NULL;
944  return(pi);
945}
946
947#ifdef HAVE_DYNAMIC_LOADING
948/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
949int iiAddCproc(char *libname, char *procname, BOOLEAN pstatic,
950               BOOLEAN(*func)(leftv res, leftv v))
951{
952  procinfov pi;
953  idhdl h;
954
955  h = enterid(mstrdup(procname),0, PROC_CMD, &IDROOT, FALSE);
956  if ( h!= NULL ) {
957    Print("register binary proc: %s::%s\n", libname, procname);
958    pi = IDPROC(h);
959    pi->libname = mstrdup(libname);
960    pi->procname = mstrdup(procname);
961    pi->language = LANG_C;
962    pi->ref = 1;
963    pi->is_static = pstatic;
964    pi->data.o.function = func;
965    return(1);
966  } else {
967    Print("iiAddCproc: failed.\n");
968  }
969  return(0);
970}
971#endif /* HAVE_DYNAMIC_LOADING */
972
973/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
974char mytoupper(char c)
975{
976  if(c>=97 && c<=(97+26)) c-=32;
977  return(c);
978}
979
980/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
981#if defined(WINNT)
982#  define  FS_SEP '\\'
983#elif defined(macintosh)
984#  define FS_SEP ','
985#else
986#  define FS_SEP '/'
987#endif
988
989char *iiConvName(char *libname)
990{
991  char *tmpname = mstrdup(libname);
992  char *p = strrchr(tmpname, FS_SEP);
993  char *r;
994  if(p==NULL) p = tmpname;
995  else p++;
996  r = strchr(p, '.');
997  if( r!= NULL) *r = '\0';
998  r = mstrdup(p);
999  *r = mytoupper(*r);
1000  // printf("iiConvName: '%s' '%s' => '%s'\n", libname, tmpname, r);
1001  FreeL(tmpname);
1002 
1003  return(r);
1004}
1005
1006/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1007void piShowProcList()
1008{
1009  idhdl h;
1010#ifdef HAVE_NAMESPACES
1011  idhdl pl;
1012#endif /* HAVE_NAMESPACES */
1013  procinfo *proc;
1014  char *name;
1015
1016  Print( "%-15s  %20s      %s,%s  %s,%s   %s,%s\n", "Library", "function",
1017         "line", "start", "line", "body", "line", "example");
1018#ifdef HAVE_NAMESPACES
1019  for(pl = IDROOT; pl != NULL; pl = IDNEXT(pl)) {
1020    if(IDTYP(pl) == PACKAGE_CMD) {
1021      for(h = IDPACKAGE(pl)->idroot; h != NULL; h = IDNEXT(h))
1022#else /* HAVE_NAMESPACES */
1023  for(h = IDROOT; h != NULL; h = IDNEXT(h))
1024#endif /* HAVE_NAMESPACES */
1025  {
1026    if(IDTYP(h) == PROC_CMD)
1027    {
1028      proc = IDPROC(h);
1029      if(strcmp(proc->procname, IDID(h))!=0)
1030      {
1031        name = (char *)AllocL(strlen(IDID(h))+strlen(proc->procname)+4);
1032        sprintf(name, "%s -> %s", IDID(h), proc->procname);
1033        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname, name);
1034        FreeL(name);
1035      }
1036      else
1037        Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname,
1038               proc->procname);
1039      if(proc->language==LANG_SINGULAR)
1040        Print("line %4d,%-5ld  %4d,%-5ld  %4d,%-5ld\n",
1041              proc->data.s.proc_lineno, proc->data.s.proc_start,
1042              proc->data.s.body_lineno, proc->data.s.body_start,
1043              proc->data.s.example_lineno, proc->data.s.example_start);
1044      else if(proc->language==LANG_C)
1045        Print("type: object\n");
1046#ifdef HAVE_NAMESPACES
1047          }
1048      }
1049#endif /* HAVE_NAMESPACES */
1050    }
1051  }
1052}
1053
1054/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1055//char *iiLineNo(char *procname, int lineno)
1056//{
1057//  char buf[256];
1058//  idhdl pn = ggetid(procname);
1059//  procinfo *pi = IDPROC(pn);
1060//
1061//  sprintf(buf, "%s %3d\0", procname, lineno);
1062//  //sprintf(buf, "%s::%s %3d\0", pi->libname, pi->procname,
1063//  //  lineno + pi->data.s.body_lineno);
1064//  return(buf);
1065//}
1066/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1067#ifdef HAVE_LIBPARSER
1068void libstack::push(char *p, char *libname)
1069{
1070#  ifdef HAVE_NAMESPACES
1071  idhdl hl = namespaceroot->get("LIB",0, TRUE);
1072#  else /* HAVE_NAMESPACES */
1073  idhdl hl = idroot->get("LIB",0);
1074#  endif /* HAVE_NAMESPACES */
1075  libstackv lp;
1076  char *f = NULL;
1077  if(hl!=NULL) f = strstr(IDSTRING(hl),libname);
1078  if( (hl==NULL) || (f == NULL)) {
1079    for(lp = this;lp!=NULL;lp=lp->next) {
1080      if(strcmp(lp->get(), libname)==0) break;
1081    }
1082    if(lp==NULL) {
1083      libstackv ls = (libstack *)Alloc0(sizeof(libstack));
1084      ls->next = this;
1085      ls->libname = mstrdup(libname);
1086      ls->to_be_done = TRUE;
1087      if(this != NULL) ls->cnt = this->cnt+1; else ls->cnt = 0;
1088      library_stack = ls;
1089    }
1090  }
1091}
1092
1093libstackv libstack::pop(char *p)
1094{
1095  libstackv ls = this;
1096  //FreeL(ls->libname);
1097  library_stack = ls->next;
1098  Free((ADDRESS)ls, sizeof(libstack));
1099  return(library_stack);
1100}
1101
1102#endif /* HAVE_LIBPARSER */
1103/*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
Note: See TracBrowser for help on using the repository browser.