"Fossies" - the Fresh Open Source Software Archive

Member "singular-4.2.1/Singular/iplib.cc" (9 Jun 2021, 39988 Bytes) of package /linux/misc/singular-4.2.1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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 */
   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 */
   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 */
  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 */
  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 
  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 */
  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
  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 
  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 }
  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 }
  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 }
  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 
  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
  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 
  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
  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 */
  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
  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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
  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 */
  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 
  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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
  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 }
  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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
  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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
 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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
 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 
 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 
 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 
 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 
 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 }
 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 
 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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
 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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
 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 }
 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
 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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/
 1406 char mytoupper(char c)
 1407 {
 1408   if(c>=97 && c<=(97+26)) c-=32;
 1409   return(c);
 1410 }
 1411 
 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 
 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
 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 
 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 /*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*/