1 /****************************************
2 *  Computer Algebra System SINGULAR     *
3 ****************************************/
4 /*
5 * ABSTRACT: interpreter: LIB and help
6 */
7 
8 #include "kernel/mod2.h"
9 
10 #include "Singular/tok.h"
11 #include "misc/options.h"
12 #include "Singular/ipid.h"
13 #include "polys/monomials/ring.h"
14 #include "Singular/subexpr.h"
15 #include "Singular/ipid.h"
16 #include "Singular/ipshell.h"
17 #include "Singular/fevoices.h"
18 #include "Singular/lists.h"
19 
20 #include <ctype.h>
21 
22 #if SIZEOF_LONG == 8
23 #define SI_MAX_NEST 500
24 #elif defined(__CYGWIN__)
25 #define SI_MAX_NEST 480
26 #else
27 #define SI_MAX_NEST 1000
28 #endif
29 
30 #if defined(ix86Mac_darwin) || defined(x86_64Mac_darwin) || defined(ppcMac_darwin)
31 #  define MODULE_SUFFIX bundle
32 #elif defined(__CYGWIN__)
33 #  define MODULE_SUFFIX dll
34 #else
35 #  define MODULE_SUFFIX so
36 #endif
37 
38 #define MODULE_SUFFIX_STRING EXPANDED_STRINGIFY(MODULE_SUFFIX)
39 
40 
41 #ifdef HAVE_DYNAMIC_LOADING
42 BOOLEAN load_modules(const char *newlib, char *fullname, BOOLEAN autoexport);
43 #endif
44 
45 #ifdef HAVE_LIBPARSER
46 #  include "libparse.h"
47 #else /* HAVE_LIBPARSER */
48 procinfo *iiInitSingularProcinfo(procinfov pi, const char *libname,
49               const char *procname, int line, long pos, BOOLEAN pstatic=FALSE);
50 #endif /* HAVE_LIBPARSER */
51 
52 extern int iiArithAddCmd(const char *szName, short nAlias, short nTokval,
53                          short nToktype, short nPos);
54 
55 #include "Singular/mod_lib.h"
56 
57 #ifdef HAVE_LIBPARSER
58 void yylprestart (FILE *input_file );
59 int current_pos(int i=0);
60 EXTERN_VAR int yylp_errno;
61 EXTERN_VAR int yylplineno;
62 extern const char *yylp_errlist[];
63 void print_init();
64 VAR libstackv library_stack;
65 #endif
66 
67 //int IsCmd(char *n, int tok);
68 char mytolower(char c);
69 
70 /*2
71 * return TRUE if the libray libname is already loaded
72 */
iiGetLibStatus(const char * lib)73 BOOLEAN iiGetLibStatus(const char *lib)
74 {
75   idhdl hl;
76 
77   char *plib = iiConvName(lib);
78   hl = basePack->idroot->get(plib,0);
79   omFree(plib);
80   if((hl==NULL) ||(IDTYP(hl)!=PACKAGE_CMD))
81   {
82     return FALSE;
83   }
84   if ((IDPACKAGE(hl)->language!=LANG_C)&&(IDPACKAGE(hl)->libname!=NULL))
85     return (strcmp(lib,IDPACKAGE(hl)->libname)==0);
86   return FALSE;
87 }
88 
89 /*2
90 * given a line 'proc[ ]+{name}[ \t]*'
91 * return a pointer to name and set the end of '\0'
92 * changes the input!
93 * returns: e: pointer to 'end of name'
94 *          ct: changed char at the end of s
95 */
iiProcName(char * buf,char & ct,char * & e)96 char* iiProcName(char *buf, char & ct, char* &e)
97 {
98   char *s=buf+5;
99   while (*s==' ') s++;
100   e=s+1;
101   while ((*e>' ') && (*e!='(')) e++;
102   ct=*e;
103   *e='\0';
104   return s;
105 }
106 
107 /*2
108 * given a line with args, return the argstr
109 */
iiProcArgs(char * e,BOOLEAN withParenth)110 char * iiProcArgs(char *e,BOOLEAN withParenth)
111 {
112   while ((*e==' ') || (*e=='\t') || (*e=='(')) e++;
113   if (*e<' ')
114   {
115     if (withParenth)
116     {
117       // no argument list, allow list #
118       return omStrDup("parameter list #;");
119     }
120     else
121     {
122       // empty list
123       return omStrDup("");
124     }
125   }
126   BOOLEAN in_args;
127   BOOLEAN args_found;
128   char *s;
129   char *argstr=(char *)omAlloc(127); // see ../omalloc/omTables.inc
130   int argstrlen=127;
131   *argstr='\0';
132   int par=0;
133   do
134   {
135     args_found=FALSE;
136     s=e; // set s to the starting point of the arg
137          // and search for the end
138     // skip leading spaces:
139     loop
140     {
141       if ((*s==' ')||(*s=='\t'))
142         s++;
143       else if ((*s=='\n')&&(*(s+1)==' '))
144         s+=2;
145       else // start of new arg or \0 or )
146         break;
147     }
148     e=s;
149     while ((*e!=',')
150     &&((par!=0) || (*e!=')'))
151     &&(*e!='\0'))
152     {
153       if (*e=='(') par++;
154       else if (*e==')') par--;
155       args_found=args_found || (*e>' ');
156       e++;
157     }
158     in_args=(*e==',');
159     if (args_found)
160     {
161       *e='\0';
162       // check for space:
163       if ((int)strlen(argstr)+12 /* parameter + ;*/ +(int)strlen(s)>= argstrlen)
164       {
165         argstrlen*=2;
166         char *a=(char *)omAlloc( argstrlen);
167         strcpy(a,argstr);
168         omFree((ADDRESS)argstr);
169         argstr=a;
170       }
171       // copy the result to argstr
172       if(strncmp(s,"alias ",6)!=0)
173       {
174         strcat(argstr,"parameter ");
175       }
176       strcat(argstr,s);
177       strcat(argstr,"; ");
178       e++; // e was pointing to ','
179     }
180   } while (in_args);
181   return argstr;
182 }
183 
184 /*2
185 * locate `procname` in lib `libname` and find the part `part`:
186 *  part=0: help, between, but excluding the line "proc ..." and "{...":
187 *    => return
188 *  part=1: body, between "{ ..." and "}", including the 1. line, w/o "{"
189 *    => set pi->data.s.body, return NULL
190 *  part=2: example, between, but excluding the line "exapmle {..." and "}":
191 *    => return
192 */
iiGetLibProcBuffer(procinfo * pi,int part)193 char* iiGetLibProcBuffer(procinfo *pi, int part )
194 {
195   char buf[256], *s = NULL, *p;
196   long procbuflen;
197 
198   FILE * fp = feFopen( pi->libname, "rb", NULL, TRUE );
199   if (fp==NULL)
200   {
201     return NULL;
202   }
203 
204   fseek(fp, pi->data.s.proc_start, SEEK_SET);
205   if(part==0)
206   { // load help string
207     int i, offset=0;
208     long head = pi->data.s.def_end - pi->data.s.proc_start;
209     procbuflen = pi->data.s.help_end - pi->data.s.help_start;
210     if (procbuflen<5)
211     {
212       fclose(fp);
213       return NULL; // help part does not exist
214     }
215     //Print("Help=%ld-%ld=%d\n", pi->data.s.body_start,
216     //    pi->data.s.proc_start, procbuflen);
217     s = (char *)omAlloc(procbuflen+head+3);
218     myfread(s, head, 1, fp);
219     s[head] = '\n';
220     fseek(fp, pi->data.s.help_start, SEEK_SET);
221     myfread(s+head+1, procbuflen, 1, fp);
222     fclose(fp);
223     s[procbuflen+head+1] = '\n';
224     s[procbuflen+head+2] = '\0';
225     offset=0;
226     for(i=0;i<=procbuflen+head+2; i++)
227     {
228       if(s[i]=='\\' &&
229          (s[i+1]=='"' || s[i+1]=='{' || s[i+1]=='}' || s[i+1]=='\\'))
230       {
231         i++;
232         offset++;
233       }
234       if(offset>0) s[i-offset] = s[i];
235     }
236     return(s);
237   }
238   else if(part==1)
239   { // load proc part - must exist
240     procbuflen = pi->data.s.def_end - pi->data.s.proc_start;
241     char *ss=(char *)omAlloc(procbuflen+2);
242     //fgets(buf, sizeof(buf), fp);
243     myfread( ss, procbuflen, 1, fp);
244     char ct;
245     char *e;
246     s=iiProcName(ss,ct,e);
247     char *argstr=NULL;
248     *e=ct;
249     argstr=iiProcArgs(e,TRUE);
250 
251     assume(pi->data.s.body_end > pi->data.s.body_start);
252 
253     procbuflen = pi->data.s.body_end - pi->data.s.body_start;
254     pi->data.s.body = (char *)omAlloc( strlen(argstr)+procbuflen+15+
255                                       strlen(pi->libname) );
256     //Print("Body=%ld-%ld=%d\n", pi->data.s.body_end,
257     //    pi->data.s.body_start, procbuflen);
258     assume(pi->data.s.body != NULL);
259     fseek(fp, pi->data.s.body_start, SEEK_SET);
260     strcpy(pi->data.s.body,argstr);
261     myfread( pi->data.s.body+strlen(argstr), procbuflen, 1, fp);
262     fclose( fp );
263     procbuflen+=strlen(argstr);
264     omFree(argstr);
265     omFree(ss);
266     pi->data.s.body[procbuflen] = '\0';
267     strcat( pi->data.s.body+procbuflen, "\n;return();\n\n" );
268     strcat( pi->data.s.body+procbuflen+13,pi->libname);
269     s=(char *)strchr(pi->data.s.body,'{');
270     if (s!=NULL) *s=' ';
271     return NULL;
272   }
273   else if(part==2)
274   { // example
275     if ( pi->data.s.example_lineno == 0)
276       return NULL; // example part does not exist
277     // load example
278     fseek(fp, pi->data.s.example_start, SEEK_SET);
279     /*char *dummy=*/ (void) fgets(buf, sizeof(buf), fp); // skip line with "example"
280     procbuflen = pi->data.s.proc_end - pi->data.s.example_start - strlen(buf);
281     //Print("Example=%ld-%ld=%d\n", pi->data.s.proc_end,
282     //  pi->data.s.example_start, procbuflen);
283     s = (char *)omAlloc(procbuflen+14);
284     myfread(s, procbuflen, 1, fp);
285     s[procbuflen] = '\0';
286     strcat(s+procbuflen-3, "\n;return();\n\n" );
287     p=(char *)strchr(s,'{');
288     if (p!=NULL) *p=' ';
289     return(s);
290   }
291   return NULL;
292 }
293 
iiAllStart(procinfov pi,const char * p,feBufferTypes t,int l)294 BOOLEAN iiAllStart(procinfov pi, const char *p, feBufferTypes t, int l)
295 {
296   int save_trace=traceit;
297   int restore_traceit=0;
298   if (traceit_stop
299   && (traceit & TRACE_SHOW_LINE))
300   {
301     traceit &=(~TRACE_SHOW_LINE);
302     traceit_stop=0;
303     restore_traceit=1;
304   }
305   // see below:
306   BITSET save1=si_opt_1;
307   BITSET save2=si_opt_2;
308   newBuffer( omStrDup(p /*pi->data.s.body*/), t /*BT_proc*/,
309                pi, l );
310   BOOLEAN err=yyparse();
311 
312   if (sLastPrinted.rtyp!=0)
313   {
314     sLastPrinted.CleanUp();
315   }
316 
317   if (restore_traceit) traceit=save_trace;
318 
319   // the access to optionStruct and verboseStruct do not work
320   // on x86_64-Linux for pic-code
321   if ((TEST_V_ALLWARN) &&
322   (t==BT_proc) &&
323   ((save1!=si_opt_1)||(save2!=si_opt_2)) &&
324   (pi->libname!=NULL) && (pi->libname[0]!='\0'))
325   {
326     if ((pi->libname!=NULL) && (pi->libname[0]!='\0'))
327       Warn("option changed in proc %s from %s",pi->procname,pi->libname);
328     else
329       Warn("option changed in proc %s",pi->procname);
330     int i;
331     for (i=0; optionStruct[i].setval!=0; i++)
332     {
333       if ((optionStruct[i].setval & si_opt_1)
334       && (!(optionStruct[i].setval & save1)))
335       {
336           Print(" +%s",optionStruct[i].name);
337       }
338       if (!(optionStruct[i].setval & si_opt_1)
339       && ((optionStruct[i].setval & save1)))
340       {
341           Print(" -%s",optionStruct[i].name);
342       }
343     }
344     for (i=0; verboseStruct[i].setval!=0; i++)
345     {
346       if ((verboseStruct[i].setval & si_opt_2)
347       && (!(verboseStruct[i].setval & save2)))
348       {
349           Print(" +%s",verboseStruct[i].name);
350       }
351       if (!(verboseStruct[i].setval & si_opt_2)
352       && ((verboseStruct[i].setval & save2)))
353       {
354           Print(" -%s",verboseStruct[i].name);
355       }
356     }
357     PrintLn();
358   }
359   return err;
360 }
361 /*2
362 * start a proc
363 * parameters are built as exprlist
364 * TODO:interrupt
365 * return FALSE on success, TRUE if an error occurs
366 */
iiPStart(idhdl pn,leftv v)367 BOOLEAN iiPStart(idhdl pn, leftv v)
368 {
369   procinfov pi=NULL;
370   int old_echo=si_echo;
371   BOOLEAN err=FALSE;
372   char save_flags=0;
373 
374   /* init febase ======================================== */
375   /* we do not enter this case if filename != NULL !! */
376   if (pn!=NULL)
377   {
378     pi = IDPROC(pn);
379     if(pi!=NULL)
380     {
381       save_flags=pi->trace_flag;
382       if( pi->data.s.body==NULL )
383       {
384         iiGetLibProcBuffer(pi);
385         if (pi->data.s.body==NULL) return TRUE;
386       }
387 //      omUpdateInfo();
388 //      int m=om_Info.UsedBytes;
389 //      Print("proc %s, mem=%d\n",IDID(pn),m);
390     }
391   }
392   else return TRUE;
393   /* generate argument list ======================================*/
394   //iiCurrArgs should be NULL here, as the assignment for the parameters
395   // of the prevouis call are already done befor calling another routine
396   if (v!=NULL)
397   {
398     iiCurrArgs=(leftv)omAllocBin(sleftv_bin);
399     memcpy(iiCurrArgs,v,sizeof(sleftv)); // keeps track of v->next etc.
400     v->Init();
401   }
402   else
403   {
404     iiCurrArgs=NULL;
405   }
406   /* start interpreter ======================================*/
407   myynest++;
408   if (myynest > SI_MAX_NEST)
409   {
410     WerrorS("nesting too deep");
411     err=TRUE;
412   }
413   else
414   {
415     iiCurrProc=pn;
416     err=iiAllStart(pi,pi->data.s.body,BT_proc,pi->data.s.body_lineno-(v!=NULL));
417     iiCurrProc=NULL;
418 
419     if (iiLocalRing[myynest-1] != currRing)
420     {
421       if (iiRETURNEXPR.RingDependend())
422       {
423         //idhdl hn;
424         const char *n;
425         const char *o;
426         idhdl nh=NULL, oh=NULL;
427         if (iiLocalRing[myynest-1]!=NULL)
428           oh=rFindHdl(iiLocalRing[myynest-1],NULL);
429         if (oh!=NULL)          o=oh->id;
430         else                   o="none";
431         if (currRing!=NULL)
432           nh=rFindHdl(currRing,NULL);
433         if (nh!=NULL)          n=nh->id;
434         else                   n="none";
435         Werror("ring change during procedure call %s: %s -> %s (level %d)",pi->procname,o,n,myynest);
436         iiRETURNEXPR.CleanUp();
437         err=TRUE;
438       }
439       currRing=iiLocalRing[myynest-1];
440     }
441     if ((currRing==NULL)
442     && (currRingHdl!=NULL))
443       currRing=IDRING(currRingHdl);
444     else
445     if ((currRing!=NULL) &&
446       ((currRingHdl==NULL)||(IDRING(currRingHdl)!=currRing)
447        ||(IDLEV(currRingHdl)>=myynest-1)))
448     {
449       rSetHdl(rFindHdl(currRing,NULL));
450       iiLocalRing[myynest-1]=NULL;
451     }
452     //Print("kill locals for %s (level %d)\n",IDID(pn),myynest);
453     killlocals(myynest);
454 #ifndef SING_NDEBUG
455     checkall();
456 #endif
457     //Print("end kill locals for %s (%d)\n",IDID(pn),myynest);
458   }
459   myynest--;
460   si_echo=old_echo;
461   if (pi!=NULL)
462     pi->trace_flag=save_flags;
463 //  omUpdateInfo();
464 //  int m=om_Info.UsedBytes;
465 //  Print("exit %s, mem=%d\n",IDID(pn),m);
466   return err;
467 }
468 
469 VAR ring    *iiLocalRing;
470 INST_VAR sleftv  iiRETURNEXPR;
471 VAR int     iiRETURNEXPR_len=0;
472 
473 #ifdef RDEBUG
iiShowLevRings()474 static void iiShowLevRings()
475 {
476   int i;
477   for (i=0;i<=myynest;i++)
478   {
479     Print("lev %d:",i);
480     if (iiLocalRing[i]==NULL) PrintS("NULL");
481     else                      Print("%lx",(long)iiLocalRing[i]);
482     PrintLn();
483   }
484   if (currRing==NULL) PrintS("curr:NULL\n");
485   else                Print ("curr:%lx\n",(long)currRing);
486 }
487 #endif /* RDEBUG */
488 
iiCheckNest()489 static void iiCheckNest()
490 {
491   if (myynest >= iiRETURNEXPR_len-1)
492   {
493     iiLocalRing=(ring *)omreallocSize(iiLocalRing,
494                                    iiRETURNEXPR_len*sizeof(ring),
495                                    (iiRETURNEXPR_len+16)*sizeof(ring));
496     memset(&(iiLocalRing[iiRETURNEXPR_len]),0,16*sizeof(ring));
497     iiRETURNEXPR_len+=16;
498   }
499 }
iiMake_proc(idhdl pn,package pack,leftv args)500 BOOLEAN iiMake_proc(idhdl pn, package pack, leftv args)
501 {
502   int err;
503   procinfov pi = IDPROC(pn);
504   if(pi->is_static && myynest==0)
505   {
506     Werror("'%s::%s()' is a local procedure and cannot be accessed by an user.",
507            pi->libname, pi->procname);
508     return TRUE;
509   }
510   iiCheckNest();
511   iiLocalRing[myynest]=currRing;
512   //Print("currRing(%d):%s(%x) in %s\n",myynest,IDID(currRingHdl),currRing,IDID(pn));
513   iiRETURNEXPR.Init();
514   procstack->push(pi->procname);
515   if ((traceit&TRACE_SHOW_PROC)
516   || (pi->trace_flag&TRACE_SHOW_PROC))
517   {
518     if (traceit&TRACE_SHOW_LINENO) PrintLn();
519     Print("entering%-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
520   }
521 #ifdef RDEBUG
522   if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
523 #endif
524   switch (pi->language)
525   {
526     default:
527     case LANG_NONE:
528                  WerrorS("undefined proc");
529                  err=TRUE;
530                  break;
531 
532     case LANG_SINGULAR:
533                  if ((pi->pack!=NULL)&&(currPack!=pi->pack))
534                  {
535                    currPack=pi->pack;
536                    iiCheckPack(currPack);
537                    currPackHdl=packFindHdl(currPack);
538                    //Print("set pack=%s\n",IDID(currPackHdl));
539                  }
540                  else if ((pack!=NULL)&&(currPack!=pack))
541                  {
542                    currPack=pack;
543                    iiCheckPack(currPack);
544                    currPackHdl=packFindHdl(currPack);
545                    //Print("set pack=%s\n",IDID(currPackHdl));
546                  }
547                  err=iiPStart(pn,args);
548                  break;
549     case LANG_C:
550                  leftv res = (leftv)omAlloc0Bin(sleftv_bin);
551                  err = (pi->data.o.function)(res, args);
552                  memcpy(&iiRETURNEXPR,res,sizeof(iiRETURNEXPR));
553                  omFreeBin((ADDRESS)res,  sleftv_bin);
554                  break;
555   }
556   if ((traceit&TRACE_SHOW_PROC)
557   || (pi->trace_flag&TRACE_SHOW_PROC))
558   {
559     if (traceit&TRACE_SHOW_LINENO) PrintLn();
560     Print("leaving %-*.*s %s (level %d)\n",myynest*2,myynest*2," ",IDID(pn),myynest);
561   }
562   //const char *n="NULL";
563   //if (currRingHdl!=NULL) n=IDID(currRingHdl);
564   //Print("currRing(%d):%s(%x) after %s\n",myynest,n,currRing,IDID(pn));
565 #ifdef RDEBUG
566   if (traceit&TRACE_SHOW_RINGS) iiShowLevRings();
567 #endif
568   if (err)
569   {
570     iiRETURNEXPR.CleanUp();
571     //iiRETURNEXPR.Init(); //done by CleanUp
572   }
573   if (iiCurrArgs!=NULL)
574   {
575     if (!err) Warn("too many arguments for %s",IDID(pn));
576     iiCurrArgs->CleanUp();
577     omFreeBin((ADDRESS)iiCurrArgs, sleftv_bin);
578     iiCurrArgs=NULL;
579   }
580   procstack->pop();
581   if (err)
582     return TRUE;
583   return FALSE;
584 }
iiCallLibProcBegin()585 static void iiCallLibProcBegin()
586 {
587   idhdl tmp_ring=NULL;
588   if (currRing!=NULL)
589   {
590     if ((currRingHdl!=NULL) && (IDRING(currRingHdl)!=currRing))
591     {
592       // clean up things depending on currRingHdl:
593       sLastPrinted.CleanUp(IDRING(currRingHdl));
594       sLastPrinted.Init();
595     }
596     // need to define a ring-hdl for currRingHdl
597     tmp_ring=enterid(" tmpRing",myynest,RING_CMD,&IDROOT,FALSE);
598     IDRING(tmp_ring)=rIncRefCnt(currRing);
599     rSetHdl(tmp_ring);
600   }
601 }
iiCallLibProcEnd(idhdl save_ringhdl,ring save_ring)602 static void iiCallLibProcEnd(idhdl save_ringhdl, ring save_ring)
603 {
604   if ((currRing!=NULL)
605   &&(currRing!=save_ring))
606   {
607     rDecRefCnt(currRing);
608     idhdl hh=IDROOT;
609     idhdl prev=NULL;
610     while((hh!=currRingHdl) && (hh!=NULL)) { prev=hh; hh=hh->next; }
611     if (hh!=NULL)
612     {
613       if (prev==NULL) IDROOT=hh->next;
614       else prev->next=hh->next;
615       omFree((ADDRESS)IDID(hh));
616       omFreeBin((ADDRESS)hh, idrec_bin);
617     }
618   }
619   currRingHdl=save_ringhdl;
620   currRing=save_ring;
621 }
622 
iiCallLibProc1(const char * n,void * arg,int arg_type,BOOLEAN & err)623 void* iiCallLibProc1(const char*n, void *arg, int arg_type, BOOLEAN &err)
624 {
625   idhdl h=ggetid(n);
626   if ((h==NULL)
627   || (IDTYP(h)!=PROC_CMD))
628   {
629     err=2;
630     return NULL;
631   }
632   // ring handling
633   idhdl save_ringhdl=currRingHdl;
634   ring save_ring=currRing;
635   iiCallLibProcBegin();
636   // argument:
637   sleftv tmp;
638   tmp.Init();
639   tmp.data=arg;
640   tmp.rtyp=arg_type;
641   // call proc
642   err=iiMake_proc(h,currPack,&tmp);
643   // clean up ring
644   iiCallLibProcEnd(save_ringhdl,save_ring);
645   // return
646   if (err==FALSE)
647   {
648     void*r=iiRETURNEXPR.data;
649     iiRETURNEXPR.data=NULL;
650     iiRETURNEXPR.CleanUp();
651     return r;
652   }
653   return NULL;
654 }
655 
656 // return NULL on failure
ii_CallProcId2Id(const char * lib,const char * proc,ideal arg,const ring R)657 ideal ii_CallProcId2Id(const char *lib,const char *proc, ideal arg, const ring R)
658 {
659   char *plib = iiConvName(lib);
660   idhdl h=ggetid(plib);
661   omFree(plib);
662   if (h==NULL)
663   {
664     BOOLEAN bo=iiLibCmd(lib,TRUE,TRUE,FALSE);
665     if (bo) return NULL;
666   }
667   ring oldR=currRing;
668   rChangeCurrRing(R);
669   BOOLEAN err;
670   ideal I=(ideal)iiCallLibProc1(proc,idCopy(arg),IDEAL_CMD,err);
671   rChangeCurrRing(oldR);
672   if (err) return NULL;
673   return I;
674 }
675 
ii_CallProcId2Int(const char * lib,const char * proc,ideal arg,const ring R)676 int ii_CallProcId2Int(const char *lib,const char *proc, ideal arg, const ring R)
677 {
678   char *plib = iiConvName(lib);
679   idhdl h=ggetid(plib);
680   omFree(plib);
681   if (h==NULL)
682   {
683     BOOLEAN bo=iiLibCmd(lib,TRUE,TRUE,FALSE);
684     if (bo) return 0;
685   }
686   BOOLEAN err;
687   ring oldR=currRing;
688   rChangeCurrRing(R);
689   int I=(int)(long)iiCallLibProc1(proc,idCopy(arg),IDEAL_CMD,err);
690   rChangeCurrRing(oldR);
691   if (err) return 0;
692   return I;
693 }
694 
695 /// args: NULL terminated array of arguments
696 /// arg_types: 0 terminated array of corresponding types
ii_CallLibProcM(const char * n,void ** args,int * arg_types,const ring R,BOOLEAN & err)697 leftv ii_CallLibProcM(const char*n, void **args, int* arg_types, const ring R, BOOLEAN &err)
698 {
699   idhdl h=ggetid(n);
700   if ((h==NULL)
701   || (IDTYP(h)!=PROC_CMD))
702   {
703     err=2;
704     return NULL;
705   }
706   // ring handling
707   idhdl save_ringhdl=currRingHdl;
708   ring save_ring=currRing;
709   rChangeCurrRing(R);
710   iiCallLibProcBegin();
711   // argument:
712   if (arg_types[0]!=0)
713   {
714     sleftv tmp;
715     leftv tt=&tmp;
716     int i=1;
717     tmp.Init();
718     tmp.data=args[0];
719     tmp.rtyp=arg_types[0];
720     while(arg_types[i]!=0)
721     {
722       tt->next=(leftv)omAlloc0Bin(sleftv_bin);
723       tt=tt->next;
724       tt->rtyp=arg_types[i];
725       tt->data=args[i];
726       i++;
727     }
728     // call proc
729     err=iiMake_proc(h,currPack,&tmp);
730   }
731   else
732   // call proc
733     err=iiMake_proc(h,currPack,NULL);
734   // clean up ring
735   iiCallLibProcEnd(save_ringhdl,save_ring);
736   // return
737   if (err==FALSE)
738   {
739     leftv h=(leftv)omAllocBin(sleftv_bin);
740     memcpy(h,&iiRETURNEXPR,sizeof(sleftv));
741     iiRETURNEXPR.Init();
742     return h;
743   }
744   return NULL;
745 }
746 /*2
747 * start an example (as a proc),
748 * destroys the string 'example'
749 */
iiEStart(char * example,procinfo * pi)750 BOOLEAN iiEStart(char* example, procinfo *pi)
751 {
752   BOOLEAN err;
753   int old_echo=si_echo;
754 
755   iiCheckNest();
756   procstack->push(example);
757   iiLocalRing[myynest]=currRing;
758   if (traceit&TRACE_SHOW_PROC)
759   {
760     if (traceit&TRACE_SHOW_LINENO) printf("\n");
761     printf("entering example (level %d)\n",myynest);
762   }
763   myynest++;
764 
765   err=iiAllStart(pi,example,BT_example,(pi != NULL ? pi->data.s.example_lineno: 0));
766 
767   killlocals(myynest);
768   myynest--;
769   si_echo=old_echo;
770   if (traceit&TRACE_SHOW_PROC)
771   {
772     if (traceit&TRACE_SHOW_LINENO) printf("\n");
773     printf("leaving  -example- (level %d)\n",myynest);
774   }
775   if (iiLocalRing[myynest] != currRing)
776   {
777     if (iiLocalRing[myynest]!=NULL)
778     {
779       rSetHdl(rFindHdl(iiLocalRing[myynest],NULL));
780       iiLocalRing[myynest]=NULL;
781     }
782     else
783     {
784       currRingHdl=NULL;
785       currRing=NULL;
786     }
787   }
788   procstack->pop();
789   return err;
790 }
791 
792 
793 extern "C"
794 {
795 #  define SI_GET_BUILTIN_MOD_INIT0(name) int SI_MOD_INIT0(name)(SModulFunctions*);
796           SI_FOREACH_BUILTIN(SI_GET_BUILTIN_MOD_INIT0)
797 #  undef  SI_GET_BUILTIN_MOD_INIT0
798 };
799 
800 extern "C" int flint_mod_init(SModulFunctions* psModulFunctions);
801 
802 SModulFunc_t
iiGetBuiltinModInit(const char * libname)803 iiGetBuiltinModInit(const char* libname)
804 {
805 #ifdef HAVE_FLINT
806   if (strcmp(libname,"flint.so")==0) return SI_MOD_INIT0(flint);
807 #endif
808 #  define SI_GET_BUILTIN_MOD_INIT(name) if (strcmp(libname, #name ".so") == 0){ return SI_MOD_INIT0(name); }
809           SI_FOREACH_BUILTIN(SI_GET_BUILTIN_MOD_INIT)
810 #  undef  SI_GET_BUILTIN_MOD_INIT
811 
812   return NULL;
813 }
814 
815 
816 
817 
818 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
iiTryLoadLib(leftv v,const char * id)819 BOOLEAN iiTryLoadLib(leftv v, const char *id)
820 {
821   BOOLEAN LoadResult = TRUE;
822   char libnamebuf[1024];
823   char *libname = (char *)omAlloc(strlen(id)+5);
824   const char *suffix[] = { "", ".lib", ".so", ".sl", NULL };
825   int i = 0;
826   // FILE *fp;
827   // package pack;
828   // idhdl packhdl;
829   lib_types LT;
830   for(i=0; suffix[i] != NULL; i++)
831   {
832     sprintf(libname, "%s%s", id, suffix[i]);
833     *libname = mytolower(*libname);
834     if((LT = type_of_LIB(libname, libnamebuf)) > LT_NOTFOUND)
835     {
836       #ifdef HAVE_DYNAMIC_LOADING
837       char libnamebuf[1024];
838       #endif
839 
840       if (LT==LT_SINGULAR)
841         LoadResult = iiLibCmd(libname, FALSE, FALSE,TRUE);
842       #ifdef HAVE_DYNAMIC_LOADING
843       else if ((LT==LT_ELF) || (LT==LT_HPUX))
844         LoadResult = load_modules(libname,libnamebuf,FALSE);
845       #endif
846       else if (LT==LT_BUILTIN)
847       {
848         LoadResult=load_builtin(libname,FALSE, iiGetBuiltinModInit(libname));
849       }
850       if(!LoadResult )
851       {
852         v->name = iiConvName(libname);
853         break;
854       }
855     }
856   }
857   omFree(libname);
858   return LoadResult;
859 }
860 
861 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
862 /* check, if library lib has already been loaded
863    if yes, writes filename of lib into where and returns TRUE,
864       no, returns FALSE
865 */
iiLocateLib(const char * lib,char * where)866 BOOLEAN iiLocateLib(const char* lib, char* where)
867 {
868   char *plib = iiConvName(lib);
869   idhdl pl = basePack->idroot->get(plib,0);
870   if( (pl!=NULL) && (IDTYP(pl)==PACKAGE_CMD) &&
871     (IDPACKAGE(pl)->language == LANG_SINGULAR))
872   {
873     strncpy(where,IDPACKAGE(pl)->libname,127);
874     return TRUE;
875   }
876   else
877     return FALSE;;
878 }
879 
iiLibCmd(const char * newlib,BOOLEAN autoexport,BOOLEAN tellerror,BOOLEAN force)880 BOOLEAN iiLibCmd( const char *newlib, BOOLEAN autoexport, BOOLEAN tellerror, BOOLEAN force )
881 {
882   if (strcmp(newlib,"Singular")==0) return FALSE;
883   char libnamebuf[1024];
884   idhdl pl;
885   char *plib = iiConvName(newlib);
886   FILE * fp = feFopen( newlib, "r", libnamebuf, tellerror );
887   // int lines = 1;
888   BOOLEAN LoadResult = TRUE;
889 
890   if (fp==NULL)
891   {
892     return TRUE;
893   }
894   pl = basePack->idroot->get(plib,0);
895   if (pl==NULL)
896   {
897     pl = enterid( plib,0, PACKAGE_CMD,
898                   &(basePack->idroot), TRUE );
899     IDPACKAGE(pl)->language = LANG_SINGULAR;
900     IDPACKAGE(pl)->libname=omStrDup(newlib);
901   }
902   else
903   {
904     if(IDTYP(pl)!=PACKAGE_CMD)
905     {
906       omFree(plib);
907       WarnS("not of type package.");
908       fclose(fp);
909       return TRUE;
910     }
911     if (!force)
912     {
913       omFree(plib);
914       return FALSE;
915     }
916   }
917   LoadResult = iiLoadLIB(fp, libnamebuf, newlib, pl, autoexport, tellerror);
918 
919   if(!LoadResult) IDPACKAGE(pl)->loaded = TRUE;
920   omFree((ADDRESS)plib);
921   return LoadResult;
922 }
923 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
iiCleanProcs(idhdl & root)924 static void iiCleanProcs(idhdl &root)
925 {
926   idhdl prev=NULL;
927   loop
928   {
929     if (root==NULL) return;
930     if (IDTYP(root)==PROC_CMD)
931     {
932       procinfo *pi=(procinfo*)IDDATA(root);
933       if ((pi->language == LANG_SINGULAR)
934       && (pi->data.s.body_start == 0L))
935       {
936         // procinfo data incorrect:
937         // - no proc body can start at the beginning of the file
938         killhdl(root);
939         if (prev==NULL)
940           root=IDROOT;
941         else
942         {
943           root=prev;
944           prev=NULL;
945         }
946         continue;
947       }
948     }
949     prev=root;
950     root=IDNEXT(root);
951   }
952 }
iiRunInit(package p)953 static void iiRunInit(package p)
954 {
955   idhdl h=p->idroot->get("mod_init",0);
956   if (h==NULL) return;
957   if (IDTYP(h)==PROC_CMD)
958   {
959     int save=yylineno;
960     myynest++;
961     // procinfo *pi=(procinfo*)IDDATA(h);
962     //PrintS("mod_init found\n");
963     iiMake_proc(h,p,NULL);
964     myynest--;
965     yylineno=save;
966   }
967 }
968 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
iiLoadLIB(FILE * fp,const char * libnamebuf,const char * newlib,idhdl pl,BOOLEAN autoexport,BOOLEAN tellerror)969 BOOLEAN iiLoadLIB(FILE *fp, const char *libnamebuf, const char*newlib,
970              idhdl pl, BOOLEAN autoexport, BOOLEAN tellerror)
971 {
972   EXTERN_VAR FILE *yylpin;
973   libstackv ls_start = library_stack;
974   lib_style_types lib_style;
975 
976   yylpin = fp;
977   #if YYLPDEBUG > 1
978   print_init();
979   #endif
980   EXTERN_VAR int lpverbose;
981   if (BVERBOSE(V_DEBUG_LIB)) lpverbose=1;
982   else lpverbose=0;
983   // yylplex sets also text_buffer
984   if (text_buffer!=NULL) *text_buffer='\0';
985   yylplex(newlib, libnamebuf, &lib_style, pl, autoexport);
986   if(yylp_errno)
987   {
988     Werror("Library %s: ERROR occurred: in line %d, %d.", newlib, yylplineno,
989          current_pos(0));
990     if(yylp_errno==YYLP_BAD_CHAR)
991     {
992       Werror(yylp_errlist[yylp_errno], *text_buffer, yylplineno);
993       omFree((ADDRESS)text_buffer);
994       text_buffer=NULL;
995     }
996     else
997       Werror(yylp_errlist[yylp_errno], yylplineno);
998     WerrorS("Cannot load library,... aborting.");
999     reinit_yylp();
1000     fclose( yylpin );
1001     iiCleanProcs(IDROOT);
1002     return TRUE;
1003   }
1004   if (BVERBOSE(V_LOAD_LIB))
1005     Print( "// ** loaded %s %s\n", libnamebuf, text_buffer);
1006   if( (lib_style == OLD_LIBSTYLE) && (BVERBOSE(V_LOAD_LIB)))
1007   {
1008     Warn( "library %s has old format. This format is still accepted,", newlib);
1009     WarnS( "but for functionality you may wish to change to the new");
1010     WarnS( "format. Please refer to the manual for further information.");
1011   }
1012   reinit_yylp();
1013   fclose( yylpin );
1014   fp = NULL;
1015   iiRunInit(IDPACKAGE(pl));
1016 
1017   {
1018     libstackv ls;
1019     for(ls = library_stack; (ls != NULL) && (ls != ls_start); )
1020     {
1021       if(ls->to_be_done)
1022       {
1023         ls->to_be_done=FALSE;
1024         iiLibCmd(ls->get(),autoexport,tellerror,FALSE);
1025         ls = ls->pop(newlib);
1026       }
1027     }
1028 #if 0
1029     PrintS("--------------------\n");
1030     for(ls = library_stack; ls != NULL; ls = ls->next)
1031     {
1032       Print("%s: LIB-stack:(%d), %s %s\n", newlib, ls->cnt, ls->get(),
1033         ls->to_be_done ? "not loaded" : "loaded");
1034     }
1035     PrintS("--------------------\n");
1036 #endif
1037   }
1038 
1039   if(fp != NULL) fclose(fp);
1040   return FALSE;
1041 }
1042 
1043 
1044 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
iiInitSingularProcinfo(procinfov pi,const char * libname,const char * procname,int,long pos,BOOLEAN pstatic)1045 procinfo *iiInitSingularProcinfo(procinfov pi, const char *libname,
1046               const char *procname, int, long pos, BOOLEAN pstatic)
1047 {
1048   memset(pi,0,sizeof(*pi));
1049   pi->libname = omStrDup(libname);
1050   pi->procname = omStrDup(procname);
1051   pi->language = LANG_SINGULAR;
1052   pi->ref = 1;
1053   pi->is_static = pstatic;
1054   pi->data.s.proc_start = pos;
1055   return(pi);
1056 }
1057 
1058 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
iiAddCproc(const char * libname,const char * procname,BOOLEAN pstatic,BOOLEAN (* func)(leftv res,leftv v))1059 int iiAddCproc(const char *libname, const char *procname, BOOLEAN pstatic,
1060                BOOLEAN(*func)(leftv res, leftv v))
1061 {
1062   procinfov pi;
1063   idhdl h;
1064 
1065   #ifndef SING_NDEBUG
1066   int dummy;
1067   if (IsCmd(procname,dummy))
1068   {
1069     Werror(">>%s< is a reserved name",procname);
1070     return 0;
1071   }
1072   #endif
1073 
1074   h=IDROOT->get(procname,0);
1075   if ((h!=NULL)
1076   && (IDTYP(h)==PROC_CMD))
1077   {
1078     pi = IDPROC(h);
1079     #if 0
1080     if ((pi->language == LANG_SINGULAR)
1081     &&(BVERBOSE(V_REDEFINE)))
1082       Warn("extend `%s`",procname);
1083     #endif
1084   }
1085   else
1086   {
1087     h = enterid(procname,0, PROC_CMD, &IDROOT, TRUE);
1088   }
1089   if ( h!= NULL )
1090   {
1091     pi = IDPROC(h);
1092     if((pi->language == LANG_SINGULAR)
1093     ||(pi->language == LANG_NONE))
1094     {
1095       omfree(pi->libname);
1096       pi->libname = omStrDup(libname);
1097       omfree(pi->procname);
1098       pi->procname = omStrDup(procname);
1099       pi->language = LANG_C;
1100       pi->ref = 1;
1101       pi->is_static = pstatic;
1102       pi->data.o.function = func;
1103     }
1104     else if(pi->language == LANG_C)
1105     {
1106       if(pi->data.o.function == func)
1107       {
1108         pi->ref++;
1109       }
1110       else
1111       {
1112         omfree(pi->libname);
1113         pi->libname = omStrDup(libname);
1114         omfree(pi->procname);
1115         pi->procname = omStrDup(procname);
1116         pi->language = LANG_C;
1117         pi->ref = 1;
1118         pi->is_static = pstatic;
1119         pi->data.o.function = func;
1120       }
1121     }
1122     else
1123       Warn("internal error: unknown procedure type %d",pi->language);
1124     if (currPack->language==LANG_SINGULAR) currPack->language=LANG_MIX;
1125     return(1);
1126   }
1127   else
1128   {
1129     WarnS("iiAddCproc: failed.");
1130   }
1131   return(0);
1132 }
1133 
iiAddCprocTop(const char * libname,const char * procname,BOOLEAN pstatic,BOOLEAN (* func)(leftv res,leftv v))1134 int iiAddCprocTop(const char *libname, const char *procname, BOOLEAN pstatic,
1135                BOOLEAN(*func)(leftv res, leftv v))
1136 {
1137   int r=iiAddCproc(libname,procname,pstatic,func);
1138   package s=currPack;
1139   currPack=basePack;
1140   if (r) r=iiAddCproc(libname,procname,pstatic,func);
1141   currPack=s;
1142   return r;
1143 }
1144 
1145 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1146 #ifdef HAVE_DYNAMIC_LOADING
1147 #include <map>
1148 #include <string>
1149 #include <pthread.h>
1150 
1151 THREAD_VAR std::map<std::string, void *> *dyn_modules;
1152 
registered_dyn_module(char * fullname)1153 bool registered_dyn_module(char *fullname) {
1154   if (dyn_modules == NULL)
1155     return false;
1156   std::string fname = fullname;
1157   return dyn_modules->count(fname) != 0;
1158 }
1159 
register_dyn_module(char * fullname,void * handle)1160 void register_dyn_module(char *fullname, void * handle) {
1161   std::string fname = fullname;
1162   if (dyn_modules == NULL)
1163     dyn_modules = new std::map<std::string, void *>();
1164   dyn_modules->insert(std::pair<std::string, void *>(fname, handle));
1165 }
1166 
close_all_dyn_modules()1167 void close_all_dyn_modules() {
1168   for (std::map<std::string, void *>::iterator it = dyn_modules->begin();
1169        it != dyn_modules->end();
1170        it++)
1171   {
1172     dynl_close(it->second);
1173   }
1174   delete dyn_modules;
1175   dyn_modules = NULL;
1176 }
load_modules_aux(const char * newlib,char * fullname,BOOLEAN autoexport)1177 BOOLEAN load_modules_aux(const char *newlib, char *fullname, BOOLEAN autoexport)
1178 {
1179 /*
1180   typedef int (*fktn_t)(int(*iiAddCproc)(const char *libname, const char *procname,
1181                                BOOLEAN pstatic,
1182                                BOOLEAN(*func)(leftv res, leftv v)));
1183 */
1184   SModulFunc_t fktn;
1185   idhdl pl;
1186   char *plib = iiConvName(newlib);
1187   BOOLEAN RET=TRUE;
1188   int token;
1189   int l=si_max((int)strlen(fullname),(int)strlen(newlib))+3;
1190   char *FullName=(char*)omAlloc0(l);
1191 
1192   if( *fullname != '/' &&  *fullname != '.' )
1193     sprintf(FullName, "./%s", newlib);
1194   else strncpy(FullName, fullname,l);
1195 
1196 
1197   if(IsCmd(plib, token))
1198   {
1199     Werror("'%s' is resered identifier\n", plib);
1200     goto load_modules_end;
1201   }
1202   pl = basePack->idroot->get(plib,0); /* packages only in top level
1203                                         (see enterid) */
1204   if ((pl!=NULL)
1205   &&(IDTYP(pl)==PACKAGE_CMD))
1206   {
1207     if(IDPACKAGE(pl)->language==LANG_C)
1208     {
1209       if (BVERBOSE(V_LOAD_LIB)) Warn( "%s already loaded as package", newlib);
1210       omFree(plib);
1211       return FALSE;
1212     }
1213     else if(IDPACKAGE(pl)->language==LANG_MIX)
1214     {
1215       if (BVERBOSE(V_LOAD_LIB)) Warn( "%s contain binary parts, cannot load", newlib);
1216       omFree(plib);
1217       return FALSE;
1218     }
1219   }
1220   else
1221   {
1222     pl = enterid( plib,0, PACKAGE_CMD, &IDROOT, TRUE );
1223     omFree(plib); /* enterid copied plib*/
1224     IDPACKAGE(pl)->libname=omStrDup(newlib);
1225   }
1226   IDPACKAGE(pl)->language = LANG_C;
1227   if (dynl_check_opened(FullName))
1228   {
1229     if (BVERBOSE(V_LOAD_LIB)) Warn( "%s already loaded as C library", fullname);
1230     omFreeSize(FullName,l);
1231     return FALSE;
1232   }
1233   if((IDPACKAGE(pl)->handle=dynl_open(FullName))==(void *)NULL)
1234   {
1235     Werror("dynl_open failed:%s", dynl_error());
1236     Werror("%s not found", newlib);
1237     killhdl2(pl,&(basePack->idroot),NULL); // remove package
1238     goto load_modules_end;
1239   }
1240   else
1241   {
1242     SModulFunctions sModulFunctions;
1243 
1244     package s=currPack;
1245     currPack=IDPACKAGE(pl);
1246     fktn = (SModulFunc_t)dynl_sym(IDPACKAGE(pl)->handle, "mod_init");
1247     if( fktn!= NULL)
1248     {
1249       sModulFunctions.iiArithAddCmd = iiArithAddCmd;
1250       if (autoexport) sModulFunctions.iiAddCproc = iiAddCprocTop;
1251       else            sModulFunctions.iiAddCproc = iiAddCproc;
1252       int ver=(*fktn)(&sModulFunctions);
1253       if (ver==MAX_TOK)
1254       {
1255         if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded %s\n", fullname);
1256       }
1257       else
1258       {
1259         Warn("loaded %s for a different version of Singular(expected MAX_TOK: %d, got %d)",fullname,MAX_TOK,ver);
1260       }
1261       currPack->loaded=1;
1262       currPack=s; /* reset currPack to previous */
1263       register_dyn_module(fullname, IDPACKAGE(pl)->handle);
1264       RET=FALSE;
1265     }
1266     else
1267     {
1268       Werror("mod_init not found:: %s\nThis is probably not a dynamic module for Singular!\n", dynl_error());
1269       errorreported=0;
1270       if(IDPACKAGE(pl)->idroot==NULL)
1271         killhdl2(pl,&(basePack->idroot),NULL); // remove package
1272     }
1273   }
1274 
1275   load_modules_end:
1276   omFreeSize(FullName,l);
1277   return RET;
1278 }
1279 
load_modules(const char * newlib,char * fullname,BOOLEAN autoexport)1280 BOOLEAN load_modules(const char *newlib, char *fullname, BOOLEAN autoexport)
1281 {
1282   GLOBAL_VAR static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER;
1283   pthread_mutex_lock(&mutex);
1284   BOOLEAN r = load_modules_aux(newlib, fullname, autoexport);
1285   pthread_mutex_unlock(&mutex);
1286   return r;
1287 }
1288 #endif /* HAVE_DYNAMIC_LOADING */
1289 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
load_builtin(const char * newlib,BOOLEAN autoexport,SModulFunc_t init)1290 BOOLEAN load_builtin(const char *newlib, BOOLEAN autoexport, SModulFunc_t init)
1291 {
1292   int iiAddCproc(const char *libname, const char *procname, BOOLEAN pstatic,
1293                  BOOLEAN(*func)(leftv res, leftv v));
1294 /*
1295   typedef int (*fktn_t)(int(*iiAddCproc)(const char *libname, const char *procname,
1296                                BOOLEAN pstatic,
1297                                BOOLEAN(*func)(leftv res, leftv v)));
1298 */
1299   // SModulFunc_t fktn;
1300   idhdl pl;
1301   char *plib = iiConvName(newlib);
1302   // BOOLEAN RET=TRUE;
1303   // int token;
1304 
1305   pl = basePack->idroot->get(plib,0); // search PACKAGE only in Top
1306   if ((pl!=NULL)
1307   &&(IDTYP(pl)==PACKAGE_CMD))
1308   {
1309     if(IDPACKAGE(pl)->language==LANG_C)
1310     {
1311       if (BVERBOSE(V_LOAD_LIB)) Warn( "(builtin) %s already loaded", newlib);
1312       omFree(plib);
1313       return FALSE;
1314     }
1315   }
1316   else
1317   {
1318     pl = enterid( plib,0, PACKAGE_CMD, &IDROOT, TRUE );
1319     IDPACKAGE(pl)->libname=omStrDup(newlib);
1320   }
1321   omFree(plib);
1322   IDPACKAGE(pl)->language = LANG_C;
1323 
1324   IDPACKAGE(pl)->handle=(void *)NULL;
1325   SModulFunctions sModulFunctions;
1326 
1327   package s=currPack;
1328   currPack=IDPACKAGE(pl);
1329   if( init!= NULL)
1330   {
1331     sModulFunctions.iiArithAddCmd = iiArithAddCmd;
1332     if (autoexport) sModulFunctions.iiAddCproc = iiAddCprocTop;
1333     else            sModulFunctions.iiAddCproc = iiAddCproc;
1334     (*init)(&sModulFunctions);
1335   }
1336   if (BVERBOSE(V_LOAD_LIB)) Print( "// ** loaded (builtin) %s \n", newlib);
1337   currPack->loaded=1;
1338   currPack=s;
1339 
1340   return FALSE;
1341 }
1342 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
module_help_main(const char * newlib,const char * help)1343 void module_help_main(const char *newlib,const char *help)
1344 {
1345   char *plib = iiConvName(newlib);
1346   idhdl pl = basePack->idroot->get(plib,0);
1347   if ((pl==NULL)||(IDTYP(pl)!=PACKAGE_CMD))
1348     Werror(">>%s<< is not a package (trying to add package help)",plib);
1349   else
1350   {
1351     package s=currPack;
1352     currPack=IDPACKAGE(pl);
1353     idhdl h=enterid("info",0,STRING_CMD,&IDROOT,FALSE);
1354     IDSTRING(h)=omStrDup(help);
1355     currPack=s;
1356   }
1357 }
module_help_proc(const char * newlib,const char * p,const char * help)1358 void module_help_proc(const char *newlib,const char *p, const char *help)
1359 {
1360   char *plib = iiConvName(newlib);
1361   idhdl pl = basePack->idroot->get(plib,0);
1362   if ((pl==NULL)||(IDTYP(pl)!=PACKAGE_CMD))
1363     Werror(">>%s<< is not a package(trying to add help for %s)",plib,p);
1364   else
1365   {
1366     package s=currPack;
1367     currPack=IDPACKAGE(pl);
1368     char buff[256];
1369     buff[255]='\0';
1370     strncpy(buff,p,255);
1371     strncat(buff,"_help",255-strlen(p));
1372     idhdl h=enterid(buff,0,STRING_CMD,&IDROOT,FALSE);
1373     IDSTRING(h)=omStrDup(help);
1374     currPack=s;
1375   }
1376 }
1377 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1378 
1379 #ifdef HAVE_DYNAMIC_LOADING
1380 // loads a dynamic module from the binary path and returns a named function
1381 // returns NULL, if something fails
binary_module_function(const char * newlib,const char * funcname)1382 void* binary_module_function(const char* newlib, const char* funcname)
1383 {
1384   void* result = NULL;
1385 
1386   const char* bin_dir = feGetResource('b');
1387   if (!bin_dir)  { return NULL; }
1388 
1389   char path_name[MAXPATHLEN];
1390   sprintf(path_name, "%s%s%s.%s", bin_dir, DIR_SEPP, newlib, MODULE_SUFFIX_STRING);
1391 
1392   void* openlib = dynl_open(path_name);
1393   if(!openlib)
1394   {
1395     Werror("dynl_open of %s failed:%s", path_name, dynl_error());
1396     return NULL;
1397   }
1398   result = dynl_sym(openlib, funcname);
1399   if (!result) Werror("%s: %s\n", funcname, dynl_error());
1400 
1401   return result;
1402 }
1403 #endif
1404 
1405 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
mytoupper(char c)1406 char mytoupper(char c)
1407 {
1408   if(c>=97 && c<=(97+26)) c-=32;
1409   return(c);
1410 }
1411 
mytolower(char c)1412 char mytolower(char c)
1413 {
1414   if(c>=65 && c<=(65+26)) c+=32;
1415   return(c);
1416 }
1417 
1418 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1419 //#if defined(WINNT)
1420 //#  define  FS_SEP '\\'
1421 //#else
1422 //#  define FS_SEP '/'
1423 //#endif
1424 
iiConvName(const char * libname)1425 char *iiConvName(const char *libname)
1426 {
1427   char *tmpname = omStrDup(libname);
1428   char *p = strrchr(tmpname, DIR_SEP);
1429   char *r;
1430   if(p==NULL) p = tmpname; else p++;
1431   // p is now the start of the file name (without path)
1432   r=p;
1433   while(isalnum(*r)||(*r=='_')) r++;
1434   // r point the the end of the main part of the filename
1435   *r = '\0';
1436   r = omStrDup(p);
1437   *r = mytoupper(*r);
1438   // printf("iiConvName: '%s' '%s' => '%s'\n", libname, tmpname, r);
1439   omFree((ADDRESS)tmpname);
1440 
1441   return(r);
1442 }
1443 
1444 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1445 #if 0 /* debug only */
1446 void piShowProcList()
1447 {
1448   idhdl h;
1449   procinfo *proc;
1450   char *name;
1451 
1452   Print( "%-15s  %20s      %s,%s  %s,%s   %s,%s\n", "Library", "function",
1453          "line", "start", "line", "body", "line", "example");
1454   for(h = IDROOT; h != NULL; h = IDNEXT(h))
1455   {
1456     if(IDTYP(h) == PROC_CMD)
1457     {
1458       proc = IDPROC(h);
1459       if(strcmp(proc->procname, IDID(h))!=0)
1460       {
1461         name = (char *)omAlloc(strlen(IDID(h))+strlen(proc->procname)+4);
1462         sprintf(name, "%s -> %s", IDID(h), proc->procname);
1463         Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname, name);
1464         omFree((ADDRESS)name);
1465       }
1466       else
1467         Print( "%d %-15s  %20s ", proc->is_static ? 1 : 0, proc->libname,
1468                proc->procname);
1469       if(proc->language==LANG_SINGULAR)
1470         Print("line %-5ld  %4d,%-5ld  %4d,%-5ld\n",
1471               proc->data.s.proc_start,
1472               proc->data.s.body_lineno, proc->data.s.body_start,
1473               proc->data.s.example_lineno, proc->data.s.example_start);
1474       else if(proc->language==LANG_C)
1475         PrintS("type: object\n");
1476     }
1477   }
1478 }
1479 #endif
1480 
1481 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1482 //char *iiLineNo(char *procname, int lineno)
1483 //{
1484 //  char buf[256];
1485 //  idhdl pn = ggetid(procname);
1486 //  procinfo *pi = IDPROC(pn);
1487 //
1488 //  sprintf(buf, "%s %3d\0", procname, lineno);
1489 //  //sprintf(buf, "%s::%s %3d\0", pi->libname, pi->procname,
1490 //  //  lineno + pi->data.s.body_lineno);
1491 //  return(buf);
1492 //}
1493 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1494 #ifdef HAVE_LIBPARSER
push(const char *,char * libn)1495 void libstack::push(const char */*p*/, char *libn)
1496 {
1497   libstackv lp;
1498   if( !iiGetLibStatus(libn))
1499   {
1500     for(lp = this;lp!=NULL;lp=lp->next)
1501     {
1502       if(strcmp(lp->get(), libn)==0) break;
1503     }
1504     if(lp==NULL)
1505     {
1506       libstackv ls = (libstack *)omAlloc0Bin(libstack_bin);
1507       ls->next = this;
1508       ls->libname = omStrDup(libn);
1509       ls->to_be_done = TRUE;
1510       if(library_stack != NULL) ls->cnt = library_stack->cnt+1; else ls->cnt = 0;
1511       library_stack = ls;
1512     }
1513   }
1514 }
1515 
pop(const char *)1516 libstackv libstack::pop(const char */*p*/)
1517 {
1518   libstackv ls = this;
1519   //omFree((ADDRESS)ls->libname);
1520   library_stack = ls->next;
1521   omFreeBin((ADDRESS)ls,  libstack_bin);
1522   return(library_stack);
1523 }
1524 
1525 #endif /* HAVE_LIBPARSER */
1526 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
1527