source: git/Singular/extra.cc @ 8cfee1c

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