source: git/Singular/extra.cc @ 3952ffb

spielwiese
Last change on this file since 3952ffb was 4b1d39, checked in by Hans Schönemann <hannes@…>, 22 years ago
*hannes/bricken: unified source, cleanup git-svn-id: file:///usr/local/Singular/svn/trunk@5773 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 37.5 KB
Line 
1/*****************************************
2*  Computer Algebra System SINGULAR      *
3*****************************************/
4/* $Id: extra.cc,v 1.174 2002-01-20 11:44:47 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 0
666      if (h != NULL && h->Typ() == VECTOR_CMD)
667      {
668        poly f=(poly)h->Data();
669        h=h->next;
670        if (h != NULL && h->Typ() == MODUL_CMD)
671        {
672          ideal m=(ideal)h->Data();
673          assumeStdFlag(h);
674          h=h->next;
675          if (h != NULL && h->Typ() == INT_CMD)
676          {
677            int n=(int)h->Data();
678            h=h->next;
679            if (h != NULL && h->Typ() == INTVEC_CMD)
680            {
681              intvec *v=(intvec *)h->Data();
682
683              /* == now the work starts == */
684
685              short * iv=iv2array(v);
686              poly r=0;
687              poly hp=ppJetW(f,n,iv);
688              int s=MATCOLS(m);
689              int j=0;
690              matrix T=mpInitI(s,1,0);
691
692              while (hp != NULL)
693              {
694                if (pDivisibleBy(m->m[j],hp))
695                  {
696                    if (MATELEM(T,j+1,1)==0)
697                    {
698                      MATELEM(T,j+1,1)=pDivideM(pHead(hp),pHead(m->m[j]));
699                    }
700                    else
701                    {
702                      pAdd(MATELEM(T,j+1,1),pDivideM(pHead(hp),pHead(m->m[j])));
703                    }
704                    hp=ppJetW(ksOldSpolyRed(m->m[j],hp,0),n,iv);
705                    j=0;
706                  }
707                else
708                {
709                  if (j==s-1)
710                  {
711                    r=pAdd(r,pHead(hp));
712                    hp=pLmDeleteAndNext(hp); /* hp=pSub(hp,pHead(hp));*/
713                    j=0;
714                  }
715                  else
716                  {
717                    j++;
718                  }
719                }
720              }
721
722              matrix Temp=mpTransp((matrix) idVec2Ideal(r));
723              matrix R=mpNew(MATCOLS((matrix) idVec2Ideal(f)),1);
724              for (int k=1;k<=MATROWS(Temp);k++)
725              {
726                MATELEM(R,k,1)=MATELEM(Temp,k,1);
727              }
728
729              lists L=(lists)omAllocBin(slists_bin);
730              L->Init(2);
731              L->m[0].rtyp=MATRIX_CMD;   L->m[0].data=(void *)R;
732              L->m[1].rtyp=MATRIX_CMD;   L->m[1].data=(void *)T;
733              res->data=L;
734              res->rtyp=LIST_CMD;
735              // iv aufraeumen
736              omFree(iv);
737            }
738            else
739            {
740              Warn ("4th argument: must be an intvec!");
741            }
742          }
743          else
744          {
745            Warn("3rd argument must be an int!!");
746          }
747        }
748        else
749        {
750          Warn("2nd argument must be a module!");
751        }
752      }
753      else
754      {
755        Warn("1st argument must be a vector!");
756      }
757      return FALSE;
758#endif
759    }
760    else
761/*==================== interred ==================================*/
762    #if 0
763    if(strcmp(sys_cmd,"interred")==0)
764    {
765      res->data=(char *)kIR((ideal)h->Data(),currQuotient);
766      res->rtyp=h->Typ();
767      return ((h->Typ()!=IDEAL_CMD) && (h->Typ()!=MODUL_CMD));
768    }
769    else
770    #endif
771#ifdef RDEBUG
772/*==================== poly debug ==================================*/
773    if(strcmp(sys_cmd,"p")==0)
774    {
775      pDebugPrint((poly)h->Data());
776      return FALSE;
777    }
778    else
779/*==================== ring debug ==================================*/
780    if(strcmp(sys_cmd,"r")==0)
781    {
782      rDebugPrint((ring)h->Data());
783      return FALSE;
784    }
785    else
786#endif
787/*==================== mtrack ==================================*/
788    if(strcmp(sys_cmd,"mtrack")==0)
789    {
790#ifdef OM_TRACK
791      om_Opts.MarkAsStatic = 1;
792      FILE *fd = NULL;
793      int max = 5;
794      while (h != NULL)
795      {
796        omMarkAsStaticAddr(h);
797        if (fd == NULL && h->Typ()==STRING_CMD)
798        {
799          fd = fopen((char*) h->Data(), "w");
800          if (fd == NULL)
801            Warn("Can not open %s for writing og mtrack. Using stdout");
802        }
803        if (h->Typ() == INT_CMD)
804        {
805          max = (int) h->Data();
806        }
807        h = h->Next();
808      }
809      omPrintUsedTrackAddrs((fd == NULL ? stdout : fd), max);
810      if (fd != NULL) fclose(fd);
811      om_Opts.MarkAsStatic = 0;
812      return FALSE;
813#else
814     WerrorS("mtrack not supported without OM_TRACK");
815     return TRUE;
816#endif
817    }
818/*==================== mtrack_all ==================================*/
819    if(strcmp(sys_cmd,"mtrack_all")==0)
820    {
821#ifdef OM_TRACK
822      om_Opts.MarkAsStatic = 1;
823      FILE *fd = NULL;
824      if ((h!=NULL) &&(h->Typ()==STRING_CMD))
825      {
826        fd = fopen((char*) h->Data(), "w");
827        if (fd == NULL)
828          Warn("Can not open %s for writing og mtrack. Using stdout");
829        omMarkAsStaticAddr(h);
830      }
831      // OB: TBC print to fd
832      omPrintUsedAddrs((fd == NULL ? stdout : fd), 5);
833      if (fd != NULL) fclose(fd);
834      om_Opts.MarkAsStatic = 0;
835      return FALSE;
836#else
837     WerrorS("mtrack not supported without OM_TRACK");
838     return TRUE;
839#endif
840    }
841    else
842/*==================== backtrace ==================================*/
843    if(strcmp(sys_cmd,"backtrace")==0)
844    {
845#ifndef OM_NDEBUG
846      omPrintCurrentBackTrace(stdout);
847      return FALSE;
848#else
849     WerrorS("btrack not supported without OM_TRACK");
850     return TRUE;
851#endif
852    }
853    else
854/*==================== naIdeal ==================================*/
855    if(strcmp(sys_cmd,"naIdeal")==0)
856    {
857      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
858      {
859        naSetIdeal((ideal)h->Data());
860        return FALSE;
861      }
862      else
863         WerrorS("ideal expected");
864    }
865    else
866/*==================== isSqrFree =============================*/
867#ifdef HAVE_FACTORY
868    if(strcmp(sys_cmd,"isSqrFree")==0)
869    {
870      if ((h!=NULL) &&(h->Typ()==POLY_CMD))
871      {
872        res->rtyp=INT_CMD;
873        res->data=(void *)singclap_isSqrFree((poly)h->Data());
874        return FALSE;
875      }
876      else
877        WerrorS("poly expected");
878    }
879    else
880#endif
881/*==================== pDivStat =============================*/
882#if defined(PDEBUG) || defined(PDIV_DEBUG)
883    if(strcmp(sys_cmd,"pDivStat")==0)
884    {
885      extern void pPrintDivisbleByStat();
886      pPrintDivisbleByStat();
887      return FALSE;
888    }
889    else
890#endif
891/*==================== alarm ==================================*/
892#ifndef __MWERKS__
893#ifndef MSDOS
894#ifndef atarist
895#ifdef unix
896    if(strcmp(sys_cmd,"alarm")==0)
897    {
898      if ((h!=NULL) &&(h->Typ()==INT_CMD))
899      {
900        // standard variant -> SIGALARM (standard: abort)
901        //alarm((unsigned)h->next->Data());
902        // process time (user +system): SIGVTALARM
903        struct itimerval t,o;
904        memset(&t,0,sizeof(t));
905        t.it_value.tv_sec     =(unsigned)h->Data();
906        setitimer(ITIMER_VIRTUAL,&t,&o);
907        return FALSE;
908      }
909      else
910        WerrorS("int expected");
911    }
912    else
913#endif
914#endif
915#endif
916#endif
917/*==================== red =============================*/
918#if 0
919    if(strcmp(sys_cmd,"red")==0)
920    {
921      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
922      {
923        res->rtyp=IDEAL_CMD;
924        res->data=(void *)kStdred((ideal)h->Data(),NULL,testHomog,NULL);
925        setFlag(res,FLAG_STD);
926        return FALSE;
927      }
928      else
929        WerrorS("ideal expected");
930    }
931    else
932#endif
933/*==================== algfetch =====================*/
934    if (strcmp(sys_cmd,"algfetch")==0)
935    {
936      int k;
937      idhdl w;
938      ideal i0, i1;
939      ring r0=(ring)h->Data();
940      leftv v = h->next;
941      w = r0->idroot->get(v->Name(),myynest);
942      if (w!=NULL)
943      {
944        if (IDTYP(w)==IDEAL_CMD)
945        {
946          i0 = IDIDEAL(w);
947          i1 = idInit(IDELEMS(i0),i0->rank);
948          for (k=0; k<IDELEMS(i1); k++)
949          {
950            i1->m[k] = maAlgpolyFetch(r0, i0->m[k]);
951          }
952          res->rtyp = IDEAL_CMD;
953          res->data = (void*)i1;
954          return FALSE;
955        }
956        else if (IDTYP(w)==POLY_CMD)
957        {
958          res->rtyp = POLY_CMD;
959          res->data = (void*)maAlgpolyFetch(r0,IDPOLY(w));
960          return FALSE;
961        }
962        else
963          WerrorS("`system(\"algfetch\",<ideal>/<poly>)` expected");
964      }
965      else
966        Werror("`%s` not found in `%s`",v->Name(),h->Name());
967    }
968    else
969/*==================== algmap =======================*/
970    if (strcmp(sys_cmd,"algmap")==0)
971    {
972      int k;
973      idhdl w;
974      ideal i0, i1, i, j;
975      ring r0=(ring)h->Data();
976      leftv v = h->next;
977      w = r0->idroot->get(v->Name(),myynest);
978      i0 = IDIDEAL(w);
979      v = v->next;
980      i = (ideal)v->Data();
981      v = v->next;
982      j = (ideal)v->Data();
983      i1 = idInit(IDELEMS(i0),i0->rank);
984      for (k=0; k<IDELEMS(i1); k++)
985      {
986        i1->m[k] = maAlgpolyMap(r0, i0->m[k], i, j);
987      }
988      res->rtyp = IDEAL_CMD;
989      res->data = (void*)i1;
990      return FALSE;
991    }
992    else
993#ifdef HAVE_FACTORY
994/*==================== fastcomb =============================*/
995    if(strcmp(sys_cmd,"fastcomb")==0)
996    {
997      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
998      {
999        int i=0;
1000        if (h->next!=NULL)
1001        {
1002          if (h->next->Typ()!=POLY_CMD)
1003          {
1004            Warn("Wrong types for poly= comb(ideal,poly)");
1005          }
1006        }
1007        res->rtyp=POLY_CMD;
1008        res->data=(void *) fglmLinearCombination(
1009                           (ideal)h->Data(),(poly)h->next->Data());
1010        return FALSE;
1011      }
1012      else
1013        WerrorS("ideal expected");
1014    }
1015    else
1016/*==================== comb =============================*/
1017    if(strcmp(sys_cmd,"comb")==0)
1018    {
1019      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
1020      {
1021        int i=0;
1022        if (h->next!=NULL)
1023        {
1024          if (h->next->Typ()!=POLY_CMD)
1025          {
1026              Warn("Wrong types for poly= comb(ideal,poly)");
1027          }
1028        }
1029        res->rtyp=POLY_CMD;
1030        res->data=(void *)fglmNewLinearCombination(
1031                            (ideal)h->Data(),(poly)h->next->Data());
1032        return FALSE;
1033      }
1034      else
1035        WerrorS("ideal expected");
1036    }
1037    else
1038#endif
1039#ifdef FACTORY_GCD_TEST
1040/*=======================gcd Testerei ================================*/
1041    if ( ! strcmp( sys_cmd, "setgcd" ) ) {
1042        if ( (h != NULL) && (h->Typ() == INT_CMD) ) {
1043            CFPrimitiveGcdUtil::setAlgorithm( (int)h->Data() );
1044            return FALSE;
1045        } else
1046            WerrorS("int expected");
1047    }
1048    else
1049#endif
1050
1051#ifdef FACTORY_GCD_TIMING
1052    if ( ! strcmp( sys_cmd, "gcdtime" ) ) {
1053        TIMING_PRINT( contentTimer, "time used for content: " );
1054        TIMING_PRINT( algContentTimer, "time used for algContent: " );
1055        TIMING_PRINT( algLcmTimer, "time used for algLcm: " );
1056        TIMING_RESET( contentTimer );
1057        TIMING_RESET( algContentTimer );
1058        TIMING_RESET( algLcmTimer );
1059        return FALSE;
1060    }
1061    else
1062#endif
1063
1064#ifdef FACTORY_GCD_STAT
1065    if ( ! strcmp( sys_cmd, "gcdstat" ) ) {
1066        printGcdTotal();
1067        printContTotal();
1068        resetGcdTotal();
1069        resetContTotal();
1070        return FALSE;
1071    }
1072    else
1073#endif
1074#if !defined(HAVE_NAMESPACES) && !defined(HAVE_NS)
1075/*==================== lib ==================================*/
1076    if(strcmp(sys_cmd,"LIB")==0)
1077    {
1078      idhdl hh=idroot->get((char*)h->Data(),0);
1079      if ((hh!=NULL)&&(IDTYP(hh)==PROC_CMD))
1080      {
1081        res->rtyp=STRING_CMD;
1082        char *r=iiGetLibName(IDPROC(hh));
1083        if (r==NULL) r="";
1084        res->data=omStrDup(r);
1085        return FALSE;
1086      }
1087      else
1088        Warn("`%s` not found",(char*)h->Data());
1089    }
1090    else
1091#endif
1092#ifdef HAVE_NAMESPACES
1093/*==================== nspush ===================================*/
1094    if(strcmp(sys_cmd,"nspush")==0)
1095    {
1096      if (h->Typ()==PACKAGE_CMD)
1097      {
1098        idhdl hh=(idhdl)h->data;
1099        namespaceroot = namespaceroot->push(IDPACKAGE(hh), IDID(hh));
1100        return FALSE;
1101      }
1102      else
1103        Warn("argument 2 is not a package");
1104    }
1105    else
1106/*==================== nspop ====================================*/
1107    if(strcmp(sys_cmd,"nspop")==0)
1108    {
1109      namespaceroot->pop();
1110      return FALSE;
1111    }
1112    else
1113/*==================== nsstack ===================================*/
1114    if(strcmp(sys_cmd,"nsstack")==0)
1115    {
1116      namehdl nshdl = namespaceroot;
1117      for( ; nshdl->isroot != TRUE; nshdl = nshdl->next) {
1118        Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
1119      }
1120      Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
1121      return FALSE;
1122    }
1123    else
1124#endif /* HAVE_NAMESPACES */
1125/*==================== listall ===================================*/
1126    if(strcmp(sys_cmd,"listall")==0)
1127    {
1128      int showproc=1;
1129      if ((h!=NULL) && (h->Typ()==INT_CMD)) showproc=(int)h->Data();
1130#ifdef HAVE_NS
1131      listall(showproc);
1132#else
1133      idhdl hh=IDROOT;
1134      while (hh!=NULL)
1135      {
1136        if (IDDATA(hh)==(void *)currRing) PrintS("(R)");
1137        else PrintS("   ");
1138        Print("::%s, typ %s level %d\n",
1139               IDID(hh),Tok2Cmdname(IDTYP(hh)),IDLEV(hh));
1140        hh=IDNEXT(hh);
1141      }
1142      hh=IDROOT;
1143      while (hh!=NULL)
1144      {
1145        if ((IDTYP(hh)==RING_CMD)
1146        || (IDTYP(hh)==QRING_CMD)
1147        || (IDTYP(hh)==PACKAGE_CMD))
1148        {
1149          idhdl h2=IDRING(hh)->idroot;
1150          while (h2!=NULL)
1151          {
1152            if (IDDATA(h2)==(void *)currRing) PrintS("(R)");
1153            else PrintS("   ");
1154            Print("%s::%s, typ %s level %d\n",
1155            IDID(hh),IDID(h2),Tok2Cmdname(IDTYP(h2)),IDLEV(h2));
1156            h2=IDNEXT(h2);
1157          }
1158        }
1159        hh=IDNEXT(hh);
1160      }
1161#endif /* HAVE_NS */
1162      return FALSE;
1163    }
1164    else
1165/*==================== proclist =================================*/
1166    if(strcmp(sys_cmd,"proclist")==0)
1167    {
1168      piShowProcList();
1169      return FALSE;
1170    }
1171    else
1172/* ==================== newton ================================*/
1173#ifdef HAVE_NEWTON
1174    if(strcmp(sys_cmd,"newton")==0)
1175    {
1176      if ((h->Typ()!=POLY_CMD)
1177      || (h->next->Typ()!=INT_CMD)
1178      || (h->next->next->Typ()!=INT_CMD))
1179      {
1180        WerrorS("system(\"newton\",<poly>,<int>,<int>) expected");
1181        return TRUE;
1182      }
1183      poly  p=(poly)(h->Data());
1184      int l=pLength(p);
1185      short *points=(short *)omAlloc(currRing->N*l*sizeof(short));
1186      int i,j,k;
1187      k=0;
1188      poly pp=p;
1189      for (i=0;pp!=NULL;i++)
1190      {
1191        for(j=1;j<=currRing->N;j++)
1192        {
1193          points[k]=pGetExp(pp,j);
1194          k++;
1195        }
1196        pIter(pp);
1197      }
1198      hc_ERG r=hc_KOENIG(currRing->N,      // dimension
1199                l,      // number of points
1200                (short*) points,   // points: x_1, y_1,z_1, x_2,y_2,z2,...
1201                currRing->OrdSgn==-1,
1202                (int) (h->next->Data()),      // 1: Milnor, 0: Newton
1203                (int) (h->next->next->Data()) // debug
1204               );
1205      //----<>---Output-----------------------
1206
1207
1208//  PrintS("Bin jetzt in extra.cc bei der Auswertung.\n"); // **********
1209
1210
1211      lists L=(lists)omAllocBin(slists_bin);
1212      L->Init(6);
1213      L->m[0].rtyp=STRING_CMD;               // newtonnumber;
1214      L->m[0].data=(void *)omStrDup(r.nZahl);
1215      L->m[1].rtyp=INT_CMD;
1216      L->m[1].data=(void *)r.achse;          // flag for unoccupied axes
1217      L->m[2].rtyp=INT_CMD;
1218      L->m[2].data=(void *)r.deg;            // #degenerations
1219      if ( r.deg != 0)              // only if degenerations exist
1220      {
1221        L->m[3].rtyp=INT_CMD;
1222        L->m[3].data=(void *)r.anz_punkte;     // #points
1223        //---<>--number of points------
1224        int anz = r.anz_punkte;    // number of points
1225        int dim = (currRing->N);     // dimension
1226        intvec* v = new intvec( anz*dim );
1227        for (i=0; i<anz*dim; i++)    // copy points
1228          (*v)[i] = r.pu[i];
1229        L->m[4].rtyp=INTVEC_CMD;
1230        L->m[4].data=(void *)v;
1231        //---<>--degenerations---------
1232        int deg = r.deg;    // number of points
1233        intvec* w = new intvec( r.speicher );  // necessary memeory
1234        i=0;               // start copying
1235        do
1236        {
1237          (*w)[i] = r.deg_tab[i];
1238          i++;
1239        }
1240        while (r.deg_tab[i-1] != -2);   // mark for end of list
1241        L->m[5].rtyp=INTVEC_CMD;
1242        L->m[5].data=(void *)w;
1243      }
1244      else
1245      {
1246        L->m[3].rtyp=INT_CMD; L->m[3].data=(char *)0;
1247        L->m[4].rtyp=DEF_CMD;
1248        L->m[5].rtyp=DEF_CMD;
1249      }
1250
1251      res->data=(void *)L;
1252      res->rtyp=LIST_CMD;
1253      // free all pointer in r:
1254      delete[] r.nZahl;
1255      delete[] r.pu;
1256      delete[] r.deg_tab;      // Ist das ein Problem??
1257
1258      omFreeSize((ADDRESS)points,currRing->N*l*sizeof(short));
1259      return FALSE;
1260    }
1261    else
1262#endif
1263/*==================== sdb_flags =================*/
1264#ifdef HAVE_SDB
1265    if (strcmp(sys_cmd, "sdb_flags") == 0)
1266    {
1267      if ((h!=NULL) && (h->Typ()==INT_CMD))
1268      {
1269        sdb_flags=(int)h->Data();
1270      }
1271      else
1272      {
1273        WerrorS("system(\"sdb_flags\",`int`) expected");
1274        return TRUE;
1275      }
1276      return FALSE;
1277    }
1278    else
1279/*==================== sdb_edit =================*/
1280    if (strcmp(sys_cmd, "sdb_edit") == 0)
1281    {
1282      if ((h!=NULL) && (h->Typ()==PROC_CMD))
1283      {
1284        procinfov p=(procinfov)h->Data();
1285        sdb_edit(p);
1286      }
1287      else
1288      {
1289        WerrorS("system(\"sdb_edit\",`proc`) expected");
1290        return TRUE;
1291      }
1292      return FALSE;
1293    }
1294    else
1295#endif
1296/*==================== GF =================*/
1297#if 0
1298    if (strcmp(sys_cmd, "GF") == 0)
1299    {
1300      int c=rChar(currRing);
1301      setCharacteristic( c, 2);
1302      CanonicalForm F( convSingGFClapGF( (poly)h->Data() ) );
1303      res->rtyp=POLY_CMD;
1304      res->data=convClapGFSingGF( F );
1305      return FALSE;
1306    }
1307    else
1308#endif
1309/*==================== stdX =================*/
1310    if (strcmp(sys_cmd, "std") == 0)
1311    {
1312      ideal i1;
1313      int i2;
1314      if ((h!=NULL) && (h->Typ()==MODUL_CMD))
1315      {
1316        i1=(ideal)h->CopyD();
1317        h=h->next;
1318      }
1319      else return TRUE;
1320      if ((h!=NULL) && (h->Typ()==INT_CMD))
1321      {
1322        i2=(int)h->Data();
1323      }
1324      else return TRUE;
1325      res->rtyp=MODUL_CMD;
1326      res->data=idXXX(i1,i2);
1327      return FALSE;
1328    }
1329    else
1330#ifdef HAVE_PLURAL
1331/*==================== PLURAL =================*/
1332    if (strcmp(sys_cmd, "PLURAL") == 0)
1333    {
1334      matrix C;
1335      matrix D;
1336      matrix COM;
1337      if ((h!=NULL) && (h->Typ()==MATRIX_CMD))
1338      {
1339        C=(matrix)h->CopyD();
1340        h=h->next;
1341      }
1342      else return TRUE;
1343      if ((h!=NULL) && (h->Typ()==MATRIX_CMD))
1344      {
1345        D=(matrix)h->CopyD();
1346      }
1347      else return TRUE;
1348      if (currRing->nc==NULL)
1349      {
1350        currRing->nc=(nc_struct *)omAlloc0(sizeof(nc_struct));
1351        currRing->nc->MT=(matrix *)omAlloc0(currRing->N*(currRing->N-1)/2*sizeof(matrix));
1352        currRing->nc->MTsize=(int *)omAlloc0(currRing->N*(currRing->N-1)/2*sizeof(int));
1353      }
1354      else
1355      {
1356        WarnS("redefining algebra structure");
1357      }
1358      currRing->nc->type=nc_general;
1359      currRing->nc->C=C;
1360      currRing->nc->D=D;
1361      COM=mpCopy(currRing->nc->C);
1362      int i,j;
1363      poly p;
1364      short DefMTsize=7;
1365      int nv=currRing->N;
1366      for(i=1;i<nv;i++)
1367      {
1368        for(j=i+1;j<=nv;j++)
1369        {
1370          if (MATELEM(D,i,j)==NULL)
1371          {
1372            currRing->nc->MTsize[UPMATELEM(i,j,currRing->N)]=0;
1373          }
1374          else
1375          {
1376            MATELEM(COM,i,j)=NULL;
1377            currRing->nc->MTsize[UPMATELEM(i,j,currRing->N)]=DefMTsize; /* default sizes */
1378            currRing->nc->MT[UPMATELEM(i,j,currRing->N)]=mpNew(DefMTsize,DefMTsize);
1379            p=pOne();
1380            pSetCoeff(p,nCopy(pGetCoeff(MATELEM(currRing->nc->C,i,j))));
1381            pSetExp(p,i,1);
1382            pSetExp(p,j,1);
1383            pSetm(p);
1384            p=pAdd(p,pCopy(MATELEM(currRing->nc->D,i,j)));
1385            MATELEM(currRing->nc->MT[UPMATELEM(i,j,currRing->N)],1,1)=p;
1386          }
1387
1388          /* set MT[i,j,1,1] to c_i_j*x_i*x_j + D_i_j */
1389        }
1390      }
1391
1392      currRing->nc->COM=COM;
1393      return FALSE;
1394    }
1395    else
1396#endif
1397#ifdef HAVE_WALK
1398/*==================== walk stuff =================*/
1399    if (strcmp(sys_cmd, "walkNextWeight") == 0)
1400    {
1401      if (h == NULL || h->Typ() != INTVEC_CMD ||
1402          h->next == NULL || h->next->Typ() != INTVEC_CMD ||
1403          h->next->next == NULL || h->next->next->Typ() != IDEAL_CMD)
1404      {
1405        Werror("system(\"walkNextWeight\", intvec, intvec, ideal) expected");
1406        return TRUE;
1407      }
1408
1409      if (((intvec*) h->Data())->length() != currRing->N ||
1410          ((intvec*) h->next->Data())->length() != currRing->N)
1411      {
1412        Werror("system(\"walkNextWeight\" ...) intvecs not of length %d\n",
1413               currRing->N);
1414        return TRUE;
1415      }
1416      res->data = (void*) walkNextWeight(((intvec*) h->Data()),
1417                                         ((intvec*) h->next->Data()),
1418                                         (ideal) h->next->next->Data());
1419      if (res->data == (void*) 0 || res->data == (void*) 1)
1420      {
1421        res->rtyp = INT_CMD;
1422      }
1423      else
1424      {
1425        res->rtyp = INTVEC_CMD;
1426      }
1427      return FALSE;
1428    }
1429    else if (strcmp(sys_cmd, "walkInitials") == 0)
1430    {
1431      if (h == NULL || h->Typ() != IDEAL_CMD)
1432      {
1433        WerrorS("system(\"walkInitials\", ideal) expected");
1434        return TRUE;
1435      }
1436
1437      res->data = (void*) walkInitials((ideal) h->Data());
1438      res->rtyp = IDEAL_CMD;
1439      return FALSE;
1440    }
1441    else
1442#endif
1443#ifdef ix86_Win
1444#ifdef HAVE_DL
1445/*==================== DLL =================*/
1446/* testing the DLL functionality under Win32 */
1447      if (strcmp(sys_cmd, "DLL") == 0)
1448        {
1449          typedef void  (*Void_Func)();
1450          typedef int  (*Int_Func)(int);
1451          void *hh=dynl_open("WinDllTest.dll");
1452          if ((h!=NULL) && (h->Typ()==INT_CMD))
1453            {
1454              int (*f)(int);
1455              if (hh!=NULL)
1456                {
1457                  int (*f)(int);
1458                  f=(Int_Func)dynl_sym(hh,"PlusDll");
1459                  int i=10;
1460                  if (f!=NULL) printf("%d\n",f(i));
1461                  else PrintS("cannot find PlusDll\n");
1462                }
1463            }
1464          else
1465            {
1466              void (*f)();
1467              f= (Void_Func)dynl_sym(hh,"TestDll");
1468              if (f!=NULL) f();
1469              else PrintS("cannot find TestDll\n");
1470            }
1471          return FALSE;
1472        }
1473      else
1474#endif
1475#endif
1476/*==================== Error =================*/
1477      Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
1478  }
1479  return TRUE;
1480}
1481#endif // HAVE_EXTENDED_SYSTEM
Note: See TracBrowser for help on using the repository browser.