home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / intdiv.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  25.2 KB  |  647 lines
  1. # Division ganzer Zahlen
  2.  
  3. # Dividiert zwei Unsigned Digit sequences durcheinander.
  4. # UDS_divide(a_MSDptr,a_len,a_LSDptr, b_MSDptr,b_len,b_LSDptr, &q,&r);
  5. # Die UDS a = a_MSDptr/a_len/a_LSDptr (a>=0) wird durch
  6. # die UDS b = b_MSDptr/b_len/b_LSDptr (b>=0) dividiert:
  7. # a = q * b + r mit 0 <= r < b. Bei b=0 Error.
  8. # q der Quotient, r der Rest.
  9. # q = q_MSDptr/q_len/q_LSDptr, r = r_MSDptr/r_len/r_LSDptr beides
  10. # Normalized Unsigned Digit sequences.
  11. # Vorsicht: q_LSDptr <= r_MSDptr,
  12. #           Vorzeichenerweiterung von r kann q zerstören!
  13. #           Vorzeichenerweiterung von q ist erlaubt.
  14. # a und b werden nicht modifiziert.
  15. # num_stack wird erniedrigt.
  16.   #define UDS_divide(a_MSDptr,a_len,a_LSDptr,b_MSDptr,b_len,b_LSDptr,q_,r_)  \
  17.     { # Platz fürs Ergebnis machen. Brauche maximal a_len+1 Digits.                \
  18.       var reg2 uintC _a_len = (a_len);                                             \
  19.       var reg1 uintD* roomptr; num_stack_need_1(_a_len+1,roomptr=,_EMA_);               \
  20.       UDS_divide_(a_MSDptr,_a_len,a_LSDptr,b_MSDptr,b_len,b_LSDptr,roomptr,q_,r_); \
  21.     }
  22.   local void UDS_divide_ (uintD* a_MSDptr, uintC a_len, uintD* a_LSDptr,
  23.                           uintD* b_MSDptr, uintC b_len, uintD* b_LSDptr,
  24.                           uintD* roomptr, DS* q_, DS* r_);
  25. # Methode:
  26. # erst a und b normalisieren: a=[a[m-1],...,a[0]], b=[b[n-1],...,b[0]]
  27. # mit m>=0 und n>0 (Stellensystem der Basis beta=2^intDsize).
  28. # Falls m<n, ist q:=0 und r:=a.
  29. # Falls m>=n=1, Single-Precision-Division:
  30. #   r:=0, j:=m,
  31. #   while j>0 do
  32. #     {Hier (q[m-1]*beta^(m-1)+...+q[j]*beta^j) * b[0] + r*beta^j =
  33. #           = a[m-1]*beta^(m-1)+...+a[j]*beta^j und 0<=r<b[0]<beta}
  34. #     j:=j-1, r:=r*beta+a[j], q[j]:=floor(r/b[0]), r:=r-b[0]*q[j].
  35. #   Normalisiere [q[m-1],...,q[0]], liefert q.
  36. # Falls m>=n>1, Multiple-Precision-Division:
  37. #   Es gilt a/b < beta^(m-n+1).
  38. #   s:=intDsize-1-(Nummer des höchsten Bits in b[n-1]), 0<=s<intDsize.
  39. #   Schiebe a und b um s Bits nach links und kopiere sie dabei. r:=a.
  40. #   r=[r[m],...,r[0]], b=[b[n-1],...,b[0]] mit b[n-1]>=beta/2.
  41. #   Für j=m-n,...,0: {Hier 0 <= r < b*beta^(j+1).}
  42. #     Berechne q* :
  43. #       q* := floor((r[j+n]*beta+r[j+n-1])/b[n-1]).
  44. #       Bei Überlauf (q* >= beta) setze q* := beta-1.
  45. #       Berechne c2 := ((r[j+n]*beta+r[j+n-1]) - q* * b[n-1])*beta + r[j+n-2]
  46. #       und c3 := b[n-2] * q*.
  47. #       {Es ist 0 <= c2 < 2*beta^2, sogar 0 <= c2 < beta^2 falls kein
  48. #        Überlauf aufgetreten war. Ferner 0 <= c3 < beta^2.
  49. #        Bei Überlauf und r[j+n]*beta+r[j+n-1] - q* * b[n-1] >= beta,
  50. #        das heißt c2 >= beta^2, kann man die nächste Abfrage überspringen.}
  51. #       Solange c3 > c2, {hier 0 <= c2 < c3 < beta^2} setze
  52. #         q* := q* - 1, c2 := c2 + b[n-1]*beta, c3 := c3 - b[n-2].
  53. #       Falls q* > 0:
  54. #         Setze r := r - b * q* * beta^j, im einzelnen:
  55. #           [r[n+j],...,r[j]] := [r[n+j],...,r[j]] - q* * [b[n-1],...,b[0]].
  56. #           also: u:=0, for i:=0 to n-1 do
  57. #                         u := u + q* * b[i],
  58. #                         r[j+i]:=r[j+i]-(u mod beta) (+ beta, falls Carry),
  59. #                         u:=u div beta (+ 1, falls bei der Subtraktion Carry)
  60. #                 r[n+j]:=r[n+j]-u.
  61. #           {Da stets u = (q* * [b[i-1],...,b[0]] div beta^i) + 1
  62. #                       < q* + 1 <= beta, läuft der Übertrag u nicht über.}
  63. #         Tritt dabei ein negativer Übertrag auf, so setze q* := q* - 1
  64. #           und [r[n+j],...,r[j]] := [r[n+j],...,r[j]] + [0,b[n-1],...,b[0]].
  65. #     Setze q[j] := q*.
  66. #   Normalisiere [q[m-n],..,q[0]] und erhalte den Quotienten q,
  67. #   Schiebe [r[n-1],...,r[0]] um s Bits nach rechts, normalisiere und
  68. #   erhalte den Rest r.
  69. #   Dabei kann q[j] auf dem Platz von r[n+j] liegen.
  70.   local void UDS_divide_(a_MSDptr,a_len,a_LSDptr, b_MSDptr,b_len,b_LSDptr,roomptr,q_,r_)
  71.     var reg1 uintD* a_MSDptr;
  72.     var reg3 uintC a_len;
  73.     var reg5 uintD* a_LSDptr;
  74.     var reg2 uintD* b_MSDptr;
  75.     var reg4 uintC b_len;
  76.     var reg6 uintD* b_LSDptr;
  77.     var reg10 uintD* roomptr; # ab roomptr kommen a_len+1 freie Digits
  78.     var reg10 DS* q_;
  79.     var reg10 DS* r_;
  80.     { # a normalisieren (a_MSDptr erhöhen, a_len erniedrigen):
  81.       while ((a_len>0) && (a_MSDptr[0]==0)) { a_MSDptr++; a_len--; }
  82.       # b normalisieren (b_MSDptr erhöhen, b_len erniedrigen):
  83.       loop
  84.         { if (b_len==0) { divide_0(); }
  85.           if (b_MSDptr[0]==0) { b_MSDptr++; b_len--; }
  86.           else break;
  87.         }
  88.       # jetzt m=a_len >=0 und n=b_len >0.
  89.       if (a_len < b_len)
  90.         # m<n: Trivialfall, q=0, r:= Kopie von a.
  91.         { var reg9 uintD* r_MSDptr = roomptr;
  92.           var reg9 uintD* r_LSDptr = &roomptr[a_len];
  93.           # Speicheraufbau: r_MSDptr/0/r_MSDptr/a_len/r_LSDptr
  94.           #                    |     q    |       r      |
  95.           copy_loop_down(a_LSDptr,r_LSDptr,a_len);
  96.           q_->MSDptr = r_MSDptr; q_->len = 0; q_->LSDptr = r_MSDptr; # q = 0, eine NUDS
  97.           r_->MSDptr = r_MSDptr; r_->len = a_len; r_->LSDptr = r_LSDptr; # r = Kopie von a, eine NUDS
  98.           return;
  99.         }
  100.       elif (b_len==1)
  101.         # n=1: Single-Precision-Division
  102.         { # beta^(m-1) <= a < beta^m  ==>  beta^(m-2) <= a/b < beta^m
  103.           var reg4 uintD* q_MSDptr = roomptr;
  104.           var reg6 uintD* q_LSDptr = &roomptr[a_len];
  105.           var reg3 uintD* r_MSDptr = q_LSDptr;
  106.           var reg5 uintD* r_LSDptr = &r_MSDptr[1];
  107.           # Speicheraufbau: q_MSDptr/a_len/q_LSDptr    r_MSDptr/1/r_LSDptr
  108.           #                     |      q      |           |     r    |
  109.          {var reg1 uintD rest = divucopy_loop_up(b_MSDptr[0],a_MSDptr,q_MSDptr,a_len); # Division durch b[0]
  110.           var reg2 uintC r_len;
  111.           if (!(rest==0))
  112.             { r_MSDptr[0] = rest; r_len=1; } # Rest als r ablegen
  113.             else
  114.             { r_MSDptr = r_LSDptr; r_len=0; } # Rest auf 0 normalisieren
  115.           if (q_MSDptr[0]==0)
  116.             { q_MSDptr++; a_len--; } # q normalisieren
  117.           q_->MSDptr = q_MSDptr; q_->len = a_len; q_->LSDptr = q_LSDptr; # q ablegen
  118.           r_->MSDptr = r_MSDptr; r_->len = r_len; r_->LSDptr = r_LSDptr; # r ablegen
  119.           return;
  120.         }}
  121.       else
  122.         # n>1: Multiple-Precision-Division
  123.         { # beta^(m-1) <= a < beta^m, beta^(n-1) <= b < beta^n  ==>
  124.           # beta^(m-n-1) <= a/b < beta^(m-n+1).
  125.           var reg9 uintL s;
  126.           # s bestimmen:
  127.           { var reg1 uintD msd = b_MSDptr[0]; # b[n-1]
  128.             #if 0
  129.             s = 0;
  130.             while ((sintD)msd >= 0) { msd = msd<<1; s++; }
  131.             #else # ein wenig effizienter, Abfrage auf s=0 vorwegnehmen
  132.             if ((sintD)msd < 0)
  133.               { s = 0; goto shift_ok; }
  134.               else
  135.               { integerlengthD(msd, s = intDsize - ); goto shift; }
  136.             #endif
  137.           }
  138.           # 0 <= s < intDsize.
  139.           # Kopiere b und schiebe es dabei um s Bits nach links:
  140.           if (!(s==0))
  141.             shift:
  142.             { SAVE_NUM_STACK # num_stack retten
  143.               var reg1 uintD* old_b_LSDptr = b_LSDptr;
  144.               num_stack_need(b_len,b_MSDptr=,b_LSDptr=);
  145.               shiftleftcopy_loop_down(old_b_LSDptr,b_LSDptr,b_len,s);
  146.               RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  147.             }
  148.           shift_ok:
  149.           # Wieder b = b_MSDptr/b_len/b_LSDptr.
  150.           # Kopiere a und schiebe es dabei um s Bits nach links, erhalte r:
  151.          {var reg1 uintD* r_MSDptr = roomptr;
  152.           var reg9 uintD* r_LSDptr = &roomptr[a_len+1];
  153.           # Speicheraufbau:  r_MSDptr/          a_len+1           /r_LSDptr
  154.           #                     |                  r                  |
  155.           # später:          q_MSDptr/a_len-b_len+1/r_MSDptr/b_len/r_LSDptr
  156.           #                     |           q          |       r      |
  157.           if (s==0)
  158.             { copy_loop_down(a_LSDptr,r_LSDptr,a_len); r_MSDptr[0] = 0; }
  159.             else
  160.             { r_MSDptr[0] = shiftleftcopy_loop_down(a_LSDptr,r_LSDptr,a_len,s); }
  161.           # Nun r = r_MSDptr/a_len+1/r_LSDptr.
  162.           {var reg7 uintC j = a_len-b_len; # m-n
  163.            var reg8 uintD* r_ptr = &r_LSDptr[-(uintP)j]; # Pointer oberhalb von r[j]
  164.            var reg9 uintD* q_MSDptr = r_MSDptr;
  165.            var reg9 uintC q_len = j = j+1; # q wird m-n+1 Digits haben
  166.            var reg5 uintD b_msd = b_MSDptr[0]; # b[n-1]
  167.            var reg6 uintD b_2msd = b_MSDptr[1]; # b[n-2]
  168.            #if HAVE_DD
  169.            var reg6 uintDD b_msdd = highlowDD(b_msd,b_2msd); # b[n-1]*beta+b[n-2]
  170.            #endif
  171.            # Divisions-Schleife: (wird m-n+1 mal durchlaufen)
  172.            # j = Herabzähler, b_MSDptr/b_len/b_LSDptr = [b[n-1],...,b[0]], b_len=n,
  173.            # r_MSDptr = Pointer auf r[n+j] = Pointer auf q[j],
  174.            # r_ptr = Pointer oberhalb von r[j].
  175.            do { var reg2 uintD q_stern;
  176.                 var reg3 uintD c1;
  177.                 if (r_MSDptr[0] < b_msd) # r[j+n] < b[n-1] ?
  178.                   { # Dividiere r[j+n]*beta+r[j+n-1] durch b[n-1], ohne Überlauf:
  179.                     #if HAVE_DD
  180.                       divuD(highlowDD(r_MSDptr[0],r_MSDptr[1]),b_msd, q_stern=,c1=);
  181.                     #else
  182.                       divuD(r_MSDptr[0],r_MSDptr[1],b_msd, q_stern=,c1=);
  183.                     #endif
  184.                   }
  185.                   else
  186.                   { # Überlauf, also r[j+n]*beta+r[j+n-1] >= beta*b[n-1]
  187.                     q_stern = bitm(intDsize)-1; # q* = beta-1
  188.                     # Teste ob r[j+n]*beta+r[j+n-1] - (beta-1)*b[n-1] >= beta
  189.                     # <==> r[j+n]*beta+r[j+n-1] + b[n-1] >= beta*b[n-1]+beta
  190.                     # <==> b[n-1] < floor((r[j+n]*beta+r[j+n-1]+b[n-1])/beta) {<= beta !} ist.
  191.                     # Wenn ja, direkt zur Subtraktionschleife.
  192.                     # (Andernfalls ist r[j+n]*beta+r[j+n-1] - (beta-1)*b[n-1] < beta
  193.                     #  <==> floor((r[j+n]*beta+r[j+n-1]+b[n-1])/beta) = b[n-1] ).
  194.                     if ((r_MSDptr[0] > b_msd) || ((c1 = r_MSDptr[1]+b_msd) < b_msd))
  195.                       # r[j+n] >= b[n-1]+1 oder
  196.                       # r[j+n] = b[n-1] und Addition r[j+n-1]+b[n-1] gibt Carry ?
  197.                       { goto subtract; } # ja -> direkt in die Subtraktion
  198.                   }
  199.                 # q_stern = q*,
  200.                 # c1 = (r[j+n]*beta+r[j+n-1]) - q* * b[n-1] (>=0, <beta).
  201.                 #if HAVE_DD
  202.                   { var reg3 uintDD c2 = highlowDD(c1,r_MSDptr[2]); # c1*beta+r[j+n-2]
  203.                     var reg4 uintDD c3 = muluD(b_2msd,q_stern); # b[n-2] * q*
  204.                     # Solange c2 < c3, c2 erhöhen, c3 erniedrigen:
  205.                     # Rechne dabei mit c3-c2:
  206.                     # solange >0, um b[n-1]*beta+b[n-2] erniedrigen.
  207.                     # Dies kann wegen b[n-1]*beta+b[n-2] >= beta^2/2
  208.                     # höchstens zwei mal auftreten.
  209.                     if (c3 > c2)
  210.                       { q_stern = q_stern-1; # q* := q* - 1
  211.                         if (c3-c2 > b_msdd)
  212.                           { q_stern = q_stern-1; } # q* := q* - 1
  213.                   }   }
  214.                 #else
  215.                   # Wie oben, nur mit zweigeteilten c2=[c2hi|c2lo] und c3=[c3hi|c3lo]:
  216.                   #define c2hi c1
  217.                   { var reg3 uintD c2lo = r_MSDptr[2]; # c2hi*beta+c2lo = c1*beta+r[j+n-2]
  218.                     var reg4 uintD c3hi;
  219.                     var reg4 uintD c3lo;
  220.                     muluD(b_2msd,q_stern, c3hi=,c3lo=); # c3hi*beta+c3lo = b[n-2] * q*
  221.                     if ((c3hi > c2hi) || ((c3hi == c2hi) && (c3lo > c2lo)))
  222.                       { q_stern = q_stern-1; # q* := q* - 1
  223.                         c3hi -= c2hi; if (c3lo < c2lo) { c3hi--; }; c3lo -= c2lo; # c3 := c3-c2
  224.                         if ((c3hi > b_msd) || ((c3hi == b_msd) && (c3lo > b_2msd)))
  225.                           { q_stern = q_stern-1; } # q* := q* - 1
  226.                   }   }
  227.                   #undef c2hi
  228.                 #endif
  229.                 if (!(q_stern==0))
  230.                   subtract:
  231.                   { # Subtraktionsschleife: r := r - b * q* * beta^j
  232.                     var reg3 uintD carry = mulusub_loop_down(q_stern,b_LSDptr,r_ptr,b_len);
  233.                     # Noch r_ptr[-b_len-1] -= carry, d.h. r_MSDptr[0] -= carry
  234.                     # durchführen und danach r_MSDptr[0] vergessen:
  235.                     if (carry > r_MSDptr[0])
  236.                       # Subtraktion ergab Übertrag
  237.                       { q_stern = q_stern-1; # q* := q* - 1
  238.                         addto_loop_down(b_LSDptr,r_ptr,b_len); # Additionsschleife
  239.                         # r[n+j] samt Carry kann vergessen werden...
  240.                   }   }
  241.                 # Berechnung von q* ist fertig.
  242.                 *r_MSDptr++ = q_stern; # als q[j] ablegen
  243.                 r_ptr++;
  244.               }
  245.               until (--j == 0);
  246.            # Nun ist q = [q[m-n],..,q[0]] = q_MSDptr/q_len/r_MSDptr
  247.            # und r = [r[n-1],...,r[0]] = r_MSDptr/b_len/r_LSDptr.
  248.            # q normalisieren und ablegen:
  249.            if (q_MSDptr[0]==0)
  250.              { q_MSDptr++; q_len--; }
  251.            q_->MSDptr = q_MSDptr; q_->len = q_len; q_->LSDptr = r_MSDptr;
  252.            # Schiebe [r[n-1],...,r[0]] um s Bits nach rechts:
  253.            if (!(s==0))
  254.              { shiftright_loop_up(r_MSDptr,b_len,s); }
  255.            # r normalisieren und ablegen:
  256.            while ((b_len>0) && (r_MSDptr[0]==0)) { r_MSDptr++; b_len--; }
  257.            r_->MSDptr = r_MSDptr; r_->len = b_len; r_->LSDptr = r_LSDptr;
  258.            return;
  259.         }}}
  260.     }
  261.  
  262. # Dividiert zwei Integers x,y >=0 und liefert Quotient und Rest
  263. # der Division x/y. Bei y=0 Error.
  264. # I_I_divide_I_I(x,y);
  265. # > x,y: Integers >=0
  266. # < STACK_1: Quotient q
  267. # < STACK_0: Rest r
  268. # Erniedrigt STACK um 2
  269. # kann GC auslösen
  270.   local void I_I_divide_I_I (object x, object y);
  271.   local void I_I_divide_I_I(x,y)
  272.     var reg1 object x;
  273.     var reg2 object y;
  274.     { if (I_fixnump(x))
  275.         # x Fixnum >=0
  276.         { if (I_fixnump(y))
  277.             # auch y Fixnum >=0
  278.             { var reg4 uint32 x_ = posfixnum_to_L(x);
  279.               var reg3 uint32 y_ = posfixnum_to_L(y);
  280.               if (y_==0) { divide_0(); }
  281.               elif (x_ < y_)
  282.                 # Trivialfall: q=0, r=x
  283.                 goto trivial;
  284.               elif (y_ < bit(16))
  285.                 # 32-durch-16-Bit-Division
  286.                 { var reg6 uint32 q;
  287.                   var reg5 uint16 r;
  288.                   divu_3216_3216(x_,y_,q=,r=);
  289.                   pushSTACK(UL_to_I(q));
  290.                   pushSTACK(fixnum((uintL)r));
  291.                 }
  292.               else
  293.                 # volle 32-durch-32-Bit-Division
  294.                 { var reg6 uint32 q;
  295.                   var reg5 uint32 r;
  296.                   divu_3232_3232(x_,y_,q=,r=);
  297.                   pushSTACK(UL_to_I(q));
  298.                   pushSTACK(UL_to_I(r));
  299.                 }
  300.             }
  301.             else
  302.             # y Bignum >0
  303.             { trivial:
  304.               # Trivialfall: q=0, r=x
  305.               pushSTACK(Fixnum_0);
  306.               pushSTACK(x);
  307.             }
  308.         }
  309.         else
  310.         # x Bignum -> allgemeine Division:
  311.         { SAVE_NUM_STACK # num_stack retten
  312.           var reg4 uintD* x_MSDptr;
  313.           var reg4 uintC x_len;
  314.           var reg4 uintD* x_LSDptr;
  315.           var reg4 uintD* y_MSDptr;
  316.           var reg4 uintC y_len;
  317.           var reg4 uintD* y_LSDptr;
  318.           # x in NDS umwandeln, als UDS auffassen:
  319.           BN_to_NDS_nocopy(x, x_MSDptr=,x_len=,x_LSDptr=);
  320.           # y in NDS umwandeln, als UDS auffassen:
  321.           I_to_NDS_nocopy(y, y_MSDptr=,y_len=,y_LSDptr=);
  322.           # dividieren:
  323.          {var DS q;
  324.           var DS r;
  325.           UDS_divide(x_MSDptr,x_len,x_LSDptr,y_MSDptr,y_len,y_LSDptr, &q,&r);
  326.           RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  327.           # q in Integer umwandeln:
  328.           pushSTACK(NUDS_to_I(q.MSDptr,q.len));
  329.           # r in Integer umwandeln (jetzt erst, nachdem q verwertet ist!):
  330.           pushSTACK(NUDS_to_I(r.MSDptr,r.len));
  331.         }}
  332.     }
  333.  
  334. # Fehler, wenn Quotient keine ganze Zahl ist
  335. # > STACK_1: Zähler x
  336. # > STACK_0: Nenner y
  337.   nonreturning_function(local, fehler_exquo, (void));
  338.   local void fehler_exquo()
  339.     { 
  340.       //: DEUTSCH "Quotient ~ / ~ ist keine ganze Zahl."
  341.       //: ENGLISH "quotient ~ / ~ is not an integer"
  342.       //: FRANCAIS "Le quotient de ~ par ~ n'est pas un entier."
  343.       fehler(error, GETTEXT("quotient ~ / ~ is not an integer"));
  344.     }
  345.  
  346. # Dividiert zwei Integers x,y >=0 und liefert den Quotienten x/y >=0.
  347. # Bei y=0 Error. Die Division muß aufgehen, sonst Error.
  348. # I_I_exquopos_I(x,y)
  349. # > x,y: Integers >=0
  350. # < ergebnis: Quotient x/y, ein Integer >=0
  351. # kann GC auslösen
  352.   local object I_I_exquopos_I (object x, object y);
  353. # Methode:
  354. # (exquopos x y) :==
  355. # (DIVIDE x y) -> q,r
  356. # Falls r<>0, Error.
  357. # Liefere q.
  358.   local object I_I_exquopos_I(x,y)
  359.     var reg1 object x;
  360.     var reg2 object y;
  361.     { pushSTACK(y);
  362.       pushSTACK(x);
  363.       # Stackaufbau: y, x.
  364.       I_I_divide_I_I(x,y); # q,r auf den Stack
  365.       # Stackaufbau: y, x, q, r.
  366.       if (!eq(STACK_0,Fixnum_0))
  367.         { skipSTACK(2); fehler_exquo(); }
  368.      {var reg3 object q = STACK_1;
  369.       skipSTACK(4); return q;
  370.     }}
  371.  
  372. # Dividiert zwei Integers x,y und liefert den Quotienten x/y.
  373. # Bei y=0 Error. Die Division muß aufgehen, sonst Error.
  374. # I_I_exquo_I(x,y)
  375. # > x,y: Integers
  376. # < ergebnis: Quotient x/y, ein Integer
  377. # kann GC auslösen
  378.   local object I_I_exquo_I (object x, object y);
  379. # Methode:
  380. # (exquo x y) :==
  381. # (DIVIDE (abs x) (abs y)) -> q,r
  382. # Falls r<>0, Error.
  383. # Falls x,y verschiedene Vorzeichen haben, liefere -q, sonst q.
  384.   local object I_I_exquo_I(x,y)
  385.     var reg1 object x;
  386.     var reg2 object y;
  387.     { pushSTACK(y);
  388.       pushSTACK(x);
  389.       pushSTACK(I_abs_I(y));
  390.       # Stackaufbau: y, x, (abs y).
  391.       x = I_abs_I(STACK_1); # (abs x)
  392.       I_I_divide_I_I(x,STACK_0); # q,r auf den Stack
  393.       # Stackaufbau: y, x, (abs y), q, r.
  394.       if (!eq(STACK_0,Fixnum_0))
  395.         { skipSTACK(3); fehler_exquo(); }
  396.      {var reg3 object q = STACK_1;
  397.       if (!same_sign_p(STACK_3,STACK_4))
  398.         # x,y haben verschiedene Vorzeichen
  399.         { skipSTACK(5); return I_minus_I(q); }
  400.         else
  401.         # x,y haben gleiche Vorzeichen
  402.         { skipSTACK(5); return q; }
  403.     }}
  404.  
  405. # I_I_mod_I(x,y) = (mod x y), wo x,y Integers sind.
  406. # kann GC auslösen
  407.   local object I_I_mod_I (object x, object y);
  408. # Methode:
  409. # (mod x y) :==
  410. # (DIVIDE (abs x) (abs y)) -> q,r
  411. # Falls r=0, liefere 0.
  412. # Falls x,y verschiedene Vorzeichen haben, setze r:=r-abs(y).
  413. # Falls x<0, setze r:=-r.
  414. # Liefere r.
  415.   local object I_I_mod_I(x,y)
  416.     var reg2 object x;
  417.     var reg3 object y;
  418.     { pushSTACK(y);
  419.       pushSTACK(x);
  420.       pushSTACK(I_abs_I(y));
  421.       # Stackaufbau: y, x, (abs y).
  422.       x = I_abs_I(STACK_1); # (abs x)
  423.       I_I_divide_I_I(x,STACK_0); # q,r auf den Stack
  424.       # Stackaufbau: y, x, (abs y), q, r.
  425.      {var reg1 object r = STACK_0;
  426.       if (!eq(r,Fixnum_0))
  427.         { if (!same_sign_p(STACK_3,STACK_4))
  428.             # x,y haben verschiedene Vorzeichen
  429.             { r = I_I_minus_I(r,STACK_2); } # r := (- r (abs y))
  430.           if (R_mminusp(STACK_3))
  431.             { r = I_minus_I(r); } # x<0 -> r := (- r)
  432.         }
  433.       skipSTACK(5); return r;
  434.     }}
  435.  
  436. # I_I_rem_I(x,y) = (rem x y), wo x,y Integers sind.
  437. # kann GC auslösen
  438.   local object I_I_rem_I (object x, object y);
  439. # Methode:
  440. # (rem x y) :==
  441. # (DIVIDE (abs x) (abs y)) -> q,r
  442. # Falls x<0, setze r:=-r.
  443. # Liefere r.
  444.   local object I_I_rem_I(x,y)
  445.     var reg2 object x;
  446.     var reg3 object y;
  447.     { pushSTACK(y);
  448.       pushSTACK(x);
  449.       pushSTACK(I_abs_I(y));
  450.       # Stackaufbau: y, x, (abs y).
  451.       x = I_abs_I(STACK_1); # (abs x)
  452.       I_I_divide_I_I(x,STACK_0); # q,r auf den Stack
  453.       # Stackaufbau: y, x, (abs y), q, r.
  454.      {var reg1 object r = STACK_0;
  455.       if (!eq(r,Fixnum_0))
  456.         { if (R_mminusp(STACK_3))
  457.             { r = I_minus_I(r); } # x<0 -> r := (- r)
  458.         }
  459.       skipSTACK(5); return r;
  460.     }}
  461.  
  462. # Dividiert zwei Integers x,y und liefert Quotient und Rest
  463. # (q,r) := (floor x y)
  464. # I_I_floor_I_I(x,y);
  465. # > x,y: Integers
  466. # < STACK_1: Quotient q
  467. # < STACK_0: Rest r
  468. # Erniedrigt STACK um 2
  469. # kann GC auslösen
  470.   local void I_I_floor_I_I (object x, object y);
  471. # Methode:
  472. # (floor x y) :==
  473. # (DIVIDE (abs x) (abs y)) -> q,r
  474. # Falls x,y verschiedene Vorzeichen haben und r<>0,
  475. #   setze q:=q+1 und r:=r-abs(y).
  476. # Falls x<0, setze r:=-r.
  477. # Falls x,y verschiedene Vorzeichen haben, setze q:=-q.
  478. # Liefere q,r.
  479.   local void I_I_floor_I_I(x,y)
  480.     var reg2 object x;
  481.     var reg3 object y;
  482.     { pushSTACK(y);
  483.       pushSTACK(x);
  484.       pushSTACK(I_abs_I(y));
  485.       # Stackaufbau: y, x, (abs y).
  486.       x = I_abs_I(STACK_1); # (abs x)
  487.       I_I_divide_I_I(x,STACK_0); # q,r auf den Stack
  488.       # Stackaufbau: y, x, (abs y), q, r.
  489.       if (!same_sign_p(STACK_3,STACK_4))
  490.         # x,y haben verschiedene Vorzeichen
  491.         if (!eq(STACK_0,Fixnum_0))
  492.           # r/=0, also r>0.
  493.           { STACK_1 = I_1_plus_I(STACK_1); # q := (1+ q)
  494.             STACK_0 = I_I_minus_I(STACK_0,STACK_2); # r := (- r (abs y))
  495.           }
  496.       if (R_mminusp(STACK_3))
  497.         # x<0
  498.         { STACK_0 = I_minus_I(STACK_0); # r := (- r)
  499.           if (!R_mminusp(STACK_4)) # y>=0 ?
  500.             goto negate_q; # q := (- q)
  501.         }
  502.         else
  503.         # x>=0
  504.         { if (R_mminusp(STACK_4)) # y<0 ?
  505.             negate_q: { STACK_1 = I_minus_I(STACK_1); } # q := (- q)
  506.         }
  507.       STACK_4 = STACK_1; STACK_3 = STACK_0; skipSTACK(3); # Stack aufräumen
  508.     }
  509.  
  510. # Dividiert zwei Integers x,y und liefert Quotient und Rest
  511. # (q,r) := (ceiling x y)
  512. # I_I_ceiling_I_I(x,y);
  513. # > x,y: Integers
  514. # < STACK_1: Quotient q
  515. # < STACK_0: Rest r
  516. # Erniedrigt STACK um 2
  517. # kann GC auslösen
  518.   local void I_I_ceiling_I_I (object x, object y);
  519. # Methode:
  520. # (ceiling x y) :==
  521. # (DIVIDE (abs x) (abs y)) -> q,r
  522. # Falls x,y selbes Vorzeichen haben und r<>0,
  523. #   setze q:=q+1 und r:=r-abs(y).
  524. # Falls x<0, setze r:=-r.
  525. # Falls x,y verschiedene Vorzeichen haben, setze q:=-q.
  526. # Liefere q,r.
  527.   local void I_I_ceiling_I_I(x,y)
  528.     var reg2 object x;
  529.     var reg3 object y;
  530.     { pushSTACK(y);
  531.       pushSTACK(x);
  532.       pushSTACK(I_abs_I(y));
  533.       # Stackaufbau: y, x, (abs y).
  534.       x = I_abs_I(STACK_1); # (abs x)
  535.       I_I_divide_I_I(x,STACK_0); # q,r auf den Stack
  536.       # Stackaufbau: y, x, (abs y), q, r.
  537.       if (same_sign_p(STACK_3,STACK_4))
  538.         # x,y haben selbes Vorzeichen
  539.         if (!eq(STACK_0,Fixnum_0))
  540.           # r/=0, also r>0.
  541.           { STACK_1 = I_1_plus_I(STACK_1); # q := (1+ q)
  542.             STACK_0 = I_I_minus_I(STACK_0,STACK_2); # r := (- r (abs y))
  543.           }
  544.       if (R_mminusp(STACK_3))
  545.         # x<0
  546.         { STACK_0 = I_minus_I(STACK_0); # r := (- r)
  547.           if (!R_mminusp(STACK_4)) # y>=0 ?
  548.             goto negate_q; # q := (- q)
  549.         }
  550.         else
  551.         # x>=0
  552.         { if (R_mminusp(STACK_4)) # y<0 ?
  553.             negate_q: { STACK_1 = I_minus_I(STACK_1); } # q := (- q)
  554.         }
  555.       STACK_4 = STACK_1; STACK_3 = STACK_0; skipSTACK(3); # Stack aufräumen
  556.     }
  557.  
  558. # Dividiert zwei Integers x,y und liefert Quotient und Rest
  559. # (q,r) := (truncate x y)
  560. # I_I_truncate_I_I(x,y);
  561. # > x,y: Integers
  562. # < STACK_1: Quotient q
  563. # < STACK_0: Rest r
  564. # Erniedrigt STACK um 2
  565. # kann GC auslösen
  566.   local void I_I_truncate_I_I (object x, object y);
  567. # Methode:
  568. # (truncate x y) :==
  569. # (DIVIDE (abs x) (abs y)) -> q,r
  570. # Falls x<0, setze r:=-r.
  571. # Falls x,y verschiedene Vorzeichen haben, setze q:=-q.
  572. # Liefere q,r.
  573.   local void I_I_truncate_I_I(x,y)
  574.     var reg2 object x;
  575.     var reg3 object y;
  576.     { pushSTACK(y);
  577.       pushSTACK(x);
  578.       pushSTACK(I_abs_I(y));
  579.       # Stackaufbau: y, x, (abs y).
  580.       x = I_abs_I(STACK_1); # (abs x)
  581.       I_I_divide_I_I(x,popSTACK()); # q,r auf den Stack
  582.       # Stackaufbau: y, x, q, r.
  583.       if (R_mminusp(STACK_2))
  584.         # x<0
  585.         { STACK_0 = I_minus_I(STACK_0); # r := (- r)
  586.           if (!R_mminusp(STACK_3)) # y>=0 ?
  587.             goto negate_q; # q := (- q)
  588.         }
  589.         else
  590.         # x>=0
  591.         { if (R_mminusp(STACK_3)) # y<0 ?
  592.             negate_q: { STACK_1 = I_minus_I(STACK_1); } # q := (- q)
  593.         }
  594.       STACK_3 = STACK_1; STACK_2 = STACK_0; skipSTACK(2); # Stack aufräumen
  595.     }
  596.  
  597. # Dividiert zwei Integers x,y und liefert Quotient und Rest
  598. # (q,r) := (round x y)
  599. # I_I_round_I_I(x,y);
  600. # > x,y: Integers
  601. # < STACK_1: Quotient q
  602. # < STACK_0: Rest r
  603. # Erniedrigt STACK um 2
  604. # kann GC auslösen
  605.   local void I_I_round_I_I (object x, object y);
  606. # Methode:
  607. # (round x y) :==
  608. # (DIVIDE (abs x) (abs y)) -> q,r
  609. # Setze s:=abs(y)-r.
  610. # Falls (r>s) oder (r=s und q ungerade),
  611. #   (d.h. falls r>abs(y)/2 oder r=abs(y)/2 und q ungerade),
  612. #   setze q:=q+1 und r:=-s (d.h. r:=r-abs(y)).
  613. # {Nun ist abs(r) <= abs(y)/2, bei abs(r)=abs(y)/2 ist q gerade.}
  614. # Falls x<0, setze r:=-r.
  615. # Falls x,y verschiedene Vorzeichen haben, setze q:=-q.
  616. # Liefere q,r.
  617.   local void I_I_round_I_I(x,y)
  618.     var reg2 object x;
  619.     var reg3 object y;
  620.     { pushSTACK(y);
  621.       pushSTACK(x);
  622.       pushSTACK(I_abs_I(y));
  623.       # Stackaufbau: y, x, (abs y).
  624.       x = I_abs_I(STACK_1); # (abs x)
  625.       I_I_divide_I_I(x,STACK_0); # q,r auf den Stack
  626.       # Stackaufbau: y, x, (abs y), q, r.
  627.      {var reg4 object s = I_I_minus_I(STACK_2,STACK_0); # (- (abs y) r)
  628.       var reg1 signean comp_r_s = I_I_comp(STACK_0,s); # vergleiche r und s
  629.       if ((comp_r_s>0) || ((comp_r_s==0) && (I_oddp(STACK_1)))) # (r>s) oder (r=s und q ungerade) ?
  630.         { STACK_0 = I_minus_I(s); # r := (- s) = (- r (abs y))
  631.           STACK_1 = I_1_plus_I(STACK_1); # q := (1+ q)
  632.         }
  633.       if (R_mminusp(STACK_3))
  634.         # x<0
  635.         { STACK_0 = I_minus_I(STACK_0); # r := (- r)
  636.           if (!R_mminusp(STACK_4)) # y>=0 ?
  637.             goto negate_q; # q := (- q)
  638.         }
  639.         else
  640.         # x>=0
  641.         { if (R_mminusp(STACK_4)) # y<0 ?
  642.             negate_q: { STACK_1 = I_minus_I(STACK_1); } # q := (- q)
  643.         }
  644.       STACK_4 = STACK_1; STACK_3 = STACK_0; skipSTACK(3); # Stack aufräumen
  645.     }}
  646.  
  647.