source: git/Singular/extra.cc @ 584f84d

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