source: git/Singular/extra.cc @ 1aa559b

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