source: git/Singular/extra.cc @ a4f307a

spielwiese
Last change on this file since a4f307a was a4f307a, checked in by Olaf Bachmann <obachman@…>, 23 years ago
* update prCopy stuff git-svn-id: file:///usr/local/Singular/svn/trunk@4836 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 32.9 KB
Line 
1/*****************************************
2*  Computer Algebra System SINGULAR      *
3*****************************************/
4/* $Id: extra.cc,v 1.151 2000-12-07 15:42:30 obachman Exp $ */
5/*
6* ABSTRACT: general interface to internals of Singular ("system" command)
7*/
8
9#include <stdlib.h>
10#include <stdio.h>
11#include <string.h>
12#include <ctype.h>
13#include <signal.h>
14#include "mod2.h"
15
16#ifndef __MWERKS__
17#ifdef TIME_WITH_SYS_TIME
18# include <time.h>
19# ifdef HAVE_SYS_TIME_H
20#   include <sys/time.h>
21# endif
22#else
23# ifdef HAVE_SYS_TIME_H
24#   include <sys/time.h>
25# else
26#   include <time.h>
27# endif
28#endif
29#ifdef HAVE_SYS_TIMES_H
30#include <sys/times.h>
31#endif
32
33#endif
34#include <unistd.h>
35
36#include "tok.h"
37#include "ipid.h"
38#include "polys.h"
39#include "kutil.h"
40#include "cntrlc.h"
41#include "stairc.h"
42#include "ipshell.h"
43#include "algmap.h"
44#include "modulop.h"
45#include "febase.h"
46#include "matpol.h"
47#include "longalg.h"
48#include "ideals.h"
49#include "kstd1.h"
50#include "syz.h"
51#include "sdb.h"
52#include "feOpt.h"
53#include "distrib.h"
54#include "prCopy.h"
55#include "mpr_complex.h"
56
57#include "walk.h"
58
59#ifdef HAVE_SPECTRUM
60#include "spectrum.h"
61#endif
62
63#ifdef HAVE_PLURAL
64#include "gring.h"
65#endif
66
67// Define to enable many more system commands
68#ifndef MAKE_DISTRIBUTION
69#define HAVE_EXTENDED_SYSTEM
70#endif
71
72#ifdef HAVE_FACTORY
73#define SI_DONT_HAVE_GLOBAL_VARS
74#include "clapsing.h"
75#include "clapconv.h"
76#include "kstdfac.h"
77#endif
78
79#include "silink.h"
80#ifdef HAVE_MPSR
81#include "mpsr.h"
82#include "MPT_GP.h"
83#endif
84#include "walk.h"
85
86/*
87 *   New function/system-calls that will be included as dynamic module
88 * should be inserted here.
89 * - without HAVE_DYNAMIC_LOADING: these functions comes as system("....");
90 * - with    HAVE_DYNAMIC_LOADING: these functions are loaded as module.
91 */
92#ifndef HAVE_DYNAMIC_LOADING
93#ifdef HAVE_PCV
94#include "pcv.h"
95#endif
96#endif /* not HAVE_DYNAMIC_LOADING */
97
98// see clapsing.cc for a description of the `FACTORY_*' options
99
100#ifdef FACTORY_GCD_STAT
101#include "gcd_stat.h"
102#endif
103
104#ifdef FACTORY_GCD_TIMING
105#define TIMING
106#include "timing.h"
107TIMING_DEFINE_PRINTPROTO( contentTimer );
108TIMING_DEFINE_PRINTPROTO( algContentTimer );
109TIMING_DEFINE_PRINTPROTO( algLcmTimer );
110#endif
111
112void piShowProcList();
113#ifndef MAKE_DISTRIBUTION
114static BOOLEAN jjEXTENDED_SYSTEM(leftv res, leftv h);
115#endif
116
117
118//void emStart();
119/*2
120*  the "system" command
121*/
122BOOLEAN jjSYSTEM(leftv res, leftv args)
123{
124  if(args->Typ() == STRING_CMD)
125  {
126    const char *sys_cmd=(char *)(args->Data());
127    leftv h=args->next;
128// ONLY documented system calls go here
129// Undocumented system calls go down into #ifdef HAVE_EXTENDED_SYSTEM
130/*==================== nblocks ==================================*/
131    if (strcmp(sys_cmd, "nblocks") == 0)
132    {
133      ring r;
134      if (h == NULL)
135      {
136        if (currRingHdl != NULL)
137        {
138          r = IDRING(currRingHdl);
139        }
140        else
141        {
142          WerrorS("no ring active");
143          return TRUE;
144        }
145      }
146      else
147      {
148        if (h->Typ() != RING_CMD)
149        {
150          WerrorS("ring expected");
151          return TRUE;
152        }
153        r = (ring) h->Data();
154      }
155      res->rtyp = INT_CMD;
156      res->data = (void*) (rBlocks(r) - 1);
157      return FALSE;
158    }
159/*==================== version ==================================*/
160    if(strcmp(sys_cmd,"version")==0)
161    {
162      res->rtyp=INT_CMD;
163      res->data=(void *)SINGULAR_VERSION;
164      return FALSE;
165    }
166    else
167/*==================== gen ==================================*/
168    if(strcmp(sys_cmd,"gen")==0)
169    {
170      res->rtyp=INT_CMD;
171      res->data=(void *)npGen;
172      return FALSE;
173    }
174    else
175/*==================== sh ==================================*/
176    if(strcmp(sys_cmd,"sh")==0)
177    {
178      res->rtyp=INT_CMD;
179      #ifndef __MWERKS__
180      if (h==NULL) res->data = (void *)system("sh");
181      else if (h->Typ()==STRING_CMD)
182        res->data = (void*) system((char*)(h->Data()));
183      else
184        WerrorS("string expected");
185      #else
186      res->data=(void *)0;
187      #endif
188      return FALSE;
189    }
190    else
191/*==================== uname ==================================*/
192    if(strcmp(sys_cmd,"uname")==0)
193    {
194      res->rtyp=STRING_CMD;
195      res->data = omStrDup(S_UNAME);
196      return FALSE;
197    }
198    else
199/*==================== with ==================================*/
200    if(strcmp(sys_cmd,"with")==0)
201    {
202      if (h==NULL)
203      {
204        res->rtyp=STRING_CMD;
205        res->data=(void *)omStrDup(versionString());
206        return FALSE;
207      }
208      else if (h->Typ()==STRING_CMD)
209      {
210        #define TEST_FOR(A) if(strcmp(s,A)==0) res->data=(void *)1; else
211        char *s=(char *)h->Data();
212        res->rtyp=INT_CMD;
213        #ifdef HAVE_DBM
214          TEST_FOR("DBM")
215        #endif
216        #ifdef HAVE_DLD
217          TEST_FOR("DLD")
218        #endif
219        #ifdef HAVE_FACTORY
220          TEST_FOR("factory")
221        #endif
222        #ifdef HAVE_LIBFAC_P
223          TEST_FOR("libfac")
224        #endif
225        #ifdef HAVE_MPSR
226          TEST_FOR("MP")
227        #endif
228        #ifdef HAVE_READLINE
229          TEST_FOR("readline")
230        #endif
231        #ifdef HAVE_TCL
232          TEST_FOR("tcl")
233        #endif
234        #ifdef TEST_MAC_ORDER
235          TEST_FOR("MAC_ORDER");
236        #endif
237        #ifdef HAVE_NAMESPACES
238          TEST_FOR("Namespaces");
239        #endif
240        #ifdef HAVE_DYNAMIC_LOADING
241          TEST_FOR("DynamicLoading");
242        #endif
243          ;
244        return FALSE;
245        #undef TEST_FOR
246      }
247      return TRUE;
248    }
249    else
250/*==================== browsers ==================================*/
251    if (strcmp(sys_cmd,"browsers")==0)
252    {
253      res->rtyp = STRING_CMD;
254      char* b = StringSetS("");
255      feStringAppendBrowsers(0);
256      res->data = omStrDup(b);
257      return FALSE;
258    }
259    else
260/*==================== pid ==================================*/
261    if (strcmp(sys_cmd,"pid")==0)
262    {
263      res->rtyp=INT_CMD;
264    #ifndef MSDOS
265    #ifndef __MWERKS__
266      res->data=(void *)getpid();
267    #else
268      res->data=(void *)1;
269    #endif
270    #else
271      res->data=(void *)1;
272    #endif
273      return FALSE;
274    }
275    else
276/*==================== getenv ==================================*/
277    if (strcmp(sys_cmd,"getenv")==0)
278    {
279      if ((h!=NULL) && (h->Typ()==STRING_CMD))
280      {
281        res->rtyp=STRING_CMD;
282        char *r=getenv((char *)h->Data());
283        if (r==NULL) r="";
284        res->data=(void *)omStrDup(r);
285        return FALSE;
286      }
287      else
288      {
289        WerrorS("string expected");
290        return TRUE;
291      }
292    }
293    else
294/*==================== setenv ==================================*/
295    if (strcmp(sys_cmd,"setenv")==0)
296    {
297#ifdef HAVE_SETENV
298      if (h!=NULL && h->Typ()==STRING_CMD && h->Data() != NULL &&
299          h->next != NULL && h->next->Typ() == STRING_CMD
300          && h->next->Data() != NULL)
301      {
302        res->rtyp=STRING_CMD;
303        setenv((char *)h->Data(), (char *)h->next->Data(), 1);
304        res->data=(void *)omStrDup((char *)h->next->Data());
305        feReInitResources();
306        return FALSE;
307      }
308      else
309      {
310        WerrorS("two strings expected");
311        return TRUE;
312      }
313#else
314      WerrorS("setenv not supported on this platform");
315      return TRUE;
316#endif
317    }
318    else
319/*==================== Singular ==================================*/
320    if (strcmp(sys_cmd, "Singular") == 0)
321    {
322      res->rtyp=STRING_CMD;
323      char *r=feResource("Singular");
324      if (r != NULL)
325        res->data = (void*) omStrDup( r );
326      else
327        res->data = (void*) omStrDup("");
328      return FALSE;
329    }
330    else
331/*==================== options ==================================*/
332    if (strstr(sys_cmd, "--") == sys_cmd)
333    {
334      if (strcmp(sys_cmd, "--") == 0)
335      {
336        fePrintOptValues();
337        return FALSE;
338      }
339
340      feOptIndex opt = feGetOptIndex(&sys_cmd[2]);
341      if (opt == FE_OPT_UNDEF)
342      {
343        Werror("Unknown option %s", sys_cmd);
344        Werror("Use 'system(\"--\");' for listing of available options");
345        return TRUE;
346      }
347
348      // for Untyped Options (help version),
349      // setting it just triggers action
350      if (feOptSpec[opt].type == feOptUntyped)
351      {
352        feSetOptValue(opt,NULL);
353        return FALSE;
354      }
355
356      if (h == NULL)
357      {
358        if (feOptSpec[opt].type == feOptString)
359        {
360          res->rtyp = STRING_CMD;
361          if (feOptSpec[opt].value != NULL)
362            res->data = omStrDup((char*) feOptSpec[opt].value);
363          else
364            res->data = omStrDup("");
365        }
366        else
367        {
368          res->rtyp = INT_CMD;
369          res->data = feOptSpec[opt].value;
370        }
371        return FALSE;
372      }
373
374      if (h->Typ() != STRING_CMD &&
375          h->Typ() != INT_CMD)
376      {
377        Werror("Need string or int argument to set option value");
378        return TRUE;
379      }
380      char* errormsg;
381      if (h->Typ() == INT_CMD)
382      {
383        if (feOptSpec[opt].type == feOptString)
384        {
385          Werror("Need string argument to set value of option %s", sys_cmd);
386          return TRUE;
387        }
388        errormsg = feSetOptValue(opt, (int) h->Data());
389        if (errormsg != NULL)
390          Werror("Option '--%s=%d' %s", sys_cmd, (int) h->Data(), errormsg);
391      }
392      else
393      {
394        errormsg = feSetOptValue(opt, (char*) h->Data());
395        if (errormsg != NULL)
396          Werror("Option '--%s=%s' %s", sys_cmd, (char*) h->Data(), errormsg);
397      }
398      if (errormsg != NULL) return TRUE;
399      return FALSE;
400    }
401    else
402/*==================== HC ==================================*/
403    if (strcmp(sys_cmd,"HC")==0)
404    {
405      res->rtyp=INT_CMD;
406      res->data=(void *)HCord;
407      return FALSE;
408    }
409    else
410/*==================== random ==================================*/
411    if(strcmp(sys_cmd,"random")==0)
412    {
413      if ((h!=NULL) &&(h->Typ()==INT_CMD))
414      {
415        siRandomStart=(int)h->Data();
416#ifdef buildin_rand
417        siSeed=siRandomStart;
418#else
419        srand((unsigned int)siRandomStart);
420#endif
421#ifdef HAVE_FACTORY
422        factoryseed(siRandomStart);
423#endif
424        return FALSE;
425      }
426      else if (h != NULL)
427      {
428        WerrorS("int expected");
429        return TRUE;
430      }
431      res->rtyp=INT_CMD;
432      res->data=(void*) siRandomStart;
433      return FALSE;
434    }
435/*==================== complexNearZero ======================*/
436    if(strcmp(sys_cmd,"complexNearZero")==0)
437    {
438      if (h->Typ()==NUMBER_CMD )
439      {
440        if ( h->next!=NULL && h->next->Typ()==INT_CMD )
441        {
442          if ( !rField_is_long_C() )
443            {
444              Werror( "unsupported ground field!");
445              return TRUE;
446            }
447          else
448            {
449              res->rtyp=INT_CMD;
450              res->data=(void*)complexNearZero((gmp_complex*)h->Data(),(int)h->next->Data());
451              return FALSE;
452            }
453        }
454        else
455        {
456          Werror( "expected <int> as third parameter!");
457          return TRUE;
458        }
459      }
460      else
461      {
462        Werror( "expected <number> as second parameter!");
463        return TRUE;
464      }
465    }
466/*==================== getPrecDigits ======================*/
467    if(strcmp(sys_cmd,"getPrecDigits")==0)
468    {
469      if ( !rField_is_long_C() && !rField_is_long_R() )
470      {
471        Werror( "unsupported ground field!");
472        return TRUE;
473      }
474      res->rtyp=INT_CMD;
475      res->data=(void*)getGMPFloatDigits();
476      return FALSE;
477    }
478/*==================== neworder =============================*/
479// should go below
480#ifdef HAVE_LIBFAC_P
481    if(strcmp(sys_cmd,"neworder")==0)
482    {
483      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
484      {
485        res->rtyp=STRING_CMD;
486        res->data=(void *)singclap_neworder((ideal)h->Data());
487        return FALSE;
488      }
489      else
490        WerrorS("ideal expected");
491    }
492    else
493#endif
494/*==================== pcv ==================================*/
495#ifndef HAVE_DYNAMIC_LOADING
496#ifdef HAVE_PCV
497    if(strcmp(sys_cmd,"pcvLAddL")==0)
498    {
499      return pcvLAddL(res,h);
500    }
501    else
502    if(strcmp(sys_cmd,"pcvPMulL")==0)
503    {
504      return pcvPMulL(res,h);
505    }
506    else
507    if(strcmp(sys_cmd,"pcvMinDeg")==0)
508    {
509      return pcvMinDeg(res,h);
510    }
511    else
512    if(strcmp(sys_cmd,"pcvP2CV")==0)
513    {
514      return pcvP2CV(res,h);
515    }
516    else
517    if(strcmp(sys_cmd,"pcvCV2P")==0)
518    {
519      return pcvCV2P(res,h);
520    }
521    else
522    if(strcmp(sys_cmd,"pcvDim")==0)
523    {
524      return pcvDim(res,h);
525    }
526    else
527    if(strcmp(sys_cmd,"pcvBasis")==0)
528    {
529      return pcvBasis(res,h);
530    }
531    else
532#endif
533#endif /* HAVE_DYNAMIC_LOADING */
534/*==================== contributors =============================*/
535   if(strcmp(sys_cmd,"contributors") == 0)
536   {
537     res->rtyp=STRING_CMD;
538     res->data=(void *)omStrDup(
539       "Olaf Bachmann, Hubert Grassmann, Kai Krueger, Wolfgang Neumann, Thomas Nuessler, Wilfred Pohl, Jens Schmidt, Thomas Siebert, Ruediger Stobbe, Moritz Wenk, Tim Wichmann");
540     return FALSE;
541   }
542   else
543/*==================== spectrum =============================*/
544   #ifdef HAVE_SPECTRUM
545   if(strcmp(sys_cmd,"spectrum") == 0)
546   {
547     if (h->Typ()!=POLY_CMD)
548     {
549       WerrorS("poly expected");
550       return TRUE;
551     }
552     if (h->next==NULL)
553       return spectrumProc(res,h);
554     if (h->next->Typ()!=INT_CMD)
555     {
556       WerrorS("poly,int expected");
557       return TRUE;
558     }
559     if(((int)h->next->Data())==1)
560       return spectrumfProc(res,h);
561     return spectrumProc(res,h);
562   }
563   else
564/*==================== semic =============================*/
565   if(strcmp(sys_cmd,"semic") == 0)
566   {
567     if ((h->next!=NULL)
568     && (h->Typ()==LIST_CMD)
569     && (h->next->Typ()==LIST_CMD))
570     {
571       if (h->next->next==NULL)
572         return semicProc(res,h,h->next);
573       else if (h->next->next->Typ()==INT_CMD)
574         return semicProc3(res,h,h->next,h->next->next);
575     }
576     return TRUE;
577   }
578   else
579/*==================== spadd =============================*/
580   if(strcmp(sys_cmd,"spadd") == 0)
581   {
582     if ((h->next!=NULL)
583     && (h->Typ()==LIST_CMD)
584     && (h->next->Typ()==LIST_CMD))
585     {
586       if (h->next->next==NULL)
587         return spaddProc(res,h,h->next);
588     }
589     return TRUE;
590   }
591   else
592/*==================== spmul =============================*/
593   if(strcmp(sys_cmd,"spmul") == 0)
594   {
595     if ((h->next!=NULL)
596     && (h->Typ()==LIST_CMD)
597     && (h->next->Typ()==INT_CMD))
598     {
599       if (h->next->next==NULL)
600         return spmulProc(res,h,h->next);
601     }
602     return TRUE;
603   }
604   else
605   #endif
606/*================= Extended system call ========================*/
607   {
608     #ifndef MAKE_DISTRIBUTION
609     return(jjEXTENDED_SYSTEM(res, args));
610     #else
611     Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
612     #endif
613   }
614  } /* typ==string */
615  return TRUE;
616}
617
618
619
620#ifdef HAVE_EXTENDED_SYSTEM
621// You can put your own system calls here
622#include "fglmcomb.cc"
623#include "fglm.h"
624#ifdef HAVE_NEWTON
625#include <hc_newton.h>
626#endif
627#include "mpsr.h"
628
629#include "mod_raw.h"
630   
631static BOOLEAN jjEXTENDED_SYSTEM(leftv res, leftv h)
632{
633  if(h->Typ() == STRING_CMD)
634  {
635    char *sys_cmd=(char *)(h->Data());
636    h=h->next;
637#ifdef RDEBUG
638/*==================== poly debug ==================================*/
639    if(strcmp(sys_cmd,"p")==0)
640    {
641      pDebugPrint((poly)h->Data());
642      return FALSE;
643    }
644    else
645/*==================== ring debug ==================================*/
646    if(strcmp(sys_cmd,"r")==0)
647    {
648      rDebugPrint((ring)h->Data());
649      return FALSE;
650    }
651    else
652#endif
653/*==================== mtrack ==================================*/
654    if(strcmp(sys_cmd,"mtrack")==0)
655    {
656#ifdef OM_TRACK
657      om_Opts.MarkAsStatic = 1;
658      FILE *fd = NULL;
659      int max = 5;
660      while (h != NULL)
661      {
662        omMarkAsStaticAddr(h);
663        if (fd == NULL && h->Typ()==STRING_CMD)
664        {
665          fd = fopen((char*) h->Data(), "w");
666          if (fd == NULL)
667            Warn("Can not open %s for writing og mtrack. Using stdout");
668        }
669        if (h->Typ() == INT_CMD)
670        {
671          max = (int) h->Data();
672        }
673        h = h->Next();
674      }
675      omPrintUsedTrackAddrs((fd == NULL ? stdout : fd), max);
676      if (fd != NULL) fclose(fd);
677      om_Opts.MarkAsStatic = 0;
678      return FALSE;
679#else
680     WerrorS("mtrack not supported without OM_TRACK");
681     return TRUE;
682#endif
683    }
684/*==================== mtrack_all ==================================*/
685    if(strcmp(sys_cmd,"mtrack_all")==0)
686    {
687#ifdef OM_TRACK
688      om_Opts.MarkAsStatic = 1;
689      FILE *fd = NULL;
690      if ((h!=NULL) &&(h->Typ()==STRING_CMD))
691      {
692        fd = fopen((char*) h->Data(), "w");
693        if (fd == NULL)
694          Warn("Can not open %s for writing og mtrack. Using stdout");
695        omMarkAsStaticAddr(h);
696      }
697      // OB: TBC print to fd
698      omPrintUsedAddrs((fd == NULL ? stdout : fd), 5);
699      if (fd != NULL) fclose(fd);
700      om_Opts.MarkAsStatic = 0;
701      return FALSE;
702#else
703     WerrorS("mtrack not supported without OM_TRACK");
704     return TRUE;
705#endif
706    }
707    else
708/*==================== backtrace ==================================*/
709    if(strcmp(sys_cmd,"backtrace")==0)
710    {
711#ifndef OM_NDEBUG
712      omPrintCurrentBackTrace(stdout);
713      return FALSE;
714#else
715     WerrorS("btrack not supported without OM_TRACK");
716     return TRUE;
717#endif
718    }
719    else
720/*==================== naIdeal ==================================*/
721    if(strcmp(sys_cmd,"naIdeal")==0)
722    {
723      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
724      {
725        naSetIdeal((ideal)h->Data());
726        return FALSE;
727      }
728      else
729         WerrorS("ideal expected");
730    }
731    else
732/*==================== isSqrFree =============================*/
733#ifdef HAVE_FACTORY
734    if(strcmp(sys_cmd,"isSqrFree")==0)
735    {
736      if ((h!=NULL) &&(h->Typ()==POLY_CMD))
737      {
738        res->rtyp=INT_CMD;
739        res->data=(void *)singclap_isSqrFree((poly)h->Data());
740        return FALSE;
741      }
742      else
743        WerrorS("poly expected");
744    }
745    else
746#endif
747/*==================== pDivStat =============================*/
748#if defined(PDEBUG) || defined(PDIV_DEBUG)
749    if(strcmp(sys_cmd,"pDivStat")==0)
750    {
751      extern void pPrintDivisbleByStat();
752      pPrintDivisbleByStat();
753      return FALSE;
754    }
755    else
756#endif
757/*==================== alarm ==================================*/
758#ifndef __MWERKS__
759#ifndef MSDOS
760#ifndef atarist
761#ifdef unix
762    if(strcmp(sys_cmd,"alarm")==0)
763    {
764      if ((h!=NULL) &&(h->Typ()==INT_CMD))
765      {
766        // standard variant -> SIGALARM (standard: abort)
767        //alarm((unsigned)h->next->Data());
768        // process time (user +system): SIGVTALARM
769        struct itimerval t,o;
770        memset(&t,0,sizeof(t));
771        t.it_value.tv_sec     =(unsigned)h->Data();
772        setitimer(ITIMER_VIRTUAL,&t,&o);
773        return FALSE;
774      }
775      else
776        WerrorS("int expected");
777    }
778    else
779#endif
780#endif
781#endif
782#endif
783/*==================== red =============================*/
784#if 0
785    if(strcmp(sys_cmd,"red")==0)
786    {
787      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
788      {
789        res->rtyp=IDEAL_CMD;
790        res->data=(void *)kStdred((ideal)h->Data(),NULL,testHomog,NULL);
791        setFlag(res,FLAG_STD);
792        return FALSE;
793      }
794      else
795        WerrorS("ideal expected");
796    }
797    else
798#endif
799/*==================== algfetch =====================*/
800    if (strcmp(sys_cmd,"algfetch")==0)
801    {
802      int k;
803      idhdl w;
804      ideal i0, i1;
805      ring r0=(ring)h->Data();
806      leftv v = h->next;
807      w = r0->idroot->get(v->Name(),myynest);
808      if (w!=NULL)
809      {
810        if (IDTYP(w)==IDEAL_CMD)
811        {
812          i0 = IDIDEAL(w);
813          i1 = idInit(IDELEMS(i0),i0->rank);
814          for (k=0; k<IDELEMS(i1); k++)
815          {
816            i1->m[k] = maAlgpolyFetch(r0, i0->m[k]);
817          }
818          res->rtyp = IDEAL_CMD;
819          res->data = (void*)i1;
820          return FALSE;
821        }
822        else if (IDTYP(w)==POLY_CMD)
823        {
824          res->rtyp = POLY_CMD;
825          res->data = (void*)maAlgpolyFetch(r0,IDPOLY(w));
826          return FALSE;
827        }
828        else
829          WerrorS("`system(\"algfetch\",<ideal>/<poly>)` expected");
830      }
831      else
832        Werror("`%s` not found in `%s`",v->Name(),h->Name());
833    }
834    else
835/*==================== algmap =======================*/
836    if (strcmp(sys_cmd,"algmap")==0)
837    {
838      int k;
839      idhdl w;
840      ideal i0, i1, i, j;
841      ring r0=(ring)h->Data();
842      leftv v = h->next;
843      w = r0->idroot->get(v->Name(),myynest);
844      i0 = IDIDEAL(w);
845      v = v->next;
846      i = (ideal)v->Data();
847      v = v->next;
848      j = (ideal)v->Data();
849      i1 = idInit(IDELEMS(i0),i0->rank);
850      for (k=0; k<IDELEMS(i1); k++)
851      {
852        i1->m[k] = maAlgpolyMap(r0, i0->m[k], i, j);
853      }
854      res->rtyp = IDEAL_CMD;
855      res->data = (void*)i1;
856      return FALSE;
857    }
858    else
859#ifdef HAVE_FACTORY
860/*==================== fastcomb =============================*/
861    if(strcmp(sys_cmd,"fastcomb")==0)
862    {
863      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
864      {
865        int i=0;
866        if (h->next!=NULL)
867        {
868          if (h->next->Typ()!=POLY_CMD)
869          {
870            Warn("Wrong types for poly= comb(ideal,poly)");
871          }
872        }
873        res->rtyp=POLY_CMD;
874        res->data=(void *) fglmLinearCombination(
875                           (ideal)h->Data(),(poly)h->next->Data());
876        return FALSE;
877      }
878      else
879        WerrorS("ideal expected");
880    }
881    else
882/*==================== comb =============================*/
883    if(strcmp(sys_cmd,"comb")==0)
884    {
885      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
886      {
887        int i=0;
888        if (h->next!=NULL)
889        {
890          if (h->next->Typ()!=POLY_CMD)
891          {
892              Warn("Wrong types for poly= comb(ideal,poly)");
893          }
894        }
895        res->rtyp=POLY_CMD;
896        res->data=(void *)fglmNewLinearCombination(
897                            (ideal)h->Data(),(poly)h->next->Data());
898        return FALSE;
899      }
900      else
901        WerrorS("ideal expected");
902    }
903    else
904#endif
905#ifdef FACTORY_GCD_TEST
906/*=======================gcd Testerei ================================*/
907    if ( ! strcmp( sys_cmd, "setgcd" ) ) {
908        if ( (h != NULL) && (h->Typ() == INT_CMD) ) {
909            CFPrimitiveGcdUtil::setAlgorithm( (int)h->Data() );
910            return FALSE;
911        } else
912            WerrorS("int expected");
913    }
914    else
915#endif
916
917#ifdef FACTORY_GCD_TIMING
918    if ( ! strcmp( sys_cmd, "gcdtime" ) ) {
919        TIMING_PRINT( contentTimer, "time used for content: " );
920        TIMING_PRINT( algContentTimer, "time used for algContent: " );
921        TIMING_PRINT( algLcmTimer, "time used for algLcm: " );
922        TIMING_RESET( contentTimer );
923        TIMING_RESET( algContentTimer );
924        TIMING_RESET( algLcmTimer );
925        return FALSE;
926    }
927    else
928#endif
929
930#ifdef FACTORY_GCD_STAT
931    if ( ! strcmp( sys_cmd, "gcdstat" ) ) {
932        printGcdTotal();
933        printContTotal();
934        resetGcdTotal();
935        resetContTotal();
936        return FALSE;
937    }
938    else
939#endif
940/*==================== lib ==================================*/
941    if(strcmp(sys_cmd,"LIB")==0)
942    {
943#ifdef HAVE_NAMESPACES
944      idhdl hh=namespaceroot->get((char*)h->Data(),0);
945#else /* HAVE_NAMESPACES */
946      idhdl hh=idroot->get((char*)h->Data(),0);
947#endif /* HAVE_NAMESPACES */
948      if ((hh!=NULL)&&(IDTYP(hh)==PROC_CMD))
949      {
950        res->rtyp=STRING_CMD;
951        char *r=iiGetLibName(IDPROC(hh));
952        if (r==NULL) r="";
953        res->data=omStrDup(r);
954        return FALSE;
955      }
956      else
957        Warn("`%s` not found",(char*)h->Data());
958    }
959    else
960#ifdef HAVE_NAMESPACES
961/*==================== nspush ===================================*/
962    if(strcmp(sys_cmd,"nspush")==0)
963    {
964      if (h->Typ()==PACKAGE_CMD)
965      {
966        idhdl hh=(idhdl)h->data;
967        namespaceroot = namespaceroot->push(IDPACKAGE(hh), IDID(hh));
968        return FALSE;
969      }
970      else
971        Warn("argument 2 is not a package");
972    }
973    else
974/*==================== nspop ====================================*/
975    if(strcmp(sys_cmd,"nspop")==0)
976    {
977      namespaceroot->pop();
978      return FALSE;
979    }
980    else
981#endif /* HAVE_NAMESPACES */
982/*==================== nsstack ===================================*/
983    if(strcmp(sys_cmd,"nsstack")==0)
984    {
985      namehdl nshdl = namespaceroot;
986      for( ; nshdl->isroot != TRUE; nshdl = nshdl->next) {
987        Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
988      }
989      Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
990      return FALSE;
991    }
992    else
993/*==================== proclist =================================*/
994    if(strcmp(sys_cmd,"proclist")==0)
995    {
996      piShowProcList();
997      return FALSE;
998    }
999    else
1000/* ==================== newton ================================*/
1001#ifdef HAVE_NEWTON
1002    if(strcmp(sys_cmd,"newton")==0)
1003    {
1004      if ((h->Typ()!=POLY_CMD)
1005      || (h->next->Typ()!=INT_CMD)
1006      || (h->next->next->Typ()!=INT_CMD))
1007      {
1008        WerrorS("system(\"newton\",<poly>,<int>,<int>) expected");
1009        return TRUE;
1010      }
1011      poly  p=(poly)(h->Data());
1012      int l=pLength(p);
1013      short *points=(short *)omAlloc(currRing->N*l*sizeof(short));
1014      int i,j,k;
1015      k=0;
1016      poly pp=p;
1017      for (i=0;pp!=NULL;i++)
1018      {
1019        for(j=1;j<=currRing->N;j++)
1020        {
1021          points[k]=pGetExp(pp,j);
1022          k++;
1023        }
1024        pIter(pp);
1025      }
1026      hc_ERG r=hc_KOENIG(currRing->N,      // dimension
1027                l,      // number of points
1028                (short*) points,   // points: x_1, y_1,z_1, x_2,y_2,z2,...
1029                currRing->OrdSgn==-1,
1030                (int) (h->next->Data()),      // 1: Milnor, 0: Newton
1031                (int) (h->next->next->Data()) // debug
1032               );
1033      //----<>---Output-----------------------
1034
1035
1036//  PrintS("Bin jetzt in extra.cc bei der Auswertung.\n"); // **********
1037
1038
1039      lists L=(lists)omAllocBin(slists_bin);
1040      L->Init(6);
1041      L->m[0].rtyp=STRING_CMD;               // newtonnumber;
1042      L->m[0].data=(void *)omStrDup(r.nZahl);
1043      L->m[1].rtyp=INT_CMD;
1044      L->m[1].data=(void *)r.achse;          // flag for unoccupied axes
1045      L->m[2].rtyp=INT_CMD;
1046      L->m[2].data=(void *)r.deg;            // #degenerations
1047      if ( r.deg != 0)              // only if degenerations exist
1048      {
1049        L->m[3].rtyp=INT_CMD;
1050        L->m[3].data=(void *)r.anz_punkte;     // #points
1051        //---<>--number of points------
1052        int anz = r.anz_punkte;    // number of points
1053        int dim = (currRing->N);     // dimension
1054        intvec* v = new intvec( anz*dim );
1055        for (i=0; i<anz*dim; i++)    // copy points
1056          (*v)[i] = r.pu[i];
1057        L->m[4].rtyp=INTVEC_CMD;
1058        L->m[4].data=(void *)v;
1059        //---<>--degenerations---------
1060        int deg = r.deg;    // number of points
1061        intvec* w = new intvec( r.speicher );  // necessary memeory
1062        i=0;               // start copying
1063        do
1064        {
1065          (*w)[i] = r.deg_tab[i];
1066          i++;
1067        }
1068        while (r.deg_tab[i-1] != -2);   // mark for end of list
1069        L->m[5].rtyp=INTVEC_CMD;
1070        L->m[5].data=(void *)w;
1071      }
1072      else
1073      {
1074        L->m[3].rtyp=INT_CMD; L->m[3].data=(char *)0;
1075        L->m[4].rtyp=DEF_CMD;
1076        L->m[5].rtyp=DEF_CMD;
1077      }
1078
1079      res->data=(void *)L;
1080      res->rtyp=LIST_CMD;
1081      // free all pointer in r:
1082      delete[] r.nZahl;
1083      delete[] r.pu;
1084      delete[] r.deg_tab;      // Ist das ein Problem??
1085
1086      omFreeSize((ADDRESS)points,currRing->N*l*sizeof(short));
1087      return FALSE;
1088    }
1089    else
1090#endif
1091/*==================== gp =================*/
1092#ifdef HAVE_MPSR
1093    if (strcmp(sys_cmd, "gp") == 0)
1094    {
1095      if (h->Typ() != LINK_CMD)
1096      {
1097        WerrorS("No Link arg");
1098        return FALSE;
1099      }
1100      si_link l = (si_link) h->Data();
1101      if (strcmp(l->m->type, "MPfile") != 0)
1102      {
1103        WerrorS("No MPfile link");
1104        return TRUE;
1105      }
1106      if( ! SI_LINK_R_OPEN_P(l)) // open r ?
1107      {
1108        if (slOpen(l, SI_LINK_READ)) return TRUE;
1109      }
1110
1111      MP_Link_pt link = (MP_Link_pt) l->data;
1112      if (MP_InitMsg(link) != MP_Success)
1113      {
1114        WerrorS("Can not Init");
1115      }
1116      MPT_Tree_pt tree = NULL;
1117      if (MPT_GetTree(link, &tree) != MPT_Success)
1118      {
1119        WerrorS("Can not get tree");
1120        return TRUE;
1121      }
1122      MPT_GP_pt gp_tree = MPT_GetGP(tree);
1123      if (gp_tree == NULL || ! gp_tree->IsOk(gp_tree))
1124      {
1125        WerrorS("gp error");
1126        return TRUE;
1127      }
1128      delete gp_tree;
1129      MPT_DeleteTree(tree);
1130      return FALSE;
1131    }
1132    else
1133#endif
1134/*==================== sdb_flags =================*/
1135    if (strcmp(sys_cmd, "sdb_flags") == 0)
1136    {
1137      if ((h!=NULL) && (h->Typ()==INT_CMD))
1138      {
1139        sdb_flags=(int)h->Data();
1140      }
1141      else
1142      {
1143        WerrorS("system(\"sdb_flags\",`int`) expected");
1144        return TRUE;
1145      }
1146      return FALSE;
1147    }
1148    else
1149/*==================== sdb_edit =================*/
1150    if (strcmp(sys_cmd, "sdb_edit") == 0)
1151    {
1152      if ((h!=NULL) && (h->Typ()==PROC_CMD))
1153      {
1154        procinfov p=(procinfov)h->Data();
1155        sdb_edit(p);
1156      }
1157      else
1158      {
1159        WerrorS("system(\"sdb_edit\",`proc`) expected");
1160        return TRUE;
1161      }
1162      return FALSE;
1163    }
1164    else
1165/*==================== GF =================*/
1166#if 0
1167    if (strcmp(sys_cmd, "GF") == 0)
1168    {
1169      int c=rChar(currRing);
1170      setCharacteristic( c, 2);
1171      CanonicalForm F( convSingGFClapGF( (poly)h->Data() ) );
1172      res->rtyp=POLY_CMD;
1173      res->data=convClapGFSingGF( F );
1174      return FALSE;
1175    }
1176    else
1177#endif
1178/*==================== stdX =================*/
1179    if (strcmp(sys_cmd, "std") == 0)
1180    {
1181      ideal i1;
1182      int i2;
1183      if ((h!=NULL) && (h->Typ()==MODUL_CMD))
1184      {
1185        i1=(ideal)h->CopyD();
1186        h=h->next;
1187      }
1188      else return TRUE;
1189      if ((h!=NULL) && (h->Typ()==INT_CMD))
1190      {
1191        i2=(int)h->Data();
1192      }
1193      else return TRUE;
1194      res->rtyp=MODUL_CMD;
1195      res->data=idXXX(i1,i2);
1196      return FALSE;
1197    }
1198    else
1199#ifdef HAVE_PLURAL
1200/*==================== PLURAL =================*/
1201    if (strcmp(sys_cmd, "PLURAL") == 0)
1202    {
1203      matrix C;
1204      matrix D;
1205
1206      if ((h!=NULL) && (h->Typ()==MATRIX_CMD))
1207      {
1208        C=(matrix)h->CopyD();
1209        h=h->next;
1210      }
1211      else return TRUE;
1212      if ((h!=NULL) && (h->Typ()==MATRIX_CMD))
1213      {
1214        D=(matrix)h->CopyD();
1215      }
1216      else return TRUE;
1217      if (currRing->nc==NULL)
1218      {
1219        currRing->nc=(nc_struct *)omAlloc0(sizeof(nc_struct));
1220        currRing->nc->MT=(matrix *)omAlloc0(pVariables*(pVariables-1)/2*sizeof(matrix));
1221        currRing->nc->MTsize=(int *)omAlloc0(pVariables*(pVariables-1)/2*sizeof(int));
1222      }
1223      else
1224      {
1225        WarnS("redefining algebra structure");
1226      }
1227      currRing->nc->type=nc_general;
1228      currRing->nc->C=C;
1229      currRing->nc->D=D;
1230      {
1231        int i,j;
1232        poly p;
1233        short DefMTsize=7;
1234        int nv=pVariables;
1235        for(i=1;i<nv;i++)
1236        {
1237          for(j=i+1;j<=nv;j++)
1238          { 
1239            currRing->nc->MTsize[UPMATELEM(i,j)]=DefMTsize; /* default sizes */
1240            currRing->nc->MT[UPMATELEM(i,j)]=mpNew(DefMTsize,DefMTsize);
1241            p=pOne();
1242            pSetCoeff(p,nCopy(pGetCoeff(MATELEM(currRing->nc->C,i,j))));
1243            pSetExp(p,i,1);
1244            pSetExp(p,j,1);
1245            pSetm(p);
1246            p=pAdd(p,pCopy(MATELEM(currRing->nc->D,i,j)));
1247            MATELEM(currRing->nc->MT[UPMATELEM(i,j)],1,1)=p;
1248            /* set MT[i,j,1,1] to c_i_j*x_i*x_j + D_i_j */
1249          }
1250        }
1251      }
1252      // set p_Procs:
1253//      currRing->p_Procs->pp_Mult_mm =nc_pp_Mult_mm;
1254//      currRing->p_Procs->p_Mult_mm =nc_p_Mult_mm;
1255//      currRing->p_Procs->p_Minus_mm_Mult_qq =nc_p_Minus_mm_Mult_qq;
1256
1257      return FALSE;
1258    }
1259    else
1260#endif
1261#ifdef HAVE_WALK
1262/*==================== walk stuff =================*/
1263    if (strcmp(sys_cmd, "walkNextWeight") == 0)
1264    {
1265      if (h == NULL || h->Typ() != INTVEC_CMD ||
1266          h->next == NULL || h->next->Typ() != INTVEC_CMD ||
1267          h->next->next == NULL || h->next->next->Typ() != IDEAL_CMD)
1268      {
1269        Werror("system(\"walkNextWeight\", intvec, intvec, ideal) expected");
1270        return TRUE;
1271      }
1272
1273      if (((intvec*) h->Data())->length() != currRing->N ||
1274          ((intvec*) h->next->Data())->length() != currRing->N)
1275      {
1276        Werror("system(\"walkNextWeight\" ...) intvecs not of length %d\n",
1277               currRing->N);
1278        return TRUE;
1279      }
1280      res->data = (void*) walkNextWeight(((intvec*) h->Data()),
1281                                         ((intvec*) h->next->Data()),
1282                                         (ideal) h->next->next->Data());
1283      if (res->data == (void*) 0 || res->data == (void*) 1)
1284      {
1285        res->rtyp = INT_CMD;
1286      }
1287      else
1288      {
1289        res->rtyp = INTVEC_CMD;
1290      }
1291      return FALSE;
1292    }
1293    else if (strcmp(sys_cmd, "walkInitials") == 0)
1294    {
1295      if (h == NULL || h->Typ() != IDEAL_CMD)
1296      {
1297        WerrorS("system(\"walkInitials\", ideal) expected");
1298        return TRUE;
1299      }
1300
1301      res->data = (void*) walkInitials((ideal) h->Data());
1302      res->rtyp = IDEAL_CMD;
1303      return FALSE;
1304    }
1305    else
1306#endif
1307
1308/*==================== Error =================*/
1309      Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
1310  }
1311  return TRUE;
1312}
1313#endif // HAVE_EXTENDED_SYSTEM
Note: See TracBrowser for help on using the repository browser.