source: git/Singular/extra.cc @ 4449fba

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