source: git/Singular/extra.cc @ 0b59f5

spielwiese
Last change on this file since 0b59f5 was 0b59f5, checked in by Olaf Bachmann <obachman@…>, 24 years ago
* GMG's changes git-svn-id: file:///usr/local/Singular/svn/trunk@4006 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 29.3 KB
Line 
1/*****************************************
2*  Computer Algebra System SINGULAR      *
3*****************************************/
4/* $Id: extra.cc,v 1.130 1999-12-13 15:33:43 obachman 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 "mod2.h"
14
15#ifndef __MWERKS__
16#ifdef TIME_WITH_SYS_TIME
17# include <time.h>
18# ifdef HAVE_SYS_TIME_H
19#   include <sys/time.h>
20# endif
21#else
22# ifdef HAVE_SYS_TIME_H
23#   include <sys/time.h>
24# else
25#   include <time.h>
26# endif
27#endif
28#ifdef HAVE_SYS_TIMES_H
29#include <sys/times.h>
30#endif
31
32#endif
33#include <unistd.h>
34
35#include "tok.h"
36#include "ipid.h"
37#include "polys.h"
38#include "kutil.h"
39#include "cntrlc.h"
40#include "stairc.h"
41#include "ipshell.h"
42#include "algmap.h"
43#include "modulop.h"
44#include "febase.h"
45#include "matpol.h"
46#include "longalg.h"
47#include "ideals.h"
48#include "kstd1.h"
49#include "syz.h"
50#include "sdb.h"
51#include "feOpt.h"
52#include "distrib.h"
53#include "prCopy.h"
54#include "mpr_complex.h"
55
56#ifdef HAVE_SPECTRUM
57#include "spectrum.h"
58#endif
59
60
61// Define to enable many more system commands
62#ifndef MAKE_DISTRIBUTION
63#define HAVE_EXTENDED_SYSTEM
64#endif
65
66#ifdef HAVE_FACTORY
67#define SI_DONT_HAVE_GLOBAL_VARS
68#include "clapsing.h"
69#include "clapconv.h"
70#include "kstdfac.h"
71#endif
72
73#include "silink.h"
74#ifdef HAVE_MPSR
75#include "mpsr.h"
76#include "MPT_GP.h"
77#endif
78#include "walk.h"
79
80/*
81 *   New function/system-calls that will be included as dynamic module
82 * should be inserted here.
83 * - without HAVE_DYNAMIC_LOADING: these functions comes as system("....");
84 * - with    HAVE_DYNAMIC_LOADING: these functions are loaded as module.
85 */
86#ifndef HAVE_DYNAMIC_LOADING
87#ifdef HAVE_PCV
88#include "pcv.h"
89#endif
90#endif /* not HAVE_DYNAMIC_LOADING */
91
92// see clapsing.cc for a description of the `FACTORY_*' options
93
94#ifdef FACTORY_GCD_STAT
95#include "gcd_stat.h"
96#endif
97
98#ifdef FACTORY_GCD_TIMING
99#define TIMING
100#include "timing.h"
101TIMING_DEFINE_PRINTPROTO( contentTimer );
102TIMING_DEFINE_PRINTPROTO( algContentTimer );
103TIMING_DEFINE_PRINTPROTO( algLcmTimer );
104#endif
105
106void piShowProcList();
107#ifndef MAKE_DISTRIBUTION
108static BOOLEAN jjEXTENDED_SYSTEM(leftv res, leftv h);
109#endif
110
111
112//void emStart();
113/*2
114*  the "system" command
115*/
116BOOLEAN jjSYSTEM(leftv res, leftv args)
117{
118  if(args->Typ() == STRING_CMD)
119  {
120    const char *sys_cmd=(char *)(args->Data());
121    leftv h=args->next;
122// ONLY documented system calls go here
123// Undocumented system calls go down into #ifdef HAVE_EXTENDED_SYSTEM
124/*==================== nblocks ==================================*/
125    if (strcmp(sys_cmd, "nblocks") == 0)
126    {
127      ring r;
128      if (h == NULL)
129      {
130        if (currRingHdl != NULL)
131        {
132          r = IDRING(currRingHdl);
133        }
134        else
135        {
136          WerrorS("no ring active");
137          return TRUE;
138        }
139      }
140      else
141      {
142        if (h->Typ() != RING_CMD)
143        {
144          WerrorS("ring expected");
145          return TRUE;
146        }
147        r = (ring) h->Data();
148      }
149      res->rtyp = INT_CMD;
150      res->data = (void*) (rBlocks(r) - 1);
151      return FALSE;
152    }
153/*==================== version ==================================*/
154    if(strcmp(sys_cmd,"version")==0)
155    {
156      res->rtyp=INT_CMD;
157      res->data=(void *)SINGULAR_VERSION;
158      return FALSE;
159    }
160    else
161/*==================== gen ==================================*/
162    if(strcmp(sys_cmd,"gen")==0)
163    {
164      res->rtyp=INT_CMD;
165      res->data=(void *)npGen;
166      return FALSE;
167    }
168    else
169/*==================== gc ==================================*/
170    if(strcmp(sys_cmd,"gc")==0)
171    {
172      mmGarbageCollectHeaps(3);
173      return FALSE;
174    }
175    else
176/*==================== sh ==================================*/
177    if(strcmp(sys_cmd,"sh")==0)
178    {
179      res->rtyp=INT_CMD;
180      #ifndef __MWERKS__
181      if (h==NULL) res->data = (void *)system("sh");
182      else if (h->Typ()==STRING_CMD)
183        res->data = (void*) system((char*)(h->Data()));
184      else
185        WerrorS("string expected");
186      #else
187      res->data=(void *)0;
188      #endif
189      return FALSE;
190    }
191    else
192/*==================== with ==================================*/
193    if(strcmp(sys_cmd,"with")==0)
194    {
195      if (h==NULL)
196      {
197        res->rtyp=STRING_CMD;
198        res->data=(void *)mstrdup(versionString());
199        return FALSE;
200      }
201      else if (h->Typ()==STRING_CMD)
202      {
203        #define TEST_FOR(A) if(strcmp(s,A)==0) res->data=(void *)1; else
204        char *s=(char *)h->Data();
205        res->rtyp=INT_CMD;
206        #ifdef HAVE_DBM
207          TEST_FOR("DBM")
208        #endif
209        #ifdef HAVE_DLD
210          TEST_FOR("DLD")
211        #endif
212        #ifdef HAVE_FACTORY
213          TEST_FOR("factory")
214        #endif
215        #ifdef HAVE_LIBFAC_P
216          TEST_FOR("libfac")
217        #endif
218        #ifdef HAVE_MPSR
219          TEST_FOR("MP")
220        #endif
221        #ifdef HAVE_READLINE
222          TEST_FOR("readline")
223        #endif
224        #ifdef HAVE_TCL
225          TEST_FOR("tcl")
226        #endif
227        #ifdef TEST_MAC_ORDER
228          TEST_FOR("MAC_ORDER");
229        #endif
230        #ifdef HAVE_NAMESPACES
231          TEST_FOR("Namespaces");
232        #endif
233        #ifdef HAVE_DYNAMIC_LOADING
234          TEST_FOR("DynamicLoading");
235        #endif
236          ;
237        return FALSE;
238        #undef TEST_FOR
239      }
240      return TRUE;
241    }
242    else
243/*==================== browsers ==================================*/
244    if (strcmp(sys_cmd,"browsers")==0)
245    {
246      res->rtyp = STRING_CMD;
247      char* b = StringSetS("");
248      feStringAppendBrowsers(0);
249      res->data = mstrdup(b);
250      return FALSE;
251    }
252    else
253/*==================== pid ==================================*/
254    if (strcmp(sys_cmd,"pid")==0)
255    {
256      res->rtyp=INT_CMD;
257    #ifndef MSDOS
258    #ifndef __MWERKS__
259      res->data=(void *)getpid();
260    #else
261      res->data=(void *)1;
262    #endif
263    #else
264      res->data=(void *)1;
265    #endif
266      return FALSE;
267    }
268    else
269/*==================== getenv ==================================*/
270    if (strcmp(sys_cmd,"getenv")==0)
271    {
272      if ((h!=NULL) && (h->Typ()==STRING_CMD))
273      {
274        res->rtyp=STRING_CMD;
275        char *r=getenv((char *)h->Data());
276        if (r==NULL) r="";
277        res->data=(void *)mstrdup(r);
278        return FALSE;
279      }
280      else
281      {
282        WerrorS("string expected");
283        return TRUE;
284      }
285    }
286    else
287/*==================== setenv ==================================*/
288    if (strcmp(sys_cmd,"setenv")==0)
289    {
290#ifdef HAVE_SETENV
291      if (h!=NULL && h->Typ()==STRING_CMD && h->Data() != NULL &&
292          h->next != NULL && h->next->Typ() == STRING_CMD
293          && h->next->Data() != NULL)
294      {
295        res->rtyp=STRING_CMD;
296        setenv((char *)h->Data(), (char *)h->next->Data(), 1);
297        res->data=(void *)mstrdup((char *)h->next->Data());
298        feReInitResources();
299        return FALSE;
300      }
301      else
302      {
303        WerrorS("two strings expected");
304        return TRUE;
305      }
306#else
307      WerrorS("setenv not supported on this platform");
308      return TRUE;
309#endif
310    }
311    else
312/*==================== Singular ==================================*/
313    if (strcmp(sys_cmd, "Singular") == 0)
314    {
315      res->rtyp=STRING_CMD;
316      char *r=feResource("Singular");
317      if (r != NULL)
318        res->data = (void*) mstrdup( r );
319      else
320        res->data = (void*) mstrdup("");
321      return FALSE;
322    }
323    else
324/*==================== options ==================================*/
325    if (strstr(sys_cmd, "--") == sys_cmd)
326    {
327      if (strcmp(sys_cmd, "--") == 0)
328      {
329        fePrintOptValues();
330        return FALSE;
331      }
332
333      feOptIndex opt = feGetOptIndex(&sys_cmd[2]);
334      if (opt == FE_OPT_UNDEF)
335      {
336        Werror("Unknown option %s", sys_cmd);
337        Werror("Use 'system(\"--\");' for listing of available options");
338        return TRUE;
339      }
340
341      // for Untyped Options (help version),
342      // setting it just triggers action
343      if (feOptSpec[opt].type == feOptUntyped)
344      {
345        feSetOptValue(opt,NULL);
346        return FALSE;
347      }
348
349      if (h == NULL)
350      {
351        if (feOptSpec[opt].type == feOptString)
352        {
353          res->rtyp = STRING_CMD;
354          if (feOptSpec[opt].value != NULL)
355            res->data = mstrdup((char*) feOptSpec[opt].value);
356          else
357            res->data = mstrdup("");
358        }
359        else
360        {
361          res->rtyp = INT_CMD;
362          res->data = feOptSpec[opt].value;
363        }
364        return FALSE;
365      }
366
367      if (h->Typ() != STRING_CMD &&
368          h->Typ() != INT_CMD)
369      {
370        Werror("Need string or int argument to set option value");
371        return TRUE;
372      }
373      char* errormsg;
374      if (h->Typ() == INT_CMD)
375      {
376        if (feOptSpec[opt].type == feOptString)
377        {
378          Werror("Need string argument to set value of option %s", sys_cmd);
379          return TRUE;
380        }
381        errormsg = feSetOptValue(opt, (int) h->Data());
382        if (errormsg != NULL)
383          Werror("Option '--%s=%d' %s", sys_cmd, (int) h->Data(), errormsg);
384      }
385      else
386      {
387        errormsg = feSetOptValue(opt, (char*) h->Data());
388        if (errormsg != NULL)
389          Werror("Option '--%s=%s' %s", sys_cmd, (char*) h->Data(), errormsg);
390      }
391      if (errormsg != NULL) return TRUE;
392      return FALSE;
393    }
394    else
395/*==================== HC ==================================*/
396    if (strcmp(sys_cmd,"HC")==0)
397    {
398      res->rtyp=INT_CMD;
399      res->data=(void *)HCord;
400      return FALSE;
401    }
402    else
403/*==================== random ==================================*/
404    if(strcmp(sys_cmd,"random")==0)
405    {
406      if ((h!=NULL) &&(h->Typ()==INT_CMD))
407      {
408        siRandomStart=(int)h->Data();
409#ifdef buildin_rand
410        siSeed=siRandomStart;
411#else
412        srand((unsigned int)siRandomStart);
413#endif
414        return FALSE;
415      }
416      else if (h != NULL)
417      {
418        WerrorS("int expected");
419        return TRUE;
420      }
421      res->rtyp=INT_CMD;
422      res->data=(void*) siRandomStart;
423      return FALSE;
424    }
425/*==================== complexNearZero ======================*/
426    if(strcmp(sys_cmd,"complexNearZero")==0)
427    {
428      if (h->Typ()==NUMBER_CMD )
429      {
430        if ( h->next!=NULL && h->next->Typ()==INT_CMD )
431        {
432          if ( !rField_is_long_C() )
433            {
434              Werror( "unsupported ground field!");
435              return TRUE;
436            }
437          else
438            {
439              res->rtyp=INT_CMD;
440              res->data=(void*)complexNearZero((gmp_complex*)h->Data(),(int)h->next->Data());
441              return FALSE;
442            }
443        }
444        else
445        {
446          Werror( "expected <int> as third parameter!");
447          return TRUE;
448        }
449      }
450      else
451      {
452        Werror( "expected <number> as second parameter!");
453        return TRUE;
454      }
455    }
456/*==================== getPrecDigits ======================*/
457    if(strcmp(sys_cmd,"getPrecDigits")==0)
458    {
459      if ( !rField_is_long_C() && !rField_is_long_R() )
460      {
461        Werror( "unsupported ground field!");
462        return TRUE;
463      }
464      res->rtyp=INT_CMD;
465      res->data=(void*)getGMPFloatDigits();
466      return FALSE;
467    }
468/*==================== neworder =============================*/
469// should go below
470#ifdef HAVE_LIBFAC_P
471    if(strcmp(sys_cmd,"neworder")==0)
472    {
473      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
474      {
475        res->rtyp=STRING_CMD;
476        res->data=(void *)singclap_neworder((ideal)h->Data());
477        return FALSE;
478      }
479      else
480        WerrorS("ideal expected");
481    }
482    else
483#endif
484/*==================== pcv ==================================*/
485#ifndef HAVE_DYNAMIC_LOADING
486#ifdef HAVE_PCV
487    if(strcmp(sys_cmd,"pcvLAddL")==0)
488    {
489      return pcvLAddL(res,h);
490    }
491    else
492    if(strcmp(sys_cmd,"pcvPMulL")==0)
493    {
494      return pcvPMulL(res,h);
495    }
496    else
497    if(strcmp(sys_cmd,"pcvMinDeg")==0)
498    {
499      return pcvMinDeg(res,h);
500    }
501    else
502    if(strcmp(sys_cmd,"pcvP2CV")==0)
503    {
504      return pcvP2CV(res,h);
505    }
506    else
507    if(strcmp(sys_cmd,"pcvCV2P")==0)
508    {
509      return pcvCV2P(res,h);
510    }
511    else
512    if(strcmp(sys_cmd,"pcvDim")==0)
513    {
514      return pcvDim(res,h);
515    }
516    else
517    if(strcmp(sys_cmd,"pcvBasis")==0)
518    {
519      return pcvBasis(res,h);
520    }
521    else
522#endif
523#endif /* HAVE_DYNAMIC_LOADING */
524/*==================== contributors =============================*/
525   if(strcmp(sys_cmd,"contributors") == 0)
526   {
527     res->rtyp=STRING_CMD;
528     res->data=(void *)mstrdup(
529       "Olaf Bachmann, Hubert Grassmann, Kai Krueger, Wolfgang Neumann, Thomas Nuessler, Wilfred Pohl, Jens Schmidt, Thomas Siebert, Ruediger Stobbe, Moritz Wenk, Tim Wichmann");
530     return FALSE;
531   }
532   else
533/*==================== spectrum =============================*/
534   #ifdef HAVE_SPECTRUM
535   if(strcmp(sys_cmd,"spectrum") == 0)
536   {
537     if (h->Typ()!=POLY_CMD)
538     {
539       WerrorS("poly expected");
540       return TRUE;
541     }
542     if (h->next==NULL)
543       return spectrumProc(res,h);
544     if (h->next->Typ()!=INT_CMD)
545     {
546       WerrorS("poly,int expected");
547       return TRUE;
548     }
549     if(((int)h->next->Data())==1)
550       return spectrumfProc(res,h);
551     return spectrumProc(res,h);
552   }
553   else
554/*==================== semic =============================*/
555   if(strcmp(sys_cmd,"semic") == 0)
556   {
557     if ((h->next!=NULL)
558     && (h->Typ()==LIST_CMD)
559     && (h->next->Typ()==LIST_CMD))
560     {
561       if (h->next->next==NULL)
562         return semicProc(res,h,h->next);
563       else if (h->next->next->Typ()==INT_CMD)
564         return semicProc3(res,h,h->next,h->next->next);
565     }
566     return TRUE;
567   }
568   else
569/*==================== spadd =============================*/
570   if(strcmp(sys_cmd,"spadd") == 0)
571   {
572     if ((h->next!=NULL)
573     && (h->Typ()==LIST_CMD)
574     && (h->next->Typ()==LIST_CMD))
575     {
576       if (h->next->next==NULL)
577         return spaddProc(res,h,h->next);
578     }
579     return TRUE;
580   }
581   else
582/*==================== spmul =============================*/
583   if(strcmp(sys_cmd,"spmul") == 0)
584   {
585     if ((h->next!=NULL)
586     && (h->Typ()==LIST_CMD)
587     && (h->next->Typ()==INT_CMD))
588     {
589       if (h->next->next==NULL)
590         return spmulProc(res,h,h->next);
591     }
592     return TRUE;
593   }
594   else
595   #endif
596/*================= Extended system call ========================*/
597   {
598     #ifndef MAKE_DISTRIBUTION
599     return(jjEXTENDED_SYSTEM(res, args));
600     #else
601     Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
602     #endif
603   }
604  } /* typ==string */
605  return TRUE;
606}
607
608
609
610#ifdef HAVE_EXTENDED_SYSTEM
611// You can put your own system calls here
612#include "fglmcomb.cc"
613#include "fglm.h"
614#ifdef HAVE_NEWTON
615#include <hc_newton.h>
616#endif
617#include "mpsr.h"
618
619static BOOLEAN jjEXTENDED_SYSTEM(leftv res, leftv h)
620{
621  if(h->Typ() == STRING_CMD)
622  {
623    char *sys_cmd=(char *)(h->Data());
624    h=h->next;
625/*==================== poly debug ==================================*/
626    if(strcmp(sys_cmd,"p")==0)
627    {
628      pDebugPrint((poly)h->Data());
629      return FALSE;
630    }
631    else
632/*==================== ring debug ==================================*/
633    if(strcmp(sys_cmd,"r")==0)
634    {
635      rDebugPrint((ring)h->Data());
636      return FALSE;
637    }
638    else
639/*==================== mtrack ==================================*/
640    if(strcmp(sys_cmd,"mtrack")==0)
641    {
642#ifdef MLIST
643      FILE *fd = NULL;
644      if ((h!=NULL) &&(h->Typ()==STRING_CMD))
645      {
646        fd = fopen((char*) h->Data(), "w");
647        if (fd == NULL)
648          Warn("Can not open %s for writing og mtrack. Using stdout");
649      }
650      mmTestList((fd == NULL ? stdout: fd), 0);
651      if (fd != NULL) fclose(fd);
652      return FALSE;
653#else
654     WerrorS("mtrack not supported without MLIST");
655     return TRUE;
656#endif
657    }
658    else
659/*==================== naIdeal ==================================*/
660    if(strcmp(sys_cmd,"naIdeal")==0)
661    {
662      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
663      {
664        naSetIdeal((ideal)h->Data());
665        return FALSE;
666      }
667      else
668         WerrorS("ideal expected");
669    }
670    else
671/*==================== isSqrFree =============================*/
672#ifdef HAVE_FACTORY
673    if(strcmp(sys_cmd,"isSqrFree")==0)
674    {
675      if ((h!=NULL) &&(h->Typ()==POLY_CMD))
676      {
677        res->rtyp=INT_CMD;
678        res->data=(void *)singclap_isSqrFree((poly)h->Data());
679        return FALSE;
680      }
681      else
682        WerrorS("poly expected");
683    }
684    else
685#endif
686/*==================== pDivStat =============================*/
687    if(strcmp(sys_cmd,"pDivStat")==0)
688    {
689#ifdef PDIV_DEBUG
690      extern void pPrintDivisbleByStat();
691      pPrintDivisbleByStat();
692#endif
693      return FALSE;
694    }
695    else
696/*==================== alarm ==================================*/
697#ifndef __MWERKS__
698#ifndef MSDOS
699#ifndef atarist
700#ifdef unix
701    if(strcmp(sys_cmd,"alarm")==0)
702    {
703      if ((h!=NULL) &&(h->Typ()==INT_CMD))
704      {
705        // standard variant -> SIGALARM (standard: abort)
706        //alarm((unsigned)h->next->Data());
707        // process time (user +system): SIGVTALARM
708        struct itimerval t,o;
709        memset(&t,0,sizeof(t));
710        t.it_value.tv_sec     =(unsigned)h->Data();
711        setitimer(ITIMER_VIRTUAL,&t,&o);
712        return FALSE;
713      }
714      else
715        WerrorS("int expected");
716    }
717    else
718#endif
719#endif
720#endif
721#endif
722/*==================== red =============================*/
723#if 0
724    if(strcmp(sys_cmd,"red")==0)
725    {
726      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
727      {
728        res->rtyp=IDEAL_CMD;
729        res->data=(void *)kStdred((ideal)h->Data(),NULL,testHomog,NULL);
730        setFlag(res,FLAG_STD);
731        return FALSE;
732      }
733      else
734        WerrorS("ideal expected");
735    }
736    else
737#endif
738/*==================== algfetch =====================*/
739    if (strcmp(sys_cmd,"algfetch")==0)
740    {
741      int k;
742      idhdl w;
743      ideal i0, i1;
744      ring r0=(ring)h->Data();
745      leftv v = h->next;
746      w = r0->idroot->get(v->Name(),myynest);
747      if (w!=NULL)
748      {
749        if (IDTYP(w)==IDEAL_CMD)
750        {
751          i0 = IDIDEAL(w);
752          i1 = idInit(IDELEMS(i0),i0->rank);
753          for (k=0; k<IDELEMS(i1); k++)
754          {
755            i1->m[k] = maAlgpolyFetch(r0, i0->m[k]);
756          }
757          res->rtyp = IDEAL_CMD;
758          res->data = (void*)i1;
759          return FALSE;
760        }
761        else if (IDTYP(w)==POLY_CMD)
762        {
763          res->rtyp = POLY_CMD;
764          res->data = (void*)maAlgpolyFetch(r0,IDPOLY(w));
765          return FALSE;
766        }
767        else
768          WerrorS("`system(\"algfetch\",<ideal>/<poly>)` expected");
769      }
770      else
771        Werror("`%s` not found in `%s`",v->Name(),h->Name());
772    }
773    else
774/*==================== algmap =======================*/
775    if (strcmp(sys_cmd,"algmap")==0)
776    {
777      int k;
778      idhdl w;
779      ideal i0, i1, i, j;
780      ring r0=(ring)h->Data();
781      leftv v = h->next;
782      w = r0->idroot->get(v->Name(),myynest);
783      i0 = IDIDEAL(w);
784      v = v->next;
785      i = (ideal)v->Data();
786      v = v->next;
787      j = (ideal)v->Data();
788      i1 = idInit(IDELEMS(i0),i0->rank);
789      for (k=0; k<IDELEMS(i1); k++)
790      {
791        i1->m[k] = maAlgpolyMap(r0, i0->m[k], i, j);
792      }
793      res->rtyp = IDEAL_CMD;
794      res->data = (void*)i1;
795      return FALSE;
796    }
797    else
798#ifdef HAVE_FACTORY
799/*==================== fastcomb =============================*/
800    if(strcmp(sys_cmd,"fastcomb")==0)
801    {
802      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
803      {
804        int i=0;
805        if (h->next!=NULL)
806        {
807          if (h->next->Typ()!=POLY_CMD)
808          {
809            Warn("Wrong types for poly= comb(ideal,poly)");
810          }
811        }
812        res->rtyp=POLY_CMD;
813        res->data=(void *) fglmLinearCombination(
814                           (ideal)h->Data(),(poly)h->next->Data());
815        return FALSE;
816      }
817      else
818        WerrorS("ideal expected");
819    }
820    else
821/*==================== comb =============================*/
822    if(strcmp(sys_cmd,"comb")==0)
823    {
824      if ((h!=NULL) &&(h->Typ()==IDEAL_CMD))
825      {
826        int i=0;
827        if (h->next!=NULL)
828        {
829          if (h->next->Typ()!=POLY_CMD)
830          {
831              Warn("Wrong types for poly= comb(ideal,poly)");
832          }
833        }
834        res->rtyp=POLY_CMD;
835        res->data=(void *)fglmNewLinearCombination(
836                            (ideal)h->Data(),(poly)h->next->Data());
837        return FALSE;
838      }
839      else
840        WerrorS("ideal expected");
841    }
842    else
843#endif
844#ifdef FACTORY_GCD_TEST
845/*=======================gcd Testerei ================================*/
846    if ( ! strcmp( sys_cmd, "setgcd" ) ) {
847        if ( (h != NULL) && (h->Typ() == INT_CMD) ) {
848            CFPrimitiveGcdUtil::setAlgorithm( (int)h->Data() );
849            return FALSE;
850        } else
851            WerrorS("int expected");
852    }
853    else
854#endif
855
856#ifdef FACTORY_GCD_TIMING
857    if ( ! strcmp( sys_cmd, "gcdtime" ) ) {
858        TIMING_PRINT( contentTimer, "time used for content: " );
859        TIMING_PRINT( algContentTimer, "time used for algContent: " );
860        TIMING_PRINT( algLcmTimer, "time used for algLcm: " );
861        TIMING_RESET( contentTimer );
862        TIMING_RESET( algContentTimer );
863        TIMING_RESET( algLcmTimer );
864        return FALSE;
865    }
866    else
867#endif
868
869#ifdef FACTORY_GCD_STAT
870    if ( ! strcmp( sys_cmd, "gcdstat" ) ) {
871        printGcdTotal();
872        printContTotal();
873        resetGcdTotal();
874        resetContTotal();
875        return FALSE;
876    }
877    else
878#endif
879/*==================== lib ==================================*/
880    if(strcmp(sys_cmd,"LIB")==0)
881    {
882#ifdef HAVE_NAMESPACES
883      idhdl hh=namespaceroot->get((char*)h->Data(),0);
884#else /* HAVE_NAMESPACES */
885      idhdl hh=idroot->get((char*)h->Data(),0);
886#endif /* HAVE_NAMESPACES */
887      if ((hh!=NULL)&&(IDTYP(hh)==PROC_CMD))
888      {
889        res->rtyp=STRING_CMD;
890        char *r=iiGetLibName(IDPROC(hh));
891        if (r==NULL) r="";
892        res->data=mstrdup(r);
893        return FALSE;
894      }
895      else
896        Warn("`%s` not found",(char*)h->Data());
897    }
898    else
899#ifdef HAVE_NAMESPACES
900/*==================== nspush ===================================*/
901    if(strcmp(sys_cmd,"nspush")==0)
902    {
903      if (h->Typ()==PACKAGE_CMD)
904      {
905        idhdl hh=(idhdl)h->data;
906        namespaceroot = namespaceroot->push(IDPACKAGE(hh), IDID(hh));
907        return FALSE;
908      }
909      else
910        Warn("argument 2 is not a package");
911    }
912    else
913/*==================== nspop ====================================*/
914    if(strcmp(sys_cmd,"nspop")==0)
915    {
916      namespaceroot->pop();
917      return FALSE;
918    }
919    else
920#endif /* HAVE_NAMESPACES */
921/*==================== nsstack ===================================*/
922    if(strcmp(sys_cmd,"nsstack")==0)
923    {
924      namehdl nshdl = namespaceroot;
925      for( ; nshdl->isroot != TRUE; nshdl = nshdl->next) {
926        Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
927      }
928      Print("NSstack: %s:%d, nesting=%d\n", nshdl->name, nshdl->lev, nshdl->myynest);
929      return FALSE;
930    }
931    else
932/*==================== proclist =================================*/
933    if(strcmp(sys_cmd,"proclist")==0)
934    {
935      piShowProcList();
936      return FALSE;
937    }
938    else
939/* ==================== newton ================================*/
940#ifdef HAVE_NEWTON
941    if(strcmp(sys_cmd,"newton")==0)
942    {
943      if ((h->Typ()!=POLY_CMD)
944      || (h->next->Typ()!=INT_CMD)
945      || (h->next->next->Typ()!=INT_CMD))
946      {
947        WerrorS("system(\"newton\",<poly>,<int>,<int>) expected");
948        return TRUE;
949      }
950      poly  p=(poly)(h->Data());
951      int l=pLength(p);
952      short *points=(short *)Alloc(currRing->N*l*sizeof(short));
953      int i,j,k;
954      k=0;
955      poly pp=p;
956      for (i=0;pp!=NULL;i++)
957      {
958        for(j=1;j<=currRing->N;j++)
959        {
960          points[k]=pGetExp(pp,j);
961          k++;
962        }
963        pIter(pp);
964      }
965      hc_ERG r=hc_KOENIG(currRing->N,      // dimension
966                l,      // number of points
967                (short*) points,   // points: x_1, y_1,z_1, x_2,y_2,z2,...
968                currRing->OrdSgn==-1,
969                (int) (h->next->Data()),      // 1: Milnor, 0: Newton
970                (int) (h->next->next->Data()) // debug
971               );
972      //----<>---Output-----------------------
973
974
975//  PrintS("Bin jetzt in extra.cc bei der Auswertung.\n"); // **********
976
977
978      lists L=(lists)AllocSizeOf(slists);
979      L->Init(6);
980      L->m[0].rtyp=STRING_CMD;               // newtonnumber;
981      L->m[0].data=(void *)mstrdup(r.nZahl);
982      L->m[1].rtyp=INT_CMD;
983      L->m[1].data=(void *)r.achse;          // flag for unoccupied axes
984      L->m[2].rtyp=INT_CMD;
985      L->m[2].data=(void *)r.deg;            // #degenerations
986      if ( r.deg != 0)              // only if degenerations exist
987      {
988        L->m[3].rtyp=INT_CMD;
989        L->m[3].data=(void *)r.anz_punkte;     // #points
990        //---<>--number of points------
991        int anz = r.anz_punkte;    // number of points
992        int dim = (currRing->N);     // dimension
993        intvec* v = NewIntvec1( anz*dim );
994        for (i=0; i<anz*dim; i++)    // copy points
995          (*v)[i] = r.pu[i];
996        L->m[4].rtyp=INTVEC_CMD;
997        L->m[4].data=(void *)v;
998        //---<>--degenerations---------
999        int deg = r.deg;    // number of points
1000        intvec* w = NewIntvec1( r.speicher );  // necessary memeory
1001        i=0;               // start copying
1002        do
1003        {
1004          (*w)[i] = r.deg_tab[i];
1005          i++;
1006        }
1007        while (r.deg_tab[i-1] != -2);   // mark for end of list
1008        L->m[5].rtyp=INTVEC_CMD;
1009        L->m[5].data=(void *)w;
1010      }
1011      else
1012      {
1013        L->m[3].rtyp=INT_CMD; L->m[3].data=(char *)0;
1014        L->m[4].rtyp=DEF_CMD;
1015        L->m[5].rtyp=DEF_CMD;
1016      }
1017
1018      res->data=(void *)L;
1019      res->rtyp=LIST_CMD;
1020      // free all pointer in r:
1021      delete[] r.nZahl;
1022      delete[] r.pu;
1023      delete[] r.deg_tab;      // Ist das ein Problem??
1024
1025      Free((ADDRESS)points,currRing->N*l*sizeof(short));
1026      return FALSE;
1027    }
1028    else
1029#endif
1030/*==================== gp =================*/
1031#ifdef HAVE_MPSR
1032    if (strcmp(sys_cmd, "gp") == 0)
1033    {
1034      if (h->Typ() != LINK_CMD)
1035      {
1036        WerrorS("No Link arg");
1037        return FALSE;
1038      }
1039      si_link l = (si_link) h->Data();
1040      if (strcmp(l->m->type, "MPfile") != 0)
1041      {
1042        WerrorS("No MPfile link");
1043        return TRUE;
1044      }
1045      if( ! SI_LINK_R_OPEN_P(l)) // open r ?
1046      {
1047        if (slOpen(l, SI_LINK_READ)) return TRUE;
1048      }
1049
1050      MP_Link_pt link = (MP_Link_pt) l->data;
1051      if (MP_InitMsg(link) != MP_Success)
1052      {
1053        WerrorS("Can not Init");
1054      }
1055      MPT_Tree_pt tree = NULL;
1056      if (MPT_GetTree(link, &tree) != MPT_Success)
1057      {
1058        WerrorS("Can not get tree");
1059        return TRUE;
1060      }
1061      MPT_GP_pt gp_tree = MPT_GetGP(tree);
1062      if (gp_tree == NULL || ! gp_tree->IsOk(gp_tree))
1063      {
1064        WerrorS("gp error");
1065        return TRUE;
1066      }
1067      delete gp_tree;
1068      MPT_DeleteTree(tree);
1069      return FALSE;
1070    }
1071    else
1072#endif
1073/*==================== sdb_flags =================*/
1074    if (strcmp(sys_cmd, "sdb_flags") == 0)
1075    {
1076      if ((h!=NULL) && (h->Typ()==INT_CMD))
1077      {
1078        sdb_flags=(int)h->Data();
1079      }
1080      else
1081      {
1082        WerrorS("system(\"sdb_flags\",`int`) expected");
1083        return TRUE;
1084      }
1085      return FALSE;
1086    }
1087    else
1088/*==================== sdb_edit =================*/
1089    if (strcmp(sys_cmd, "sdb_edit") == 0)
1090    {
1091      if ((h!=NULL) && (h->Typ()==PROC_CMD))
1092      {
1093        procinfov p=(procinfov)h->Data();
1094        sdb_edit(p);
1095      }
1096      else
1097      {
1098        WerrorS("system(\"sdb_edit\",`proc`) expected");
1099        return TRUE;
1100      }
1101      return FALSE;
1102    }
1103    else
1104/*==================== GF =================*/
1105#if 0
1106    if (strcmp(sys_cmd, "GF") == 0)
1107    {
1108      int c=rChar(currRing);
1109      setCharacteristic( c, 2);
1110      CanonicalForm F( convSingGFClapGF( (poly)h->Data() ) );
1111      res->rtyp=POLY_CMD;
1112      res->data=convClapGFSingGF( F );
1113      return FALSE;
1114    }
1115    else
1116#endif
1117#ifdef HAVE_WALK
1118/*==================== walk stuff =================*/
1119    if (strcmp(sys_cmd, "walkNextWeight") == 0)
1120    {
1121      if (h == NULL || h->Typ() != INTVEC_CMD ||
1122          h->next == NULL || h->next->Typ() != INTVEC_CMD ||
1123          h->next->next == NULL || h->next->next->Typ() != IDEAL_CMD)
1124      {
1125        Werror("system(\"walkNextWeight\", intvec, intvec, ideal) expected");
1126        return TRUE;
1127      }
1128
1129      if (((intvec*) h->Data())->length() != currRing->N ||
1130          ((intvec*) h->next->Data())->length() != currRing->N)
1131      {
1132        Werror("system(\"walkNextWeight\" ...) intvecs not of length %d\n",
1133               currRing->N);
1134        return TRUE;
1135      }
1136      res->data = (void*) walkNextWeight(((intvec*) h->Data()),
1137                                         ((intvec*) h->next->Data()),
1138                                         (ideal) h->next->next->Data());
1139      if (res->data == (void*) 0 || res->data == (void*) 1)
1140      {
1141        res->rtyp = INT_CMD;
1142      }
1143      else
1144      {
1145        res->rtyp = INTVEC_CMD;
1146      }
1147      return FALSE;
1148    }
1149    else if (strcmp(sys_cmd, "walkInitials") == 0)
1150    {
1151      if (h == NULL || h->Typ() != IDEAL_CMD)
1152      {
1153        WerrorS("system(\"walkInitials\", ideal) expected");
1154        return TRUE;
1155      }
1156
1157      res->data = (void*) walkInitials((ideal) h->Data());
1158      res->rtyp = IDEAL_CMD;
1159      return FALSE;
1160    }
1161    else
1162#endif
1163/*==================== test =================*/
1164    if (strcmp(sys_cmd, "test") == 0)
1165    {
1166      intvec v(3);
1167     
1168      v[4] = 1;
1169     
1170    }
1171/*==================== Error =================*/
1172      Werror( "system(\"%s\",...) %s", sys_cmd, feNotImplemented );
1173  }
1174  return TRUE;
1175}
1176#endif // HAVE_EXTENDED_SYSTEM
Note: See TracBrowser for help on using the repository browser.