source: git/Singular/generate.pl @ 97a7b44

spielwiese
Last change on this file since 97a7b44 was faea11, checked in by Olaf Bachmann <obachman@…>, 25 years ago
* preparation for inclusion of Buckets git-svn-id: file:///usr/local/Singular/svn/trunk@3061 2c84dea3-7e68-4137-9b89-c4e89433aadc
  • Property mode set to 100755
File size: 21.8 KB
Line 
1#!/usr/local/bin/perl
2###########################################################################
3# $Id: generate.pl,v 1.3 1999-05-26 16:20:19 obachman Exp $
4
5###########################################################################
6##
7## FILE: generate.pl
8## PURPOSE: Generates Proc's and GetProc's as specified by templates and
9## variable @input. Writes result to stdout, warning/errors to stderr.
10## AUTHOR: obachman (3/98)
11##
12
13###########################################################################
14##
15## Supporting procedures
16##
17
18sub Warning
19{
20  print STDERR $_[0], "\n";
21}
22
23
24# Each occureence of CALL_<fn>(...) in $string is replaced by
25# `eval fn(..., $argv)'. Modified string is returned.
26sub Expand
27{
28  local($string, $argv) = @_;
29  local(@lines, @call, $call, $prefix, $postfix, $whitespaces, $result);
30  local($i, $j);
31
32  @lines = split(/\n/, $_[0]);
33  for ($i = 0; $i <= $#lines; $i++)
34  {
35    if ($lines[$i] =~ /CALL_/)
36    {
37      ($whitespaces, $prefix, $call, $postfix) = &ParseLine($lines[$i]);
38      #insert $argv as last argument to call
39      if ($call =~ /\(\s*\)$/)
40      {
41        $call =~ s/\(\s*\)$/\(\$argv\)/;
42      }
43      else
44      {
45        $call =~ s/\)$/\,\$argv\)/;
46      }
47      $call = "& ".$call.";";
48      $call = eval $call;
49      @call = split(/\n/,"$whitespaces$prefix$call$postfix");
50      for ($j=1; $j <= $#call; $j++)
51      {
52        $call[$j] = $whitespaces.$call[$j];
53      }
54      $lines[$i] = join("\n", @call);
55    }
56  }
57  $result = join("\n", @lines);
58  if ($call) 
59  {
60    return (&Expand($result));
61  }
62  else
63  {
64    return $result;
65  }
66}
67
68# takes a line containing CALL_ apart into and returns
69# ($whitespace, $prefix, $call, $postfix)
70sub ParseLine
71{
72  local($line) = @_;
73  local($i, $c_start, $c_length, $bcount);
74  local($whitespace, $prefix, $call, $postfix);
75 
76  while(substr($line, $i, 1) =~ /\s/ && $i <= length($line))
77  {
78    $whitespace = $whitespace.substr($line, $i, 1);
79    $i++;
80  }
81 
82  while(substr($line, $i) !~ /^CALL_/  && $i <= length($line))
83  {
84    $prefix = $prefix.substr($line, $i, 1);
85    $i++;
86  }
87 
88  $i = $i+5;
89  $c_start = $i;
90  while(substr($line, $i, 1) ne "(" && $i <= length($line))
91  {
92    $i++;
93  }
94  if (substr($line, $i, 1) eq "(")
95  {
96    $bcount = 1;
97    $i++;
98    while ($bcount > 0 && $i <= length($line))
99    {
100      if (substr($line, $i, 1) eq ")")
101      {
102        $bcount--;
103      }
104      elsif (substr($line, $i, 1) eq "(")
105      {
106        $bcount++;
107      }
108      elsif (substr($line, $i, 1) eq "\"")
109      {
110        $i++;
111        while ((substr($line, $i, 1) ne "\"" || 
112                substr($line, $i-1, 1) eq "\\") && 
113               $i <= length($line))
114        {
115          $i++;
116        }
117      }
118      $i++;
119    }
120  }
121  $call = substr($line, $c_start, $i - $c_start);
122  $postfix = substr($line, $i);
123  return ($whitespace, $prefix, $call, $postfix);
124}
125
126
127###########################################################################
128##
129## Specification of the properties which determine a Proc
130##
131## Properties need to have following syntax: propVAL, where prop is
132## short "prefix" name of properties, and needs to be in lower caps, and
133## VAL is possible value and needs to be in all upper caps.
134##
135## Furthermore, observe the following conventions
136## @Protperty = ("propGEN", "propVAL1", ...)
137## $EnumType{prop} = Property
138## GetProperty($string) should always return a valid value.
139
140## need to hard-wire properties here, because they are needed in the interface to surrounding C++-code:
141
142@Properties = ("ch", "ot", "hom", "nw");
143@Characteristics = ("chGEN", "chMODP");
144$EnumType{"ch"} = "Characteristics";
145sub GetCharacteristic
146{
147  foreach $element (split('_', $_[0]))
148  {
149    return ($element) if ($element =~ /^ch/ && 
150                          grep(/$element/, @Characteristics));
151  }
152  return $Characteristics[0];
153}
154 
155@OrderingTypes = ("otGEN", "otEXP", "otCOMPEXP", "otEXPCOMP", "otSYZDPC");
156$EnumType{"ot"} = "OrderingTypes";
157sub GetOrderingType
158{
159  foreach $element (split('_', $_[0]))
160  {
161    return ($element) if ($element =~ /^ot/ && 
162                         grep(/$element/, @OrderingTypes));
163  }
164  return $OrderingTypes[0];
165}
166
167@Homogs = ("homGEN", "homYES"); 
168$EnumType{"hom"} = "Homogs";
169sub GetHomog
170{
171  foreach $element (split('_', $_[0]))
172  {
173    return ($element) if ($element =~ /^hom/ &&
174                          grep(/$element/, @Homogs));
175  }
176  return $Homogs[0];
177}
178
179@NumWords = ("nwGEN", "nwONE", "nwTWO", "nwEVEN", "nwODD");
180$EnumType{"nw"} = "NumWords";
181sub GetNumWords
182{
183  foreach $element (split('_', $_[0]))
184  {
185    return ($element) if ($element =~ /^nw/ &&
186                          grep(/$element/, @NumWords));
187  }
188  return $NumWords[0];
189}
190
191# given a list of "short" prefix properties, generate enumeration type
192# specification for each property
193sub Generate_EnumTypes
194{
195  local(@evalues, $source);
196 
197  foreach $key (@_)
198  {
199    $etype = $EnumType{$key};
200    if ($etype =~ /\w+/)
201    {
202      @evalues = eval '@'.$etype;
203      if ($#evalues >= 0)
204      {
205        $source = $source."typedef enum $etype {". $evalues[0] . " = 0";
206        shift @evalues;
207        foreach $evalue (@evalues)
208        {
209          $source = $source.", $evalue";
210        }
211        $source = $source."} $etype;\n";
212      }
213      else
214      {
215        & Warning("No enum values for type: $etype");
216      }
217    }
218    else
219    {
220      & Warning("Unknown enumeration type index: $key");
221    }
222  }
223  return $source;
224}
225
226
227###########################################################################
228##
229## "Macros" needed in expansion of Procs
230##
231sub NCOPYNEG
232{
233  local($number, $argv) = @_;
234 
235  return "npNegM($number)" if (& GetCharacteristic($argv) eq "chMODP");
236  return "nNeg(nCopy($number))";
237}
238
239sub NNEG
240{
241  local($number, $argv) = @_;
242
243  return "npNegM($number)" if (& GetCharacteristic($argv) eq "chMODP");
244  return "nNeg($number)";
245}
246
247
248sub NDELETE
249{
250  local($number, $argv) = @_;
251 
252  return "" if (& GetCharacteristic($argv) eq "chMODP");
253  return "nDelete($number)";
254}
255
256sub NMULT
257{
258  local($m1, $m2, $argv) = @_;
259 
260  return "npMultM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
261  return "nMult($m1, $m2)";
262}
263
264sub NADD
265{
266  local($m1, $m2, $argv) = @_;
267 
268  return "npAddM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
269  return "nAdda($m1, $m2)";
270}
271
272sub NSUB
273{
274  local($m1, $m2, $argv) = @_;
275 
276  return "npSubM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
277  return "nSub($m1, $m2)";
278}
279
280sub NEQUAL
281{
282  local($m1, $m2, $argv) = @_;
283 
284  return "npEqualM($m1, $m2)" if (& GetCharacteristic($argv) eq "chMODP");
285  return "nEqual($m1, $m2)";
286} 
287
288sub NISZERO
289{
290  local($m1, $argv) = @_;
291 
292  return "npIsZeroM($m1)" if (& GetCharacteristic($argv) eq "chMODP");
293  return "nIsZero($m1)";
294}
295
296sub MULTCOPYX
297{
298  local($p, $monom, $n, $exp, $spNoether, $argv) = @_;
299 
300  return "spMultCopyX($p, $monom, $n, $exp, $spNoether)" 
301    if (& GetCharacteristic($argv) eq "chMODP");
302  return "spGMultCopyX($p, $monom, $n, $exp, $spNoether)";
303}
304
305sub INITORDER
306{
307  local($order, $p, $argv) = @_;
308 
309  return "$order = $p->Order" if (&GetHomog($argv) eq "homYES");
310  return "";
311}
312
313 
314sub PCOPYADDFAST
315{
316  local($p1, $p2, $p3, $order, $argv) = @_;
317 
318  return "pCopyAddFastHomog($p1, $p2, $p3, $order)" 
319    if (&GetHomog($argv) eq "homYES");
320  return "pCopyAddFast0($p1, $p2, $p3)";
321}
322
323sub PDELETE1
324{
325  local($p, $argv) = @_;
326  return ""
327    if (& GetCharacteristic($argv) eq "chMODP");
328  return "pDelete1(&$p)";
329}
330
331sub ORDERINIT
332{
333  local($p1, $p2, $argv) = @_;
334  return "int _new_order = pGetOrder($p1) + pGetOrder($p2)"
335    if (& GetHomog($argv) eq "homYES");
336  return "";
337}
338
339sub ORDERADD
340{
341  local($p1, $p2, $p3, $argv) = @_;
342  return "$p1->Order = _new_order" 
343    if (& GetHomog($argv) eq "homYES");
344  return "$p1->Order = $p2->Order + $p3->Order"
345}
346
347sub EXPADD
348{
349  local($p1, $p2, $p3, $argv) = @_;
350  local($nw) = & GetNumWords($argv);
351 
352  return "memadd_".$nw."((unsigned long*) &($p1->exp[0]),(const unsigned long*) &($p2->exp[0]),(const unsigned long*) &($p3->exp[0]))" 
353    if ($nw eq "nwONE" || $nw eq "nwTWO");
354 
355  return "memadd_".$nw."((unsigned long*) &($p1->exp[0]),(const unsigned long*) &($p2->exp[0]),(const unsigned long*) &($p3->exp[0]), pVariables1W)" 
356    if ($nw eq "nwODD" || $nw eq "nwEVEN");
357 
358  return "memadd((unsigned long*) &($p1->exp[0]),(const unsigned long*) &($p2->exp[0]),(const unsigned long*) &($p3->exp[0]), pVariables1W)";
359}
360
361###########################################################################
362##
363## COMPARE "macro": Besides generating th source code which
364## accomplishes monomial comparisons, it also generates the (global)
365## string $rargv charcaterising the generated Proc
366##
367sub COMPARE
368{
369  local($p1, $p2, $d, $argv) = @_;
370  local($ot, $hom, $nw, $res);
371 
372  $rargv = &GetCharacteristic($argv);
373  $ot = &GetOrderingType($argv);
374  $rargv =  $rargv."_".$ot;
375  if ($ot eq "otCOMPEXP" ||
376      $ot eq "otEXPCOMP" ||
377      $ot eq "otEXP")
378  {
379    if ($ot eq "otCOMPEXP")
380    {
381      $res = "$d = pGetComp($p2) - pGetComp($p1);\n";
382      $res = $res."NonZeroTestA($d, pComponentOrder, goto NotEqual);\n";
383      $ot = "otEXP";
384    }
385    $hom = &GetHomog($argv);
386    $rargv =  $rargv."_".$hom;
387    if ($hom ne "homYES")
388    {
389      $res = $res."$d = pGetOrder($p1) - pGetOrder($p2);\n";
390      $res = $res."NonZeroTestA($d, pOrdSgn, goto NotEqual);\n";
391    }
392#     $rargv =  $rargv."_nwGEN";
393#     $res = join("_", $res, pMonComp, $ot, "nwGEN");
394#     $res = $res."($p1, $p2, pVariables1W, $d, NonZeroA($d, pLexSgn, goto NotEqual ), goto Equal);";
395     $nw = &GetNumWords($argv);
396     $rargv =  $rargv."_".$nw;
397     $res = join("_", $res, pMonComp, $ot, $nw);
398     if ($nw eq "nwONE" || $nw eq "nwTWO")
399     {
400       $res = $res."($p1, $p2, $d, NonZeroA($d, pLexSgn, goto NotEqual ), goto Equal);" 
401     }
402     else
403     {
404       $res = $res."($p1, $p2, pVariables1W, $d, NonZeroA($d, pLexSgn, goto NotEqual ), goto Equal);";
405     }
406    return $res;
407  }
408  else
409  {
410    if ($ot eq "otSYZDPC")
411    {
412      $res = "if (($d = pGetOrder($p1) - pGetOrder($p2))) goto NotEqual;\n";
413      $nw = &GetNumWords($argv);
414      $hom = &GetHomog($argv);
415      $rargv =  $rargv."_".$hom;
416      $rargv =  $rargv."_".$nw;
417      $res = join("_", $res, pMonComp, $ot, $nw);
418      if ($nw eq "nwONE" || $nw eq "nwTWO")
419      {
420        $res = $res."($p1, $p2, $d, goto NotEqual, goto Equal);";
421      }
422      else
423      {
424        $res = $res."($p1, $p2, pVariables1W, $d, goto NotEqual, goto Equal);";
425      }
426      return $res;
427    }
428    # general ordering type
429    return ("if (($d = pComp0($p1, $p2))) goto NotEqual; else goto Equal;");
430  }
431}
432
433
434###########################################################################
435##
436## Generates a Proc from a given "$argv" input string,
437## i.e. property string
438##
439## Returns spSpolyLoop and sets global associative array
440## $loops{$rargv} to generated loop.
441##
442
443sub Generate_CurrProc
444{
445  local($argv)= @_;
446  local($loopbody);
447
448  undef $rargv if (defined($rargv));
449 
450  $loopbody = &Expand($CurrProcTemplate, $argv);
451
452  $rargv = $argv if (! defined($rargv));
453   
454  & Warning("Can not realize $argv: Changed to $rargv") if ($argv ne $rargv);
455
456  if (grep(/$rargv/, keys(%loops)))
457  {
458    & Warning("Duplicate entry $rargv: Ignoring $argv");
459    return;
460  }
461  else
462  {
463    $loops{$rargv} = "static ".$CurrProcReturnType." ".$CurrProc."_$rargv\n$loopbody\n";
464    return ($loops{$rargv});
465  }
466}
467
468#gnerates Procs from array of $argv strings
469sub Generate_CurrProcs
470{
471  local(%loops);
472 
473  foreach $argv (@_)
474  {
475    & Generate_CurrProc($argv);
476  }
477  return (%loops);
478}
479
480###########################################################################
481##
482## Generates array of $argv strings from a given input string by
483## "orthoganization", i.e. komma-separated entries in input string are
484## replaced by two argv strings containing the respective entrie.
485##
486
487sub FlattenInputString
488{
489  local($str) = @_;
490 
491  if ($str =~ /_/)
492  {
493    local(@parts, $head, @subresults, @result);
494    @parts = split(/_/, $str);
495    $head = shift(@parts);
496    @subresults = &FlattenInputString(join("_", @parts));
497    foreach $part (split(/,/, $head))
498    {
499      foreach $subresult (@subresults)
500      {
501        @result = (@result, $part."_".$subresult);
502      }
503    }
504    return (@result);
505  }
506  return (split(/,/, $str));
507}
508
509# generate array of $argv strings from array of input strings
510sub FlattenInput
511{
512  local(@result);
513  foreach $entry (@_)
514  {
515    $entry =~ s/\s//;
516    @result = (@result, & FlattenInputString($entry));
517  }
518  return @result;
519}
520
521
522###########################################################################
523##
524## GetProc routines
525## They all work on valid $argv strings, only.
526##
527
528## Given a $prefix and an array of $argv's, return all the "next"
529## values, i.e. strings deliminted by $prefix and next '_'.
530sub GetNextKeys
531{
532  local($prefix, @values, $value);
533 
534  $prefix = shift(@_);
535  $prefix = $prefix."_" unless ($prefix eq "");
536  foreach $element (@_)
537  {
538    if ($prefix eq "")
539    {
540      ($value = $element) =~ s/^([a-zA-Z]*)(\w*)/\1/;
541      @values = ($value, @values) unless grep(/^$value$/, @values);
542    }
543    elsif ($element =~ /^$prefix/)
544    {
545      ($value = $element) =~ s/^($prefix)([a-zA-Z]*)(\w*)/\2/;
546      @values = ($value, @values) unless grep(/^$value$/, @values);
547    }
548  }
549  return @values;
550}
551
552# recursively generates "Get$CurrProc" by working through all $argv's
553# which math $prefix
554# Sets $checks{$prefix}, if $prefix eq $argv
555sub GenerateBody_GetCurrProc
556{
557  local($prefix, $nextprefix, $source, $newsource, $prop, $curr_prop, $gen_key);
558 
559  $prefix = shift(@_);
560 
561  #check for exact match -- then we are done
562  if (grep(/^$prefix$/, @_))
563  {
564    $checks{$prefix} = "return ".$CurrProc."_$prefix;\n";
565    return ($checks{$prefix});
566  }
567 
568  foreach $key (& GetNextKeys($prefix, @_))
569  {
570    if ($key =~ /\w+/)
571    {
572      # get prop,
573      ($prop = $key) =~ s/([a-z]*)([A-Z]*)/\1/;
574      #check prop against exiting ones
575      if ($curr_prop)
576      {
577        if ($prop ne $curr_prop)
578        {
579          & Warning("Different props at same level: $prop : $curr_prop");
580          next;
581        }
582      }
583      else
584      {
585        $curr_prop = $prop;
586      }
587      # delay handling of "GEN" field
588      if ($key =~ /GEN/)
589      {
590        $gen_key = $key;
591        next;
592      }
593      # let's work recursively
594      if ($prefix eq "")
595      {
596        $nextprefix = $key;
597      }
598      else
599      {
600        $nextprefix = $prefix."_".$key;
601      }
602      $newsource=&GenerateBody_GetCurrProc($nextprefix,grep(/$nextprefix/,@_));
603      if ($newsource)
604      {
605        $source = $source."if ($prop == $key)\n{\n".$newsource."}\n";
606      }
607    }
608  }
609 
610  # take care of general key, if it exists
611  if ($gen_key)
612  {
613    $gen_key  = $prefix."_".$gen_key unless ($prefix eq "");
614    $source = $source . &GenerateBody_GetCurrProc($gen_key,grep(/$gen_key/,@_));
615  }
616  return ($source);
617}
618
619
620sub Generate_GetCurrProc
621{
622  local($header);
623 
624  $header = "static ".$CurrProc."_Proc Get".$CurrProc."(";
625 
626  foreach $key (@Properties)
627  {
628    $etype = $EnumType{$key};
629    if ($etype =~ /\w+/)
630    {
631      $header = $header."$etype $key,";
632    }
633  }
634  chop($header);
635 
636  return ($header. 
637          ")\n{\n" . 
638          &GenerateBody_GetCurrProc("", @_). 
639          "return NULL;\n}\n");
640}
641
642###########################################################################
643##
644## Input Specification
645##
646
647##
648## kb_n_Mult_p
649##
650
651$input{"kb_n_Mult_p"} = ("chMODP_otGEN_homGEN_nwGEN");
652
653$returnType{"kb_n_Mult_p"} = "void";
654
655$template{"kb_n_Mult_p"} = <<_EOT_
656(number n, poly p)
657{
658  while (p != NULL)
659  {
660    number nc = pGetCoeff(p);
661    pSetCoeff0(p, CALL_NMULT("n", "nc"));
662    CALL_NDELETE("&nc");
663    pIter(p);
664  }
665}
666_EOT_
667  ;
668
669##
670## kb_p_Add_q
671##
672
673$input{"kb_p_Add_q"}
674  = (
675 "chMODP".
676 "_otEXP,otCOMPEXP,otEXPCOMP".
677"_homGEN,homYES".
678"_nwONE,nwTWO,nwEVEN,nwODD".
679":".
680      "chMODP".
681      "_otSYZDPC".
682      "_homGEN".
683      "_nwONE,nwTWO,nwEVEN,nwODD"
684    );
685
686## Template of kb_p_Add_q
687$returnType{"kb_p_Add_q"} = "void";
688
689$template{"kb_p_Add_q"} = <<_EOT_
690(poly *p, int *lp,
691 poly *q, int *lq,
692 memHeap heap)
693{
694#ifdef KB_USE_HEAPS
695  assume(heap != NULL);
696#else
697  assume(heap == NULL);
698#endif
699  assume(pLength(*p) == *lp && pLength(*q) == *lq);
700 
701  number t, n1, n2;
702  unsigned int l = *lp + *lq;
703  spolyrec rp;
704  poly a = &rp, a1 = *p, a2 = *q;
705
706  if (a2 == NULL) return;
707
708  *q = NULL;
709  *lq = 0;
710 
711  if (a1 == NULL)
712  {
713    *p = a2;
714    *lp = l;
715    return;
716  }
717
718  Top:     // compare a1 and a2 w.r.t. monomial ordering
719  register long d;
720  CALL_COMPARE("a1", "a2", "d");
721 
722  Equal:
723  assume(pComp0(a1, a2) == 0);
724
725  n1 = pGetCoeff(a1);
726  n2 = pGetCoeff(a2);
727  t = CALL_NADD("n1", "n2");
728  CALL_NDELETE("&n1");
729  CALL_NDELETE("&n2");
730  kb_pFree1AndAdvance(a2, heap);
731 
732  if (CALL_NISZERO("t"))
733  {
734    l -= 2;
735    CALL_NDELETE("&t");
736    kb_pFree1AndAdvance(a1, heap);
737  }
738  else
739  {
740    l--;
741    pSetCoeff0(a1,t);
742    a = pNext(a) = a1;
743    pIter(a1);
744  }
745  if (a1==NULL)
746  {
747    pNext(a) = a2;
748    goto Finish;
749  }
750  else if (a2==NULL)
751  {
752    pNext(a) = a1;
753    goto Finish;
754  }
755  goto Top;
756     
757  NotEqual:
758  if (d < 0)
759  {
760    assume(pComp0(a1, a2) == -1);
761    a = pNext(a) = a2;
762    pIter(a2);
763    if (a2==NULL)
764    {
765      pNext(a) = a1;
766      goto Finish;
767    }
768  }
769  else
770  {
771    assume(pComp0(a1, a2) == 1);
772    a = pNext(a) = a1;
773    pIter(a1);
774    if (a1==NULL)
775    {
776      pNext(a) = a2;
777      goto Finish;
778    }
779  }
780  goto Top;
781 
782
783  Finish: 
784  assume(pLength(pNext(&rp)) == (int) l);
785  *lp = l;
786  *p  = pNext(&rp);
787}
788
789_EOT_
790  ;
791
792##
793## Third, kb_p_Mult_m
794##
795
796$input{"kb_p_Mult_m"}
797  = ("chMODP".
798     "_homGEN,homYES".
799     "_nwONE,nwTWO,nwEVEN,nwODD"
800    );
801## Template of kb_p_Mult_m
802$returnType{"kb_p_Mult_m"} = "poly";
803
804$template{"kb_p_Mult_m"} = <<_EOT_
805(poly p,
806 poly m,
807 poly spNoether,
808 memHeap heap)
809{
810#ifdef KB_USE_HEAPS
811  assume(heap != NULL);
812#else
813  assume(heap == NULL);
814#endif
815  if (p == NULL) return NULL;
816  spolyrec rp;
817  poly q = &rp;
818  number ln = pGetCoeff(m);
819  int comp = pGetComp(m);
820  CALL_ORDERINIT("p", "m");
821 
822
823  pSetComp(m, 0);
824
825  while (p != NULL)
826  {
827    kb_pNew(pNext(q), heap);
828    q = pNext(q);
829
830    pSetCoeff0(q, CALL_NMULT("ln", "pGetCoeff(p)"));
831
832    CALL_ORDERADD("q", "p", "m");
833
834    CALL_EXPADD("q", "p", "m");
835   
836    p = pNext(p);
837  }
838  pNext(q) = NULL;
839  pSetComp(m, comp);
840  return pNext(&rp);
841}
842_EOT_
843  ;
844
845##
846## Fourth, kb_p_Minus_m_Mult_q
847##
848$input{"kb_p_Minus_m_Mult_q"}
849  = ("chMODP".
850     "_otEXP,otCOMPEXP,otEXPCOMP".
851     "_homGEN,homYES".
852     "_nwONE,nwTWO,nwEVEN,nwODD".
853":".
854      "chMODP".
855      "_otSYZDPC".
856      "_homGEN".
857      "_nwONE,nwTWO,nwEVEN,nwODD"
858    );
859
860## Template of kb_p_Minus_m_Mult_q
861$returnType{"kb_p_Minus_m_Mult_q"} = "void";
862$template{"kb_p_Minus_m_Mult_q"} = <<_EOT_
863(poly *pp, int *lpp,
864 poly m,
865 poly q, int lq,
866 poly spNoether,
867 kb_p_Mult_m_Proc kb_p_Mult_m,
868 memHeap heap)
869{
870#ifdef KB_USE_HEAPS
871  assume(heap != NULL);
872#else
873  assume(heap == NULL);
874#endif
875  assume(pLength(q) == lq);
876  assume(pLength(*pp) == *lpp);
877
878  // we are done if q == NULL
879  if (q == NULL || m == NULL) return;
880 
881  poly a = m,                         // collects the result
882       qm = NULL,                     // stores q*m
883       c,                             // used for temporary storage
884       p = *pp;
885
886  number tm   = pGetCoeff(m),       // coefficient of m
887         tneg = CALL_NCOPYNEG("tm"),    // - (coefficient of m)
888         tb,                        // used for tm*coeff(a1)
889         tc;                        // used as intermediate number
890
891  unsigned int lp = *lpp + lq;
892
893  int comp = pGetComp(m);
894  CALL_ORDERINIT("q", "m");
895
896  pSetComp(m, 0);
897 
898  if (p == NULL) goto Finish; // we are done if p is 0
899
900  kb_pNew(qm, heap);
901
902  CALL_ORDERADD("qm", "q", "m");
903  CALL_EXPADD("qm", "q", "m");
904 
905  // MAIN LOOP:
906  Top:     // compare qm = m*q and p w.r.t. monomial ordering
907    register long d;
908    CALL_COMPARE("qm", "p", "d");
909
910  Equal:   // qm equals p
911    tb = CALL_NMULT("pGetCoeff(q)", "tm");
912    tc = pGetCoeff(p);
913    if (!CALL_NEQUAL("tc", "tb"))
914    {
915      lp--;
916      tc = CALL_NSUB("tc", "tb");
917      CALL_NDELETE("&pGetCoeff(p)");
918      pSetCoeff0(p,tc); // adjust coeff of p
919      a = pNext(a) = p; // append p to result and advance p
920      pIter(p);
921    }
922    else
923    { // coeffs are equal, so their difference is 0:
924      lp -= 2;
925      CALL_NDELETE("&tc");
926      kb_pFree1AndAdvance(p, heap);
927    }
928    CALL_NDELETE("&tb");
929    pIter(q);
930    if (q == NULL || p == NULL) goto Finish; // are we done ?
931    // no, so update qm
932    CALL_ORDERADD("qm", "q", "m");
933    CALL_EXPADD("qm", "q", "m");
934    goto Top;
935
936  NotEqual:     // qm != p
937    if (d < 0)  // qm < p:
938    {
939      a = pNext(a) = p;// append p to result and advance p
940      pIter(p);
941      if (p == NULL) goto Finish;;
942      goto Top;
943    }
944    else // now d >= 0, i.e., qm > p
945    {
946      pSetCoeff0(qm,CALL_NMULT("pGetCoeff(q)", "tneg"));
947      a = pNext(a) = qm;       // append qm to result and advance q
948      pIter(q);
949      if (q == NULL) // are we done?
950      {
951        qm = NULL;
952        goto Finish;
953      }
954      // construct new qm
955      kb_pNew(qm, heap);
956      CALL_ORDERADD("qm", "q", "m");
957      CALL_EXPADD("qm", "q", "m");
958      goto Top;
959    }
960 
961 Finish: // q or p is NULL: Clean-up time
962   pSetComp(m, comp);
963   if (q == NULL) // append rest of p to result
964     pNext(a) = p;
965   else  // append (- q*m) to result
966   {
967     pSetCoeff0(m, tneg);
968     pNext(a) = kb_p_Mult_m(q, m, spNoether, heap);
969     pSetCoeff0(m, tm);
970   }
971   
972   CALL_NDELETE("&tneg");
973   if (qm != NULL) kb_pFree1(qm, heap);
974
975   *pp = pNext(m);
976   *lpp = lp;
977   pNext(m) = NULL;
978   
979   assume(pLength(*pp) == *lpp);
980}
981
982_EOT_
983  ;
984
985
986
987###########################################################################
988##
989## Main program
990##
991
992print & Generate_EnumTypes(@Properties);
993
994foreach $CurrProc (@ARGV)
995{
996  if ($template{$CurrProc} && $input{$CurrProc})
997  {
998   
999    $CurrProcTemplate = $template{$CurrProc};
1000    $CurrProcReturnType = $returnType{$CurrProc};
1001   
1002    #flatten out input
1003    @finput = &FlattenInput(split(/:/, $input{$CurrProc}));
1004   
1005    #generate loops
1006    %loops = & Generate_CurrProcs(@finput);
1007   
1008    # Generate GetSpolyLoop based on generated loops
1009    $getspolyloop = & Generate_GetCurrProc(sort(keys(%loops)));
1010   
1011    # Output results
1012
1013    foreach $key (sort(keys(%loops)))
1014    {
1015      print $loops{$key};
1016    }
1017   
1018    print $getspolyloop;
1019  }
1020  else
1021  {
1022    print (STDERR "No template for $CurrProc\n") if (! $template{$CurrProc});
1023    print (STDERR "No input for $CurrProc\n") if (! $input{$CurrProc});
1024  }
1025}
1026
1027
1028
Note: See TracBrowser for help on using the repository browser.