source: git/Singular/extra.cc @ c232af

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