source: git/Singular/extra.cc @ ebcda0

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