source: git/Singular/extra.cc @ a6a239

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