source: git/Singular/extra.cc @ 9a3a7f

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