source: git/Singular/mpsr_Get.cc @ c45b8f0

spielwiese
Last change on this file since c45b8f0 was b1dfaf, checked in by Frank Seelisch <seelisch@…>, 14 years ago
patch from Kai (checked for problems under Windows OS: no problems) git-svn-id: file:///usr/local/Singular/svn/trunk@13210 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100644
File size: 25.7 KB
Line 
1/****************************************
2*  Computer Algebra System SINGULAR     *
3****************************************/
4
5/* $Id$ */
6/***************************************************************
7 *
8 * File:       mpsr_Get.cc
9 * Purpose:    definition of the main Get routine(s)
10 * Author:     Olaf Bachmann (10/95)
11 *
12 * Change History (most recent first):
13 *
14 ***************************************************************/
15
16#include <kernel/mod2.h>
17
18#ifdef HAVE_MPSR
19
20
21#include"mpsr_Get.h"
22#include"mpsr_Tok.h"
23
24#include <Singular/tok.h>
25#include <kernel/longrat.h>
26#include <kernel/intvec.h>
27#include <kernel/ideals.h>
28#include <kernel/matpol.h>
29#include <Singular/lists.h>
30
31#include <mylimits.h>
32
33omBin mpsr_sleftv_bin = omGetSpecBin(sizeof(mpsr_sleftv));
34
35/***************************************************************
36 *
37 * prototypes
38 *
39 ***************************************************************/
40static mpsr_Status_t GetIntVecLeftv(MP_Link_pt link, MPT_Node_pt node,
41                                  mpsr_leftv mlv);
42static mpsr_Status_t GetIntMatLeftv(MP_Link_pt link, MPT_Node_pt node,
43                                  mpsr_leftv mlv);
44static mpsr_Status_t GetRingLeftv(MP_Link_pt link, MPT_Node_pt node,
45                                mpsr_leftv mlv);
46static mpsr_Status_t GetPolyLeftv(MP_Link_pt link, MPT_Node_pt node,
47                                mpsr_leftv mlv, BOOLEAN IsUnOrdered);
48static mpsr_Status_t GetPolyVectorLeftv(MP_Link_pt link, MPT_Node_pt node,
49                                        mpsr_leftv mlv,
50                                        BOOLEAN IsUnOrdered = FALSE);
51static mpsr_Status_t GetIdealLeftv(MP_Link_pt link, MPT_Node_pt node,
52                                 mpsr_leftv mlv, BOOLEAN IsUnOrdered = FALSE);
53static mpsr_Status_t GetModuleLeftv(MP_Link_pt link, MPT_Node_pt node,
54                                  mpsr_leftv mlv, BOOLEAN IsUnOrdered = FALSE);
55static mpsr_Status_t GetMatrixLeftv(MP_Link_pt link, MPT_Node_pt node,
56                                  mpsr_leftv mlv, BOOLEAN IsUnOrdered = FALSE);
57static mpsr_Status_t GetMapLeftv(MP_Link_pt link, MPT_Node_pt node,
58                               mpsr_leftv mlv);
59static mpsr_Status_t GetCopCommandLeftv(MP_Link_pt link, MPT_Node_pt node,
60                                      mpsr_leftv mlv, short quote);
61
62/***************************************************************
63 *
64 * Inlines
65 *
66 ***************************************************************/
67
68//
69// Predicates which examine nodes for primitive Singular types
70//
71#define fr(cond)    if (! (cond)) return FALSE
72
73static inline BOOLEAN IsIntVecNode(MPT_Node_pt node)
74{
75  fr(NodeCheck(node, MP_MatrixDict, MP_CopMatrixDenseVector));
76
77  MPT_Tree_pt tree = MPT_ProtoAnnotValue(node);
78  return tree != NULL && NodeCheck(tree->node, MP_CommonMetaType,
79                                   MP_ProtoDict, MP_CmtProtoIMP_Sint32);
80}
81
82static inline BOOLEAN IsIntMatNode(MPT_Node_pt node)
83{
84  fr(NodeCheck(node, MP_MatrixDict, MP_CopMatrixDenseMatrix));
85
86  MPT_Tree_pt tree = MPT_ProtoAnnotValue(node);
87  return tree != NULL && NodeCheck(tree->node, MP_CommonMetaType,
88                                   MP_ProtoDict, MP_CmtProtoIMP_Sint32);
89}
90
91static inline BOOLEAN IsRingNode(MPT_Node_pt node, ring &r, BOOLEAN &IsUnOrdered)
92{
93  BOOLEAN mv;
94  return
95    NodeCheck(node, MP_PolyDict, MP_CopPolyRing) &&
96    mpsr_GetRingAnnots(node, r, mv, IsUnOrdered) == mpsr_Success;
97}
98
99static inline BOOLEAN IsPolyNode(MPT_Node_pt node, ring &r, BOOLEAN &IsUnOrdered)
100{
101  BOOLEAN mv;
102
103  //for the timne being, we only accept DDP's
104  return
105    NodeCheck(node, MP_PolyDict, MP_CopPolyDenseDistPoly) &&
106    MPT_Annot(node, MP_PolyDict, MP_AnnotPolyModuleVector) == NULL &&
107    mpsr_GetRingAnnots(node, r, mv, IsUnOrdered) == mpsr_Success;
108}
109
110static inline BOOLEAN IsPolyVectorNode(MPT_Node_pt node, ring &r,
111                                BOOLEAN &IsUnOrdered)
112{
113  BOOLEAN mv;
114
115  //for the timne being, we only accept DDP's
116  return
117    NodeCheck(node, MP_PolyDict, MP_CopPolyDenseDistPoly) &&
118    MPT_Annot(node, MP_PolyDict, MP_AnnotPolyModuleVector) != NULL &&
119    mpsr_GetRingAnnots(node, r, mv, IsUnOrdered) == mpsr_Success;
120}
121
122static inline BOOLEAN IsIdealNode(MPT_Node_pt node, ring &r,
123                           BOOLEAN &IsUnOrdered)
124{
125  fr(NodeCheck(node, MP_PolyDict, MP_CopPolyIdeal));
126  MPT_Tree_pt tree = MPT_ProtoAnnotValue(node);
127  fr(tree != NULL);
128  node = tree->node;
129  return
130    node->type == MP_CommonMetaOperatorType &&
131    node->numchild == 0 &&
132    IsPolyNode(node, r, IsUnOrdered);
133}
134
135static inline BOOLEAN IsModuleNode(MPT_Node_pt node, ring &r, BOOLEAN &IsUnOrdered)
136{
137  fr(NodeCheck(node, MP_PolyDict, MP_CopPolyModule));
138  MPT_Tree_pt tree = MPT_ProtoAnnotValue(node);
139  fr(tree != NULL);
140  node = tree->node;
141  return
142    node->type == MP_CommonMetaOperatorType &&
143    node->numchild == 0 &&
144    IsPolyVectorNode(node, r, IsUnOrdered);
145}
146
147static inline BOOLEAN IsMatrixNode(MPT_Node_pt node, ring &r, BOOLEAN &IsUnOrdered)
148{
149  fr(NodeCheck(node, MP_MatrixDict, MP_CopMatrixDenseMatrix));
150  MPT_Tree_pt tree = MPT_ProtoAnnotValue(node);
151  fr(tree != NULL);
152  node = tree->node;
153  return
154    node->type == MP_CommonMetaOperatorType &&
155    node->numchild == 0 &&
156    IsPolyNode(node, r, IsUnOrdered);
157}
158
159static inline BOOLEAN IsQuitNode(MPT_Node_pt node)
160{
161  return NodeCheck(node, MP_MpDict, MP_CopMpEndSession);
162}
163
164//
165// Init*Leftv functions
166//
167static inline void InitIntLeftv(mpsr_leftv mlv, int i)
168{
169  mlv->lv = mpsr_InitLeftv(INT_CMD, (void *) i);
170}
171
172static inline void InitApIntLeftv(mpsr_leftv mlv, mpz_ptr apint)
173{
174  number n = (number) omAllocBin(rnumber_bin);
175#if defined(LDEBUG)
176    n->debug=123456;
177#endif
178  mlv->r = mpsr_rDefault(0);
179  n->s = 3;
180  memcpy(&(n->z), apint, sizeof(mpz_t));
181  nlNormalize(n);
182  omFreeSize(apint, sizeof(mpz_t));
183  mlv->lv = mpsr_InitLeftv(NUMBER_CMD, n);
184}
185
186static inline void InitReal32Leftv(mpsr_leftv mlv, MPT_Arg_t r32)
187{
188  number n = (number) r32;
189//  n = Real32_2_Number(r32);
190
191  mlv->r = mpsr_rDefault(-1);
192  mlv->lv = mpsr_InitLeftv(NUMBER_CMD, n);
193}
194
195static inline void InitIdentifierLeftv(mpsr_leftv mlv, char *name, short quote)
196{
197  int pos;
198
199  if (quote <= 0)
200  {
201    idhdl h = mpsr_FindIdhdl(name, mlv->r);
202
203    if (h != NULL)
204    {
205      mlv->lv = mpsr_InitLeftv(IDHDL, (void *) h);
206    }
207    else if (strcmp(name, "basering") == 0)
208    {
209      mlv->lv = mpsr_InitLeftv(IDHDL, (void*) currRingHdl);
210      mlv->lv->name=IDID(currRingHdl);
211      mlv->lv->attribute=IDATTR(currRingHdl);
212    }
213    else
214    {
215      poly p;
216
217      pos = mpsr_rDefault(0, name, mlv->r);
218      mpsr_SetCurrRing(mlv->r, TRUE);
219      p = pOne();
220      pSetExp(p,pos+1, 1);
221      pSetm(p);
222      mlv->lv = mpsr_InitLeftv(POLY_CMD, (void *) p);
223    }
224    omFree(name);
225  }
226  else
227  {
228    mlv->lv = mpsr_InitLeftv(DEF_CMD, NULL);
229    mlv->lv->name = name;
230  }
231}
232
233/* primitive mpsr_Get*Leftv functions */
234
235static inline mpsr_Status_t mpsr_GetIntLeftv(MPT_Node_pt node, mpsr_leftv mlv)
236{
237  mpsr_assume(MP_IsFixedIntegerType(node->type));
238  mlv->lv = mpsr_InitLeftv(INT_CMD, node->nvalue);
239  return mpsr_Success;
240}
241
242static inline mpsr_Status_t mpsr_GetReal32Leftv(MPT_Node_pt node, mpsr_leftv mlv)
243{
244  mpsr_assume(node->type == MP_Real32Type);
245  InitReal32Leftv(mlv, node->nvalue);
246  return mpsr_Success;
247}
248
249static inline mpsr_Status_t mpsr_GetApIntLeftv(MPT_Node_pt node, mpsr_leftv mlv)
250{
251  InitApIntLeftv(mlv, (mpz_ptr)  node->nvalue);
252  node->nvalue = NULL;
253  return mpsr_Success;
254}
255
256static inline mpsr_Status_t mpsr_GetIdentifierLeftv(MPT_Node_pt node, mpsr_leftv mlv,
257                                             short quote)
258{
259  mpsr_assume(MP_IsIdType(node->type));
260  char *id;
261  MPT_Annot_pt proc_annot = MPT_Annot(node, MP_SingularDict,
262                                      MP_AnnotSingularProcDef);
263
264  if (node->type == MP_CommonGreekIdentifierType ||
265      node->type == MP_CommonGreekIdentifierType)
266  {
267    id  = (char *) omAlloc(2*sizeof(char));
268    id[1] = '\0';
269    id[0] = MP_UINT8_T(node->nvalue);
270  }
271  else
272  {
273    id = MP_STRING_T(node->nvalue);
274    node->nvalue = NULL;
275  }
276
277  InitIdentifierLeftv(mlv, id, quote);
278
279  if (proc_annot != NULL) mlv->lv->rtyp = PROC_CMD;
280
281  return mpsr_Success;
282}
283
284static inline mpsr_Status_t mpsr_GetStringLeftv(MPT_Node_pt node, mpsr_leftv mlv)
285{
286  mpsr_assume(node->type == MP_StringType);
287  mlv->lv = mpsr_InitLeftv(STRING_CMD, MP_STRING_T(node->nvalue));
288  node->nvalue = NULL;
289  return mpsr_Success;
290}
291
292static inline mpsr_Status_t GetQuitLeftv(mpsr_leftv mlv)
293{
294  mlv->lv = mpsr_InitLeftv(STRING_CMD, (void *) omStrDup(MPSR_QUIT_STRING));
295  return mpsr_Success;
296}
297
298/***************************************************************
299 *
300 * The top-level routine for getting a message
301 *
302 ***************************************************************/
303mpsr_Status_t mpsr_GetMsg(MP_Link_pt link, leftv &lv)
304{
305  mpsr_sleftv mlv, mlv1;
306  mpsr_Status_t status = mpsr_Success;
307  mlv.lv = NULL;
308  mlv.r = NULL;
309  mlv1.lv = NULL;
310  mlv1.r = NULL;
311
312  status = (MP_InitMsg(link) == MP_Success ? mpsr_Success : mpsr_MP_Failure);
313
314  if (status == mpsr_Success && ! MP_TestEofMsg(link))
315    status = mpsr_GetLeftv(link, &mlv, 0);
316  else
317  {
318    lv = mpsr_InitLeftv(NONE, NULL);
319    return status;
320  }
321
322  // handle more than one leftv (ie. chains of leftv's)
323  while (status == mpsr_Success && ! MP_TestEofMsg(link))
324  {
325    // Get next leftv
326    status = mpsr_GetLeftv(link, &mlv1, 0);
327    if (status == mpsr_Success)
328      status = mpsr_MergeLeftv(&mlv, &mlv1);
329  }
330
331  if (status == mpsr_Success)
332  {
333    // Now mlv is our leftv -- check whether r has an ordering set
334    if (mlv.r != NULL && mlv.r->order[0] == ringorder_unspec)
335    {
336        ring r = rCopy(mlv.r);
337        r->order[0] = ringorder_dp;
338        mpsr_rSetOrdSgn(r);
339        mpsr_MapLeftv(mlv.lv, mlv.r, r);
340        rKill(mlv.r);
341        mlv.r = r;
342    }
343
344    mpsr_SetCurrRingHdl(&mlv);
345
346    lv = mlv.lv;
347  }
348  else lv = mpsr_InitLeftv(NONE, NULL);
349
350  return status;
351}
352
353/***************************************************************
354 *
355 * Top-level routine for getting a mpsr_leftv
356 *
357 ***************************************************************/
358
359// if quote > 0, then identifiers are not tried to be resolved, or
360// converted into a ring variable
361mpsr_Status_t mpsr_GetLeftv(MP_Link_pt link, mpsr_leftv mlv, short quote)
362{
363  MPT_Node_pt node = NULL;
364  MP_NodeType_t type;
365  mlv->r = NULL;
366  mlv->lv = NULL;
367
368  mpt_failr(MPT_GetNode(link, &node));
369
370  type = node->type;
371
372  if (MP_IsFixedIntegerType(type))
373    failr(mpsr_GetIntLeftv(node, mlv));
374  else if (MP_IsIdType(type))
375    failr(mpsr_GetIdentifierLeftv(node, mlv, quote));
376  else
377  {
378    switch (node->type)
379    {
380        case MP_ApIntType:
381          failr(mpsr_GetApIntLeftv(node, mlv));
382          break;
383
384        case MP_StringType:
385          failr(mpsr_GetStringLeftv(node, mlv));
386          break;
387
388        case MP_Real32Type:
389          failr(mpsr_GetReal32Leftv(node, mlv));
390          break;
391
392        case MP_CommonOperatorType:
393          failr(mpsr_GetCommonOperatorLeftv(link, node, mlv, quote));
394          break;
395
396        case MP_OperatorType:
397          failr(mpsr_GetOperatorLeftv(link, node, mlv, quote));
398          break;
399
400        default:
401          MPT_DeleteNode(node);
402          return mpsr_SetError(mpsr_UnknownMPNodeType);
403    }
404  }
405
406  // everything was ok
407  MPT_DeleteNode(node);
408  return mpsr_Success;
409}
410
411/***************************************************************
412 *
413 * mpsr_Get*Leftv
414 *
415 ***************************************************************/
416mpsr_Status_t mpsr_GetCommonOperatorLeftv(MP_Link_pt link,
417                                          MPT_Node_pt node,
418                                          mpsr_leftv mlv,
419                                          short quote)
420{
421  mpsr_assume(node->type == MP_CommonOperatorType);
422  BOOLEAN IsUnOrdered;
423
424  // Check for Singular data types
425  // IntVec
426  if (IsIntVecNode(node))
427    return GetIntVecLeftv(link, node, mlv);
428  // IntMat
429  else if (IsIntMatNode(node))
430    return GetIntMatLeftv(link, node, mlv);
431  // Ring
432  else if (IsRingNode(node, mlv->r, IsUnOrdered))
433    return GetRingLeftv(link, node, mlv);
434  // Poly
435  else if (IsPolyNode(node, mlv->r, IsUnOrdered))
436    return GetPolyLeftv(link, node, mlv, IsUnOrdered);
437  // PolyVector
438  else if (IsPolyVectorNode(node, mlv->r, IsUnOrdered))
439    return GetPolyVectorLeftv(link, node, mlv, IsUnOrdered);
440  // Ideal
441  else if (IsIdealNode(node, mlv->r, IsUnOrdered))
442    return GetIdealLeftv(link, node, mlv, IsUnOrdered);
443  // Module
444  else if (IsModuleNode(node, mlv->r, IsUnOrdered))
445    return GetModuleLeftv(link, node, mlv, IsUnOrdered);
446  // Matrix
447  else if (IsMatrixNode(node, mlv->r, IsUnOrdered))
448    return GetMatrixLeftv(link, node, mlv, IsUnOrdered);
449  else if (IsQuitNode(node))
450    return GetQuitLeftv(mlv);
451  // Map
452  else
453    // now it should be a command (which handles Proc, Map and List
454    // seperately)
455    return GetCopCommandLeftv(link, node, mlv, quote);
456}
457
458mpsr_Status_t mpsr_GetOperatorLeftv(MP_Link_pt link,
459                                  MPT_Node_pt node,
460                                  mpsr_leftv mlv,
461                                  short quote)
462{
463  mpsr_assume(node->type == MP_OperatorType);
464  MP_NumChild_t nc = node->numchild, i;
465  mpsr_sleftv smlv1, *mlv1 = &smlv1;
466
467
468  if (MPT_ProtoAnnotValue(node) != NULL)
469    return mpsr_SetError(mpsr_CanNotHandlePrototype);
470
471  if (nc > 0)
472  {
473    failr(mpsr_GetLeftv(link, mlv, quote));
474    for (i=1; i<nc; i++)
475    {
476      failr(mpsr_GetLeftv(link, mlv1, quote));
477      failr(mpsr_MergeLeftv(mlv, mlv1));
478    }
479  }
480
481  command cmd = (command) omAlloc0Bin(sip_command_bin);
482  cmd->op = PROC_CMD;
483  cmd->arg1.rtyp = STRING_CMD;
484  cmd->arg1.data = (void *) omStrDup(MP_STRING_T(node->nvalue));
485
486  if (node->numchild > 0)
487  {
488    cmd->argc = 2;
489    memcpy(&(cmd->arg2), mlv->lv, sizeof(sleftv));
490    omFreeBin(mlv->lv, sleftv_bin);
491  }
492  else cmd->argc = 1;
493
494  mlv->lv = mpsr_InitLeftv(COMMAND, (void *) cmd);
495  return mpsr_Success;
496}
497
498/***************************************************************
499 *
500 * Get*Leftv routines
501 *
502 ***************************************************************/
503//
504// Get*Leftv routines
505//
506static mpsr_Status_t GetIntVecLeftv(MP_Link_pt link, MPT_Node_pt node,
507                                  mpsr_leftv mlv)
508{
509  intvec *iv = new intvec(node->numchild);
510  int *v = iv->ivGetVec();
511
512  mp_failr(IMP_GetSint32Vector(link, &v, node->numchild));
513  mlv->lv = mpsr_InitLeftv(INTVEC_CMD, (void *) iv);
514  return mpsr_Success;
515}
516
517static mpsr_Status_t GetIntMatLeftv(MP_Link_pt link, MPT_Node_pt node,
518                                  mpsr_leftv mlv)
519{
520  intvec *iv;
521  int row = node->numchild, col = 1, *v;
522  MPT_Annot_pt annot = MPT_Annot(node, MP_MatrixDict,
523                                 MP_AnnotMatrixDimension);
524  if (annot != NULL &&
525      annot->value != NULL &&
526      annot->value->node->numchild == 2 &&
527      NodeCheck(annot->value->node, MP_CommonOperatorType, MP_BasicDict,
528                MP_CopBasicList))
529  {
530    MPT_Tree_pt *tarray = (MPT_Tree_pt *) annot->value->args;
531    if (tarray[0]->node->type == MP_Sint32Type &&
532        tarray[1]->node->type == MP_Sint32Type)
533    {
534      row = MP_SINT32_T(tarray[0]->node->nvalue);
535      col = MP_SINT32_T(tarray[1]->node->nvalue);
536    }
537  }
538
539  iv = new intvec(row, col, 0);
540  v = iv->ivGetVec();
541  mp_failr(IMP_GetSint32Vector(link, &v, node->numchild));
542  mlv->lv = mpsr_InitLeftv(INTMAT_CMD, (void *) iv);
543  return mpsr_Success;
544}
545
546static mpsr_Status_t GetRingLeftv(MP_Link_pt link, MPT_Node_pt node,
547                                mpsr_leftv mlv)
548{
549  mpsr_assume(mlv->r != NULL);
550
551  if (node->numchild != 0) mpt_failr(MPT_SkipArgs(link, node));
552
553  mlv->lv = mpsr_InitLeftv(((mlv->r->qideal != NULL) ? (short) QRING_CMD :
554                            (short) RING_CMD),
555                           (void *) mlv->r);
556  mlv->r = NULL;
557  return mpsr_Success;
558}
559
560static mpsr_Status_t GetPolyLeftv(MP_Link_pt link, MPT_Node_pt node,
561                                  mpsr_leftv mlv, BOOLEAN IsUnOrdered)
562{
563  poly p;
564
565  mpsr_assume(mlv->r != NULL);
566
567  failr(mpsr_GetPoly(link, p, node->numchild, mlv->r));
568  if (IsUnOrdered) p = pSort(p);
569  pTest(p);
570  mlv->lv = mpsr_InitLeftv(POLY_CMD, (void *) p);
571  return mpsr_Success;
572}
573
574static mpsr_Status_t GetPolyVectorLeftv(MP_Link_pt link, MPT_Node_pt node,
575                                      mpsr_leftv mlv, BOOLEAN IsUnOrdered)
576{
577  poly p;
578
579  mpsr_assume(mlv->r != NULL);
580
581  failr(mpsr_GetPolyVector(link, p, node->numchild, mlv->r));
582  if (IsUnOrdered) p = pSort(p);
583  pTest(p);
584  mlv->lv = mpsr_InitLeftv(VECTOR_CMD, (void *) p);
585  return mpsr_Success;
586}
587
588static mpsr_Status_t GetIdealLeftv(MP_Link_pt link, MPT_Node_pt node,
589                                 mpsr_leftv mlv, BOOLEAN IsUnOrdered)
590{
591  MP_NumChild_t nc = node->numchild, i;
592  ring r = mlv->r;
593  MP_Uint32_t nmon;
594
595  mpsr_assume(r != NULL);
596  ideal id = idInit(nc,1);
597  for (i=0; i<nc; i++)
598  {
599    mp_failr(IMP_GetUint32(link, &nmon));
600    failr(mpsr_GetPoly(link, id->m[i], nmon, r));
601    if (IsUnOrdered) id->m[i] = pSort(id->m[i]);
602  }
603  idTest(id);
604  mlv->lv = mpsr_InitLeftv(IDEAL_CMD, (void *) id);
605  return mpsr_Success;
606}
607
608static mpsr_Status_t GetModuleLeftv(MP_Link_pt link, MPT_Node_pt node,
609                                  mpsr_leftv mlv, BOOLEAN IsUnOrdered)
610{
611  MP_NumChild_t nc = node->numchild, i;
612  ring r = mlv->r;
613  MP_Uint32_t nmon, rank = 1;
614  MPT_Annot_pt annot = MPT_Annot(node, MP_PolyDict,
615                                     MP_AnnotPolyModuleRank);
616  if (annot != NULL &&
617      annot->value != NULL &&
618      annot->value->node->type == MP_Uint32Type
619      )
620    rank = MP_UINT32_T(annot->value->node->nvalue);
621
622  mpsr_assume(r != NULL);
623  ideal id = idInit(nc,rank);
624  for (i=0; i<nc; i++)
625  {
626    mp_failr(IMP_GetUint32(link, &nmon));
627    failr(mpsr_GetPolyVector(link, id->m[i], nmon, r));
628    if (IsUnOrdered) id->m[i] = pSort(id->m[i]);
629  }
630  if (rank == 1)
631    id->rank = idRankFreeModule(id);
632  idTest(id);
633  mlv->lv = mpsr_InitLeftv(MODUL_CMD, (void *) id);
634  return mpsr_Success;
635}
636
637static mpsr_Status_t GetMatrixLeftv(MP_Link_pt link, MPT_Node_pt node,
638                                  mpsr_leftv mlv, BOOLEAN IsUnOrdered)
639{
640  MP_NumChild_t nc = node->numchild, row = nc, col = 1, i;
641  matrix mp;
642  MP_Uint32_t nmon;
643  MPT_Annot_pt annot = MPT_Annot(node, MP_MatrixDict,
644                                     MP_AnnotMatrixDimension);
645  if (annot != NULL &&
646      annot->value != NULL &&
647      annot->value->node->numchild == 2 &&
648      NodeCheck(annot->value->node, MP_CommonOperatorType, MP_BasicDict,
649               MP_CopBasicList))
650  {
651    MPT_Tree_pt *tarray = (MPT_Tree_pt *) annot->value->args;
652    if (tarray[0]->node->type == MP_Sint32Type &&
653        tarray[1]->node->type == MP_Sint32Type)
654    {
655      row = MP_SINT32_T(tarray[0]->node->nvalue);
656      col = MP_SINT32_T(tarray[1]->node->nvalue);
657    }
658  }
659
660  mpsr_assume(mlv->r != NULL);
661  mp = mpNew(row, col);
662  for (i=0; i<nc; i++)
663  {
664    mp_failr(IMP_GetUint32(link, &nmon));
665    failr(mpsr_GetPoly(link, mp->m[i], nmon, mlv->r));
666    if (IsUnOrdered) mp->m[i] = pSort(mp->m[i]);
667  }
668
669  mlv->lv = mpsr_InitLeftv(MATRIX_CMD, (void *) mp);
670  return mpsr_Success;
671}
672
673static mpsr_Status_t GetPackageLeftv(MP_Link_pt link, MPT_Node_pt node,
674                                     mpsr_leftv mlv)
675{
676  package pack = (package) omAlloc0Bin(sip_package_bin);
677
678  pack->language = LANG_NONE;
679
680  if (node->numchild > 0)
681  {
682    failr(mpsr_GetLeftv(link, mlv, 0));
683    if (mlv->lv->rtyp != STRING_CMD)
684      return mpsr_SetError(mpsr_WrongArgumentType);
685    pack->libname = (char*) mlv->lv->data;
686    mlv->lv->rtyp = PACKAGE_CMD;
687  }
688  else
689    mlv->lv = mpsr_InitLeftv(PACKAGE_CMD, NULL);
690
691  mlv->lv->data = (void*) pack;
692
693  MPT_Annot_pt annot = MPT_Annot(node, MP_SingularDict,
694                                 MP_AnnotSingularPackageType);
695  if (annot != NULL && annot->value != NULL && annot->value->node)
696  {
697    MPT_Node_pt node = annot->value->node;
698    if (node->type == MP_Uint8Type && MP_UINT8_T(node->nvalue) < LANG_MAX)
699      pack->language =  (language_defs) MP_UINT8_T(node->nvalue);
700  }
701  return mpsr_Success;
702}
703
704
705static mpsr_Status_t GetMapLeftv(MP_Link_pt link, MPT_Node_pt node,
706                               mpsr_leftv mlv)
707{
708  mpsr_sleftv smlv1, smlv2, *mlv1 = &smlv1, *mlv2 = &smlv2;
709
710  if (node->numchild != 3)
711    return mpsr_SetError(mpsr_WrongNumofArgs);
712
713  failr(mpsr_GetLeftv(link, mlv, 0));
714  failr(mpsr_GetLeftv(link, mlv1, 0));
715  failr(mpsr_GetLeftv(link, mlv2, 0));
716
717  if (mlv->lv->rtyp != RING_CMD ||
718      mlv1->lv->rtyp != STRING_CMD ||
719      mlv2->lv->rtyp != IDEAL_CMD)
720    return mpsr_SetError(mpsr_WrongArgumentType);
721
722  ring r = (ring) mlv->lv->data, r2;
723  char *name = (char *) mlv1->lv->data;
724  ideal id = (ideal) mlv2->lv->data;
725
726  idhdl h = mpsr_FindIdhdl(name, r2);
727  if (h == NULL || IDTYP(h) != RING_CMD || ! rEqual(IDRING(h), r))
728  {
729    h = mpsr_InitIdhdl(RING_CMD, r, name);
730    h->next = IDROOT;
731    IDROOT = h;
732  }
733
734  map m = (map) omAlloc0Bin(sip_sideal_bin);
735  m->preimage = omStrDup(name);
736  m->m = id->m;
737  m->nrows = id->nrows;
738  m->ncols = id->ncols;
739
740  omFreeBin(mlv->lv, sleftv_bin);
741
742  omFree(mlv1->lv->data);
743  omFreeBin(mlv1->lv, sleftv_bin);
744
745  omFreeBin(id, sip_sideal_bin);
746  omFreeBin(mlv2->lv, sleftv_bin);
747
748  mlv->r = mlv2->r;
749  mlv->lv = mpsr_InitLeftv(MAP_CMD, (void *) m);
750
751  return mpsr_Success;
752}
753
754
755static mpsr_Status_t GetCopCommandLeftv(MP_Link_pt link, MPT_Node_pt node,
756                                        mpsr_leftv mlv, short quote)
757{
758  short tok;
759  MP_NumChild_t nc = node->numchild, i;
760  mpsr_sleftv smlv1, *mlv1 = &smlv1;
761  MPT_Tree_pt typespec;
762
763
764  failr(mpsr_mp2tok(node->dict, MP_COMMON_T(node->nvalue), &tok));
765
766  if ((typespec = MPT_ProtoAnnotValue(node)) &&
767      MPT_IsTrueProtoTypeSpec(typespec))
768    return mpsr_SetError(mpsr_CanNotHandlePrototype);
769
770  if (tok == MAP_CMD) return GetMapLeftv(link, node, mlv);
771  if (tok == PACKAGE_CMD) return GetPackageLeftv(link, node, mlv);
772  if (tok == COLONCOLON) quote++;
773
774  if (nc > 0)
775  {
776    if (tok == '=') failr(mpsr_GetLeftv(link, mlv, quote + 1));
777    else failr(mpsr_GetLeftv(link, mlv, quote));
778  }
779
780  for (i=1; i<nc; i++)
781  {
782    failr(mpsr_GetLeftv(link, mlv1, quote));
783    failr(mpsr_MergeLeftv(mlv, mlv1));
784  }
785
786  command cmd = (command) omAlloc0Bin(sip_command_bin);
787  cmd->op = tok;
788  cmd->argc = nc;
789
790  // check that associative operators are binary
791  if (nc > 2 && (tok == '+' || tok == '*'))
792  {
793    leftv lv = mlv->lv, lv2;
794    command c = cmd, c2;
795
796    for (i=2; i<nc; i++)
797    {
798      c->op = tok;
799      c->argc = 2;
800      memcpy(&(c->arg1), lv, sizeof(sleftv));
801      c->arg1.next = NULL;
802
803      c2 = (command) omAlloc0Bin(sip_command_bin);
804      c->arg2.data = (void *) c2;
805      c->arg2.rtyp = COMMAND;
806      c = c2;
807      lv2 = lv->next;
808      omFreeBin(lv, sleftv_bin);
809      lv = lv2;
810    }
811    c->op = tok;
812    c->argc = 2;
813    memcpy(&(c->arg1), lv, sizeof(sleftv));
814    c->arg1.next = NULL;
815    memcpy(&(c->arg2), lv->next, sizeof(sleftv));
816    omFreeBin(lv->next, sleftv_bin);
817    omFreeBin(lv, sleftv_bin);
818  }
819  else if (nc >= 1)
820  {
821    memcpy(&(cmd->arg1), mlv->lv, sizeof(sleftv));
822    if (nc <= 3)
823    {
824      (cmd->arg1).next = NULL;
825      if (nc >= 2)
826      {
827        memcpy(&(cmd->arg2), mlv->lv->next, sizeof(sleftv));
828        (cmd->arg2).next = NULL;
829
830        if (nc == 3)
831        {
832          memcpy(&(cmd->arg3), mlv->lv->next->next, sizeof(sleftv));
833          omFreeBin(mlv->lv->next->next, sleftv_bin);
834        }
835        omFreeBin(mlv->lv->next, sleftv_bin);
836      }
837    }
838    omFreeBin(mlv->lv, sleftv_bin);
839  }
840
841  // Now we perform some tree manipulations
842  if (nc == 0 && tok == LIST_CMD)
843    // Here we work around a Singular bug: It can not handle lists of 0 args
844    // so we construct them explicitely
845  {
846    lists l = (lists) omAllocBin(slists_bin);
847    l->Init(0);
848    mlv->lv = mpsr_InitLeftv(LIST_CMD, (void *) l);
849    return mpsr_Success;
850  }
851  mlv->lv = mpsr_InitLeftv(COMMAND, (void *) cmd);
852  return mpsr_Success;
853}
854
855
856/***************************************************************
857 *
858 * The routine for Getting External Data
859 *
860 ***************************************************************/
861
862// this is all the data we want to have in directly when MPT_GetTree
863// is called, i.e. when the value of annots is read
864MPT_Status_t mpsr_GetExternalData(MP_Link_pt link,
865                                  MPT_Arg_t *odata,
866                                  MPT_Node_pt node)
867{
868  *odata = NULL;
869
870  if (node->type == MP_CommonOperatorType)
871  {
872    mpsr_sleftv mlv;
873    mpsr_Status_t status;
874    BOOLEAN IsUnOrdered;
875
876    // we would like to get polys and ideals directly
877    if (IsPolyNode(node, mlv.r, IsUnOrdered))
878      status = GetPolyLeftv(link, node, &mlv, IsUnOrdered);
879    // Ideal
880    else if (IsIdealNode(node, mlv.r, IsUnOrdered))
881      status = GetIdealLeftv(link, node, &mlv, IsUnOrdered);
882    else
883      return MPT_NotExternalData;
884
885    if (status == mpsr_Success)
886    {
887      mpsr_leftv mmlv = (mpsr_leftv) omAlloc0Bin(mpsr_sleftv_bin);
888      memcpy(mmlv, &mlv, sizeof(mpsr_sleftv));
889      *odata = (MPT_ExternalData_t) mmlv;
890      return MPT_Success;
891    }
892    else
893      return MPT_Failure;
894  }
895  else
896    return MPT_NotExternalData;
897}
898
899
900/***************************************************************
901 *
902 * A routine which gets the previous dump of Singular
903 *
904 ***************************************************************/
905
906mpsr_Status_t mpsr_GetDump(MP_Link_pt link)
907{
908  mpsr_sleftv mlv;
909  mpsr_Status_t status = mpsr_Success;
910
911  status = (MP_InitMsg(link) == MP_Success ? mpsr_Success : mpsr_MP_Failure);
912  while ((status == mpsr_Success) && (! MP_TestEofMsg(link)))
913  {
914    memset(&mlv,0,sizeof(mlv));
915    status=mpsr_GetLeftv(link, &mlv, 0);
916
917    if (status == mpsr_Success)
918    {
919#ifdef MPSR_DEBUG_DUMP
920      command cmd = (command) mlv.lv->data;
921      fprintf(stdout, "Dump got %s \n", cmd->arg1.name);
922      fflush(stdout);
923#endif
924      mpsr_SetCurrRingHdl(&mlv);
925      if (mlv.lv != NULL)
926      {
927        mlv.lv->Eval();
928        mlv.lv->CleanUp();
929        omFreeBin(mlv.lv, sleftv_bin);
930      }
931    }
932    else
933      mpsr_PrintError(status);
934  }
935  return status;
936}
937#endif
Note: See TracBrowser for help on using the repository browser.