home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / realelem.d < prev    next >
Encoding:
Text File  |  1994-06-18  |  39.8 KB  |  958 lines
  1. # Elementare Funktionen fⁿr reelle Zahlen
  2.  
  3. # R_zerop(x) stellt fest, ob (= x 0), wo x eine reelle Zahl ist.
  4.   local boolean R_zerop (object x);
  5.   local boolean R_zerop(x)
  6.     var reg1 object x;
  7.     { if (R_rationalp(x))
  8.         # bei rationalen Zahlen: Test auf 0
  9.         { if (eq(x,Fixnum_0)) { goto yes; } else { goto no; } }
  10.         # bei Floats: Fallunterscheidung
  11.         { floatcase(x,
  12.                     { if (SF_zerop(x)) { goto yes; } else { goto no; } },
  13.                     { if (FF_zerop(x)) { goto yes; } else { goto no; } },
  14.                     { if (DF_zerop(x)) { goto yes; } else { goto no; } },
  15.                     { if (LF_zerop(x)) { goto yes; } else { goto no; } }
  16.                    );
  17.         }
  18.       yes: return TRUE;
  19.       no: return FALSE;
  20.     }
  21.  
  22. # R_plusp(x) stellt fest, ob (> x 0), wo x eine reelle Zahl ist.
  23.   local boolean R_plusp (object x);
  24.   local boolean R_plusp(x)
  25.     var reg1 object x;
  26.     { if (R_minusp(x)) { return FALSE; } # x<0 -> nein
  27.       elif (R_zerop(x)) { return FALSE; } # x=0 -> nein
  28.       else { return TRUE; } # sonst ist x>0.
  29.     }
  30.  
  31. # R_minusp(x) stellt fest, ob (< x 0), wo x eine reelle Zahl ist.
  32. # (Macro in LISPBIBL.D)
  33.  
  34. # I_F_float_F(x,y) wandelt ein Integer x in das Float-Format des Floats y um
  35. # und rundet dabei n÷tigenfalls.
  36. # > x: ein Integer
  37. # > y: ein Float
  38. # < ergebnis: (float x y)
  39. # kann GC ausl÷sen
  40.   local object I_F_float_F (object x, object y);
  41.   local object I_F_float_F(x,y)
  42.     var reg2 object x;
  43.     var reg1 object y;
  44.     { floatcase(y,
  45.                 { return I_to_SF(x); },
  46.                 { return I_to_FF(x); },
  47.                 { return I_to_DF(x); },
  48.                 { return I_to_LF(x,TheLfloat(y)->len); }
  49.                );
  50.     }
  51.  
  52. # RA_F_float_F(x,y) wandelt eine rationale Zahl x in das Float-Format des
  53. # Floats y um und rundet dabei n÷tigenfalls.
  54. # > x: eine rationale Zahl
  55. # > y: ein Float
  56. # < ergebnis: (float x y)
  57. # kann GC ausl÷sen
  58.   local object RA_F_float_F (object x, object y);
  59.   local object RA_F_float_F(x,y)
  60.     var reg2 object x;
  61.     var reg1 object y;
  62.     { floatcase(y,
  63.                 { return RA_to_SF(x); },
  64.                 { return RA_to_FF(x); },
  65.                 { return RA_to_DF(x); },
  66.                 { return RA_to_LF(x,TheLfloat(y)->len); }
  67.                );
  68.     }
  69.  
  70. # R_F_float_F(x,y) wandelt eine reelle Zahl x in das Float-Format des Floats
  71. # y um und rundet dabei n÷tigenfalls.
  72. # > x: eine reelle Zahl
  73. # > y: ein Float
  74. # < ergebnis: (float x y)
  75. # kann GC ausl÷sen
  76.   local object R_F_float_F (object x, object y);
  77.   local object R_F_float_F(x,y)
  78.     var reg1 object x;
  79.     var reg2 object y;
  80.     { return (R_rationalp(x) ? RA_F_float_F(x,y) : F_F_float_F(x,y)); }
  81.  
  82. # R_to_SF(x) wandelt eine reelle Zahl x in ein Short-Float um.
  83. # < ergebnis: (coerce x 'short-float)
  84. # kann GC ausl÷sen
  85.   local object R_to_SF (object x);
  86.   local object R_to_SF(x)
  87.     var reg1 object x;
  88.     { return (R_rationalp(x) ? RA_to_SF(x) : F_to_SF(x)); }
  89.  
  90. # R_to_FF(x) wandelt eine reelle Zahl x in ein Single-Float um.
  91. # < ergebnis: (coerce x 'single-float)
  92. # kann GC ausl÷sen
  93.   local object R_to_FF (object x);
  94.   local object R_to_FF(x)
  95.     var reg1 object x;
  96.     { return (R_rationalp(x) ? RA_to_FF(x) : F_to_FF(x)); }
  97.  
  98. # R_to_DF(x) wandelt eine reelle Zahl x in ein Double-Float um.
  99. # < ergebnis: (coerce x 'double-float)
  100. # kann GC ausl÷sen
  101.   local object R_to_DF (object x);
  102.   local object R_to_DF(x)
  103.     var reg1 object x;
  104.     { return (R_rationalp(x) ? RA_to_DF(x) : F_to_DF(x)); }
  105.  
  106. # R_to_LF(x,len) wandelt eine reelle Zahl x in ein Long-Float mit len Digits um.
  107. # > uintC len: gewⁿnschte Anzahl Digits, >=LF_minlen
  108. # < ergebnis: (coerce x `(long-float ,len))
  109. # kann GC ausl÷sen
  110.   local object R_to_LF (object x, uintC len);
  111.   local object R_to_LF(x,len)
  112.     var reg1 object x;
  113.     var reg2 uintC len;
  114.     { return (R_rationalp(x) ? RA_to_LF(x,len) : F_to_LF(x,len)); }
  115.  
  116. # R_R_contagion_R(x,y) liefert eine reelle Zahl, die so ungenau ist wie die
  117. # ungenauere der beiden reellen Zahlen x und y.
  118.   local object R_R_contagion_R (object x, object y);
  119.   local object R_R_contagion_R(x,y)
  120.     var reg1 object x;
  121.     var reg2 object y;
  122.     {
  123.       #define X  { return x; }
  124.       #define Y  { return y; }
  125.       if (R_rationalp(x)) Y
  126.       elif (R_rationalp(y)) X
  127.       else
  128.         floatcase(x,
  129.         /* x SF */ X, # floatcase(y, X,X,X,X),
  130.         /* x FF */ floatcase(y, Y,X,X,X),
  131.         /* x DF */ floatcase(y, Y,Y,X,X),
  132.         /* x LF */ floatcase(y, Y,Y,Y, { if (TheLfloat(x)->len <= TheLfloat(y)->len) X else Y } )
  133.                  );
  134.       #undef Y
  135.       #undef X
  136.     }
  137.  
  138. # Macro: verteilt je nach Default-Float-Typ auf 4 Statements.
  139. # defaultfloatcase(symbol, SF_statement,FF_statement,DF_statement,LF_statement, save_statement,restore_statement);
  140. # symbol sollte ein S(..)-Symbol sein. Dessen Wert sollte SHORT-FLOAT oder
  141. # SINGLE-FLOAT oder DOUBLE-FLOAT oder LONG-FLOAT sein. Sollte es das nicht
  142. # sein, wird der Wert auf SINGLE-FLOAT gesetzt und eine Warnung ausgegeben.
  143. # kann GC ausl÷sen, aber nur zwischen save_statement und restore_statement.
  144.   #define defaultfloatcase(symbol, SF_statement,FF_statement,DF_statement,LF_statement, save_statement,restore_statement) \
  145.     {var reg1 object def = Symbol_value(symbol); # Wert holen       \
  146.      if (eq(def,S(short_float))) { SF_statement }                   \
  147.      elif (eq(def,S(single_float))) { FF_statement }                \
  148.      elif (eq(def,S(double_float))) { DF_statement }                \
  149.      elif (eq(def,S(long_float))) { LF_statement }                  \
  150.      else                                                           \
  151.        { Symbol_value(symbol) = S(single_float); # Wert korrigieren \
  152.          save_statement                                             \
  153.          # Warnung ausgeben:                                        \
  154.          # (WARN "In ~S wurde ein illegaler Wert vorgefunden,       \
  155.          #        ~S wird auf ~S zurⁿckgesetzt."                    \
  156.          #       symbol symbol (symbol-value symbol)                \
  157.          # )                                                        \
  158.          pushSTACK(OL(default_float_format_warnung_string));        \
  159.          pushSTACK(symbol);                                         \
  160.          pushSTACK(symbol);                                         \
  161.          pushSTACK(Symbol_value(symbol));                           \
  162.          funcall(S(warn),4);                                        \
  163.          restore_statement                                          \
  164.          { FF_statement }                                           \
  165.     }  }
  166.  
  167. # I_float_F(x) wandelt ein Integer x in ein Float um und rundet dabei.
  168. # > x: ein Integer
  169. # < ergebnis: (float x)
  170. # kann GC ausl÷sen
  171.   local object I_float_F (object x);
  172.   local object I_float_F(x)
  173.     var reg2 object x;
  174.     { defaultfloatcase(S(default_float_format),
  175.                        return I_to_SF(x); ,
  176.                        return I_to_FF(x); ,
  177.                        return I_to_DF(x); ,
  178.                        return I_to_LF(x,I_to_UL(O(LF_digits))); ,
  179.                        pushSTACK(x); , x = popSTACK();
  180.                       );
  181.     }
  182.  
  183. # RA_float_F(x) wandelt eine rationale Zahl x in ein Float um und rundet dabei.
  184. # > x: eine rationale Zahl
  185. # < ergebnis: (float x)
  186. # kann GC ausl÷sen
  187.   local object RA_float_F (object x);
  188.   local object RA_float_F(x)
  189.     var reg2 object x;
  190.     { defaultfloatcase(S(default_float_format),
  191.                        return RA_to_SF(x); ,
  192.                        return RA_to_FF(x); ,
  193.                        return RA_to_DF(x); ,
  194.                        return RA_to_LF(x,I_to_UL(O(LF_digits))); ,
  195.                        pushSTACK(x); , x = popSTACK();
  196.                       );
  197.     }
  198.  
  199. # R_float_F(x) wandelt eine reelle Zahl x in ein Float um
  200. # und rundet dabei n÷tigenfalls.
  201. # > x: eine reelle Zahl
  202. # < ergebnis: (float x)
  203. # kann GC ausl÷sen
  204.   local object R_float_F (object x);
  205.   local object R_float_F(x)
  206.     var reg1 object x;
  207.     { return (R_rationalp(x) ? RA_float_F(x) : x); }
  208.  
  209. # Generiert eine Funktion wie R_floor_I_R
  210.   #define GEN_R_round(rounding)  \
  211.     # Liefert ganzzahligen und gebrochenen Anteil einer reellen Zahl. \
  212.     # (q,r) := (rounding x)                                           \
  213.     # R_rounding_I_R(x);                                              \
  214.     # > x: reelle Zahl                                                \
  215.     # < STACK_1: Quotient q, ein Integer                              \
  216.     # < STACK_0: Rest r, eine reelle Zahl                             \
  217.     # Erniedrigt STACK um 2                                           \
  218.     # kann GC ausl÷sen                                                \
  219.     # Methode:                                    \
  220.     # x rational -> RA_rounding_I_RA(x)           \
  221.     # x Float -> F_rounding_I_F(x)                \
  222.     local void CONCAT3(R_,rounding,_I_R) PARM1(x, \
  223.       var reg1 object x)                          \
  224.       { if (R_rationalp(x))                       \
  225.           { CONCAT3(RA_,rounding,_I_RA) (x); }    \
  226.           else                                    \
  227.           { CONCAT3(F_,rounding,_I_F) (x); }      \
  228.       }
  229.  
  230. # R_floor_I_R(x) liefert (floor x), wo x eine reelle Zahl ist.
  231. # Beide Werte in den Stack.
  232. # kann GC ausl÷sen
  233.   local void R_floor_I_R (object x);
  234.   GEN_R_round(floor)
  235.  
  236. # R_ceiling_I_R(x) liefert (ceiling x), wo x eine reelle Zahl ist.
  237. # Beide Werte in den Stack.
  238. # kann GC ausl÷sen
  239.   local void R_ceiling_I_R (object x);
  240.   GEN_R_round(ceiling)
  241.  
  242. # R_truncate_I_R(x) liefert (truncate x), wo x eine reelle Zahl ist.
  243. # Beide Werte in den Stack.
  244. # kann GC ausl÷sen
  245.   local void R_truncate_I_R (object x);
  246.   GEN_R_round(truncate)
  247.  
  248. # R_round_I_R(x) liefert (round x), wo x eine reelle Zahl ist.
  249. # Beide Werte in den Stack.
  250. # kann GC ausl÷sen
  251.   local void R_round_I_R (object x);
  252.   GEN_R_round(round)
  253.  
  254. # Generiert eine Funktion wie R_ffloor_F_R
  255.   #define GEN_R_fround(rounding)  \
  256.     # Liefert ganzzahligen und gebrochenen Anteil einer reellen Zahl. \
  257.     # (q,r) := (frounding x)                                          \
  258.     # R_frounding_F_R(x);                                             \
  259.     # > x: reelle Zahl                                                \
  260.     # < STACK_1: Quotient q, ein integer-wertiges Float               \
  261.     # < STACK_0: Rest r, eine reelle Zahl                             \
  262.     # Erniedrigt STACK um 2                                           \
  263.     # kann GC ausl÷sen                                                \
  264.     # Methode:                                                          \
  265.     # x rational -> RA_rounding_I_RA(x), Quotienten in Float umwandeln. \
  266.     # x Float -> F_frounding_F_F(x).                                    \
  267.     local void CONCAT3(R_f,rounding,_F_R) PARM1(x,                     \
  268.       var reg1 object x)                                               \
  269.       { if (R_rationalp(x))                                            \
  270.           { CONCAT3(RA_,rounding,_I_RA) (x); # Rational-Routine        \
  271.             STACK_1 = I_float_F(STACK_1); # 1. Wert in Float umwandeln \
  272.           }                                                            \
  273.           else                                                         \
  274.           { CONCAT3(F_f,rounding,_F_F) (x); } # Float-Routine          \
  275.       }
  276.  
  277. # R_ffloor_F_R(x) liefert (ffloor x), wo x eine reelle Zahl ist.
  278. # Beide Werte in den Stack.
  279. # kann GC ausl÷sen
  280.   local void R_ffloor_F_R (object x);
  281.   GEN_R_fround(floor)
  282.  
  283. # R_fceiling_F_R(x) liefert (fceiling x), wo x eine reelle Zahl ist.
  284. # Beide Werte in den Stack.
  285. # kann GC ausl÷sen
  286.   local void R_fceiling_F_R (object x);
  287.   GEN_R_fround(ceiling)
  288.  
  289. # R_ftruncate_F_R(x) liefert (ftruncate x), wo x eine reelle Zahl ist.
  290. # Beide Werte in den Stack.
  291. # kann GC ausl÷sen
  292.   local void R_ftruncate_F_R (object x);
  293.   GEN_R_fround(truncate)
  294.  
  295. # R_fround_F_R(x) liefert (fround x), wo x eine reelle Zahl ist.
  296. # Beide Werte in den Stack.
  297. # kann GC ausl÷sen
  298.   local void R_fround_F_R (object x);
  299.   GEN_R_fround(round)
  300.  
  301. # Generiert eine Funktion wie R_R_plus_R
  302.   #define GEN_R_op21(arg1,arg2,op,ergebnis_zuweisung)  \
  303.     { if (R_rationalp(arg1))                                                      \
  304.         { if (R_rationalp(arg2))                                                  \
  305.             # beides rationale Zahlen                                             \
  306.             { ergebnis_zuweisung CONCAT3(RA_RA_,op,_RA) (arg1,arg2); }            \
  307.             else                                                                  \
  308.             # arg1 rational, arg2 Float -> arg1 in Float umwandeln                \
  309.             { pushSTACK(arg2); arg1 = RA_F_float_F(arg1,arg2); arg2 = popSTACK(); \
  310.               ergebnis_zuweisung CONCAT3(F_F_,op,_F) (arg1,arg2);                 \
  311.             }                                                                     \
  312.         }                                                                         \
  313.         else                                                                      \
  314.         { if (R_rationalp(arg2))                                                  \
  315.             # arg1 Float, arg2 rational -> arg2 in Float umwandeln                \
  316.             { pushSTACK(arg1); arg2 = RA_F_float_F(arg2,arg1); arg1 = popSTACK(); \
  317.               ergebnis_zuweisung CONCAT3(F_F_,op,_F) (arg1,arg2);                 \
  318.             }                                                                     \
  319.             else                                                                  \
  320.             # beides Floats                                                       \
  321.             { ergebnis_zuweisung CONCAT3(F_F_,op,_F) (arg1,arg2); }               \
  322.         }                                                                         \
  323.     }
  324.  
  325. # R_minus_R(x) liefert (- x), wo x eine reelle Zahl ist.
  326. # kann GC ausl÷sen
  327.   local object R_minus_R (object x);
  328.   local object R_minus_R(x)
  329.     var reg1 object x;
  330.     { return (R_rationalp(x) ? RA_minus_RA(x) : F_minus_F(x)); }
  331.  
  332. # R_abs_R(x) liefert (abs x), wo x eine reelle Zahl ist.
  333. # kann GC ausl÷sen
  334.   local object R_abs_R (object x);
  335.   local object R_abs_R(x)
  336.     var reg1 object x;
  337.     { return (R_minusp(x) ? R_minus_R(x) : x); } # x<0 -> (- x), x>=0 -> x
  338.  
  339. # R_R_plus_R(x,y) liefert (+ x y), wo x und y reelle Zahlen sind.
  340. # kann GC ausl÷sen
  341.   local object R_R_plus_R (object x, object y);
  342.   local object R_R_plus_R(x,y)
  343.     var reg1 object x;
  344.     var reg2 object y;
  345.     { if (eq(y,Fixnum_0)) { return x; }
  346.       elif (eq(x,Fixnum_0)) { return y; }
  347.       else
  348.         GEN_R_op21(x,y,plus,return)
  349.     }
  350.  
  351. # R_R_minus_R(x,y) liefert (- x y), wo x und y reelle Zahlen sind.
  352. # kann GC ausl÷sen
  353.   local object R_R_minus_R (object x, object y);
  354.   local object R_R_minus_R(x,y)
  355.     var reg1 object x;
  356.     var reg2 object y;
  357.     { if (eq(y,Fixnum_0)) { return x; }
  358.       elif (eq(x,Fixnum_0)) { return R_minus_R(y); }
  359.       else
  360.         GEN_R_op21(x,y,minus,return)
  361.     }
  362.  
  363. # R_R_mal_R(x,y) liefert (* x y), wo x und y reelle Zahlen sind.
  364. # kann GC ausl÷sen
  365.   local object R_R_mal_R (object x, object y);
  366.   local object R_R_mal_R(x,y)
  367.     var reg1 object x;
  368.     var reg2 object y;
  369.     { if (eq(x,Fixnum_0)) { return x; } # 0 * y = exakte 0
  370.       elif (eq(y,Fixnum_0)) { return y; } # x * 0 = exakte 0
  371.       else
  372.         GEN_R_op21(x,y,mal,return)
  373.     }
  374.  
  375. # R_durch_R(x) liefert (/ x), wo x eine reelle Zahl ist.
  376. # kann GC ausl÷sen
  377.   local object R_durch_R (object x);
  378.   local object R_durch_R(x)
  379.     var reg1 object x;
  380.     { return (R_rationalp(x) ? RA_durch_RA(x) : F_durch_F(x)); }
  381.  
  382. # R_R_durch_R(x,y) liefert (/ x y), wo x und y reelle Zahlen sind.
  383. # kann GC ausl÷sen
  384.   local object R_R_durch_R (object x, object y);
  385.   local object R_R_durch_R(x,y)
  386.     var reg1 object x;
  387.     var reg2 object y;
  388.     { if (eq(x,Fixnum_0))
  389.         # 0 / y = exakte 0, au▀er wenn y=0
  390.         { if (R_zerop(y)) { divide_0(); } else { return x; } }
  391.       else
  392.         GEN_R_op21(x,y,durch,return)
  393.     }
  394.  
  395. # Generiert eine Funktion wie R_R_floor_I_R
  396.   #define GEN_R_R_round(rounding)  \
  397.     # Liefert ganzzahligen Quotienten und Rest \
  398.     # einer Division reeller Zahlen.           \
  399.     # (q,r) := (rounding x y)                  \
  400.     # R_R_rounding_I_R(x,y);                   \
  401.     # > x,y: reelle Zahlen                     \
  402.     # < STACK_1: Quotient q, ein Integer       \
  403.     # < STACK_0: Rest r, eine reelle Zahl      \
  404.     # Erniedrigt STACK um 2                    \
  405.     # kann GC ausl÷sen                         \
  406.     # Methode:                                                      \
  407.     # Beides Integers -> I_I_rounding_I_I(x,y).                     \
  408.     # Sonst: R_rounding_I_R(x/y) -> (q,r). Liefere q und x-y*q=y*r. \
  409.     local void CONCAT3(R_R_,rounding,_I_R) PARM2(x,y, \
  410.       var reg2 object x,                              \
  411.       var reg1 object y)                              \
  412.       { if (N_integerp(x) && N_integerp(y)) # beides Integers? \
  413.           { CONCAT3(I_I_,rounding,_I_I) (x,y); } # ja -> Integer-Routine \
  414.           else                                        \
  415.           { pushSTACK(y);                             \
  416.             CONCAT3(R_,rounding,_I_R) (R_R_durch_R(x,y)); # ganzzahligen Anteil des Quotienten bilden \
  417.             y = STACK_2; STACK_2 = STACK_1;           \
  418.             STACK_1 = R_R_mal_R(y,STACK_0); # Nachkommateil mit y multiplizieren \
  419.             skipSTACK(1);                             \
  420.       }   }
  421.  
  422. # R_R_floor_I_R(x,y) liefert (floor x y), wo x und y reelle Zahlen sind.
  423. # Beide Werte in den Stack.
  424. # kann GC ausl÷sen
  425.   local void R_R_floor_I_R (object x, object y);
  426.   GEN_R_R_round(floor)
  427.  
  428. # R_R_ceiling_I_R(x,y) liefert (ceiling x y), wo x und y reelle Zahlen sind.
  429. # Beide Werte in den Stack.
  430. # kann GC ausl÷sen
  431.   local void R_R_ceiling_I_R (object x, object y);
  432.   GEN_R_R_round(ceiling)
  433.  
  434. # R_R_truncate_I_R(x,y) liefert (truncate x y), wo x und y reelle Zahlen sind.
  435. # Beide Werte in den Stack.
  436. # kann GC ausl÷sen
  437.   local void R_R_truncate_I_R (object x, object y);
  438.   GEN_R_R_round(truncate)
  439.  
  440. # R_R_round_I_R(x,y) liefert (round x y), wo x und y reelle Zahlen sind.
  441. # Beide Werte in den Stack.
  442. # kann GC ausl÷sen
  443.   local void R_R_round_I_R (object x, object y);
  444.   GEN_R_R_round(round)
  445.  
  446. # Generiert eine Funktion wie R_R_mod_R
  447.   #define GEN_R_R_mod(remainder,rounding)  \
  448.     # Liefert den Rest einer Division reeller Zahlen.      \
  449.     # (remainder x y) = (- x (* y (rounding x y)))         \
  450.     #                 = (* y (nth-value 1 (rounding x y))) \
  451.     # R_R_remainder_R(x,y)                                 \
  452.     # > x,y: reelle Zahlen                                 \
  453.     # < ergebnis: Rest r, eine reelle Zahl                 \
  454.     # kann GC ausl÷sen                                     \
  455.     # Methode:                                                \
  456.     # Beides Integers -> I_I_remainder_I(x,y).                \
  457.     # Sonst: R_rounding_I_R(x/y) -> (q,r). Liefere x-y*q=y*r. \
  458.     local object CONCAT3(R_R_,remainder,_R) PARM2(x,y, \
  459.       var reg2 object x,                               \
  460.       var reg1 object y)                               \
  461.       { if (N_integerp(x) && N_integerp(y)) # beides Integers? \
  462.           { return CONCAT3(I_I_,remainder,_I) (x,y); } # ja -> Integer-Routine \
  463.           else                                         \
  464.           { pushSTACK(y);                              \
  465.             CONCAT3(R_,rounding,_I_R) (R_R_durch_R(x,y)); # ganzzahligen Anteil des Quotienten bilden \
  466.             y = STACK_2; x = STACK_0; skipSTACK(3);    \
  467.             return R_R_mal_R(y,x); # Nachkommateil mit y multiplizieren \
  468.       }   }
  469.  
  470. # R_R_mod_R(x,y) = (mod x y), wo x und y reelle Zahlen sind.
  471. # kann GC ausl÷sen
  472.   local object R_R_mod_R (object x, object y);
  473.   GEN_R_R_mod(mod,floor)
  474.  
  475. # R_R_rem_R(x,y) = (rem x y), wo x und y reelle Zahlen sind.
  476. # kann GC ausl÷sen
  477.   local object R_R_rem_R (object x, object y);
  478.   GEN_R_R_mod(rem,truncate)
  479.  
  480. # Generiert eine Funktion wie R_R_ffloor_F_R
  481.   #define GEN_R_R_fround(rounding)  \
  482.     # Liefert ganzzahligen Quotienten (als Float) und Rest \
  483.     # einer Division reeller Zahlen.                       \
  484.     # (q,r) := (frounding x y)                             \
  485.     # R_R_frounding_F_R(x,y);                              \
  486.     # > x,y: reelle Zahlen                                 \
  487.     # < STACK_1: Quotient q, ein integer-wertiges Float    \
  488.     # < STACK_0: Rest r, eine reelle Zahl                  \
  489.     # Erniedrigt STACK um 2                                \
  490.     # kann GC ausl÷sen                                     \
  491.     # Methode:                                                            \
  492.     # x,y beide rational:                                                 \
  493.     #   R_R_rounding_I_R(x,y), Quotienten in Float umwandeln.             \
  494.     # Sonst:                                                              \
  495.     #   R_frounding_F_R(x/y) -> q,r. Liefere die Werte q und x-y*q = y*r. \
  496.     local void CONCAT3(R_R_f,rounding,_F_R) PARM2(x,y,                           \
  497.       var reg2 object x,                                                         \
  498.       var reg1 object y)                                                         \
  499.       { if (R_rationalp(x) && R_rationalp(y)) # beides rationale Zahlen?         \
  500.           { CONCAT3(R_R_,rounding,_I_R) (x,y); # Division mit Rest               \
  501.             STACK_1 = I_float_F(STACK_1); # Quotienten zum Float machen          \
  502.           }                                                                      \
  503.           else                                                                   \
  504.           { pushSTACK(y);                                                        \
  505.             CONCAT3(R_f,rounding,_F_R) (R_R_durch_R(x,y)); # ganzzahligen Anteil des Quotienten bilden \
  506.             y = STACK_2; STACK_2 = STACK_1;                                      \
  507.             STACK_1 = R_R_mal_R(y,STACK_0); # Nachkommateil mit y multiplizieren \
  508.             skipSTACK(1);                                                        \
  509.       }   }
  510.  
  511. # R_R_ffloor_F_R(x,y) liefert (ffloor x y), wo x und y reelle Zahlen sind.
  512. # Beide Werte in den Stack.
  513. # kann GC ausl÷sen
  514.   local void R_R_ffloor_F_R (object x, object y);
  515.   GEN_R_R_fround(floor)
  516.  
  517. # R_R_fceiling_F_R(x,y) liefert (fceiling x y), wo x und y reelle Zahlen sind.
  518. # Beide Werte in den Stack.
  519. # kann GC ausl÷sen
  520.   local void R_R_fceiling_F_R (object x, object y);
  521.   GEN_R_R_fround(ceiling)
  522.  
  523. # R_R_ftruncate_F_R(x,y) liefert (ftruncate x y), wo x und y reelle Zahlen sind.
  524. # Beide Werte in den Stack.
  525. # kann GC ausl÷sen
  526.   local void R_R_ftruncate_F_R (object x, object y);
  527.   GEN_R_R_fround(truncate)
  528.  
  529. # R_R_fround_F_R(x,y) liefert (fround x y), wo x und y reelle Zahlen sind.
  530. # Beide Werte in den Stack.
  531. # kann GC ausl÷sen
  532.   local void R_R_fround_F_R (object x, object y);
  533.   GEN_R_R_fround(round)
  534.  
  535. # R_1_plus_R(x) liefert (1+ x), wo x eine reelle Zahl ist.
  536. # kann GC ausl÷sen
  537.   local object R_1_plus_R (object x);
  538.   local object R_1_plus_R(x)
  539.     var reg1 object x;
  540.     { return (R_rationalp(x) ? RA_1_plus_RA(x) : R_R_plus_R(x,Fixnum_1)); }
  541.  
  542. # R_minus1_plus_R(x) liefert (1- x), wo x eine reelle Zahl ist.
  543. # kann GC ausl÷sen
  544.   local object R_minus1_plus_R (object x);
  545.   local object R_minus1_plus_R(x)
  546.     var reg1 object x;
  547.     { return (R_rationalp(x) ? RA_minus1_plus_RA(x) : R_R_plus_R(x,Fixnum_minus1)); }
  548.  
  549. # F_rational_RA(x) liefert (rational x), wo x ein Float ist.
  550. # kann GC ausl÷sen
  551.   local object F_rational_RA (object x);
  552.   # Methode:
  553.   # Der mathematische Wert eines Float ist, wenn INTEGER-DECODE-FLOAT die
  554.   # drei Zahlen m,e,s (Mantisse, Exponent, Vorzeichen) liefert,
  555.   # = s * 2^e * m.
  556.   # n:=m. Falls s<0, setze n:=-m.
  557.   # Falls e>=0, ist (ash n e) das Ergebnis,
  558.   # sonst ist die rationale Zahl (/ n (ash 1 (- e))) das Ergebnis.
  559.   local object F_rational_RA(x)
  560.     var reg3 object x;
  561.     { F_integer_decode_float_I_I_I(x);
  562.       # Stackaufbau: m, e, s.
  563.      {var reg1 object n = STACK_2;
  564.       if (R_mminusp(STACK_0)) { n = I_minus_I(n); } # s<0 -> setze n := (- n)
  565.       {var reg2 object e = STACK_1;
  566.        skipSTACK(3);
  567.        if (!R_minusp(e))
  568.          { return I_I_ash_I(n,e); } # e>=0 -> (ash n e)
  569.          else
  570.          { pushSTACK(n);
  571.            e = I_I_ash_I(Fixnum_1,I_minus_I(e)); # (ash 1 (- e))
  572.            return I_posI_durch_RA(popSTACK(),e); # Bruch (/ n (ash 1 (- e)))
  573.          }
  574.     }}}
  575.  
  576. # R_rational_RA(x) liefert (rational x), wo x eine reelle Zahl ist.
  577. # kann GC ausl÷sen
  578.   local object R_rational_RA (object x);
  579.   local object R_rational_RA(x)
  580.     var reg1 object x;
  581.     { return (R_rationalp(x) ? x : F_rational_RA(x)); }
  582.  
  583. # R_R_comp(x,y) vergleicht zwei reelle Zahlen x und y.
  584. # Ergebnis: 0 falls x=y, +1 falls x>y, -1 falls x<y.
  585. # kann GC ausl÷sen
  586.   local signean R_R_comp (object x, object y);
  587.   # Methode:
  588.   # Beide rational oder beide Floats -> klar.
  589.   # Eine rational, eine Float ->
  590.   #   Die rationale Zahl zum Float machen, vergleichen.
  591.   #   Verschieden -> Das war's.
  592.   #   Gleich -> Das Float mit RATIONAL rational machen, nochmals vergleichen.
  593.   local signean R_R_comp(x,y)
  594.     var reg1 object x;
  595.     var reg2 object y;
  596.     { if (R_rationalp(x))
  597.         { if (R_rationalp(y))
  598.             # beides rationale Zahlen
  599.             { return RA_RA_comp(x,y); }
  600.             else
  601.             # x rational, y Float -> x in Float umwandeln
  602.             { pushSTACK(x); pushSTACK(y); x = RA_F_float_F(x,y); # x in Float umwandeln
  603.              {var reg3 signean erg = F_F_comp(x,STACK_0); # und mit y vergleichen
  604.               if (!(erg==0)) { skipSTACK(2); return erg; } # ungleich -> fertig
  605.               y = F_rational_RA(popSTACK()); # y in rationale Zahl umwandeln
  606.               return RA_RA_comp(popSTACK(),y); # nochmals vergleichen
  607.             }}
  608.         }
  609.         else
  610.         { if (R_rationalp(y))
  611.             # x Float, y rational -> y in Float umwandeln
  612.             { pushSTACK(y); pushSTACK(x); y = RA_F_float_F(y,x); # y in Float umwandeln
  613.              {var reg3 signean erg = F_F_comp(STACK_0,y); # und mit x vergleichen
  614.               if (!(erg==0)) { skipSTACK(2); return erg; } # ungleich -> fertig
  615.               x = F_rational_RA(popSTACK()); # x in rationale Zahl umwandeln
  616.               return RA_RA_comp(x,popSTACK()); # nochmals vergleichen
  617.             }}
  618.             else
  619.             # beides Floats
  620.             { return F_F_comp(x,y); }
  621.         }
  622.     }
  623.  
  624. #if 0 # unvollstΣndig! ??
  625.  
  626. # R_R_gleich(x,y) vergleicht zwei reelle Zahlen x und y.
  627. # Ergebnis: TRUE falls x=y, FALSE sonst.
  628. # kann keine GC ausl÷sen!
  629.   local boolean R_R_gleich (object x, object y);
  630.   # Methode:
  631.   # Wann sind x und y gleich? Nach CLTL, 2nd ed., S. 290 sind die exakten
  632.   # mathematischen Werte zu vergleichen.
  633.   # x,y beide rational: (da x,y als gekⁿrzte Brⁿche mit positivem Nenner
  634.   #   vorliegen) genau dann, wenn die Nenner und die ZΣhler ⁿbereinstimmen.
  635.   # x,y beide Floats: genau dann, wenn die Vorzeichen und die Exponenten
  636.   #   ⁿbereinstimmen und die Mantisse des lΣngeren aus der Mantisse des
  637.   #   kⁿrzeren und sonst lauter Nullen besteht.
  638.   # x rational, y Float: (da der exakte Wert von y ein Integer * 2^Exponent
  639.   #   ist) genau dann, wenn die Vorzeichen ⁿbereinstimmen, der Nenner von x
  640.   #   eine Zweierpotenz ist und zwischen y = (-1)^s * m * 2^e und x = a / 2^c
  641.   #   die Gleichung m * 2^(e+c) = |a| besteht.
  642.   #
  643.   # Test von zwei Integers auf Gleichheit: entweder beide EQ oder beide
  644.   # Bignums, derselben LΣnge und mit denselben Digits (Vorzeichen inbegriffen).
  645.   # Springt mit false_statement weg, falls nicht gleich.
  646.   # define I_I_gleich(x,y) (eq(x,y) || (I_bignump(x) && I_bignump(y) && (x_len==y_len) && (compare_loop_up(x_data,y_data)==0)))
  647.   #define I_I_gleich(x_,y_,false_statement)  \
  648.     { var reg1 object _x = (x_);                       \
  649.       var reg1 object _y = (y_);                       \
  650.       if (!eq(_x,_y))                                  \
  651.         { if (!wbit_test(as_oint(_x) & as_oint(_y),bignum_bit_o)) { false_statement } \
  652.          {var reg2 uintC xlen = TheBignum(_x)->length; \
  653.           var reg3 uintC ylen = TheBignum(_y)->length; \
  654.           if (!(xlen==ylen)) { false_statement }       \
  655.           if (!(compare_loop_up(&TheBignum(_x)->data[0],&TheBignum(_y)->data[0],xlen)==0)) { false_statement } \
  656.     }   }}
  657.   local boolean R_R_gleich(x,y)
  658.     var reg1 object x;
  659.     var reg1 object y;
  660.     { if (R_rationalp(x))
  661.         # x rational
  662.         { if (R_rationalp(y))
  663.             # x,y beide rational
  664.             { if (RA_integerp(x))
  665.                 { if (!RA_integerp(y)) return FALSE;
  666.                   # x,y beide Integers
  667.                   I_I_gleich(x,y, { return FALSE; } );
  668.                   return TRUE;
  669.                 }
  670.                 else
  671.                 { if (RA_integerp(y)) return FALSE;
  672.                   # x,y beide Ratio
  673.                   # Nenner vergleichen:
  674.                   I_I_gleich(TheRatio(x)->rt_den,TheRatio(y)->rt_den, { return FALSE; } );
  675.                   # ZΣhler vergleichen:
  676.                   I_I_gleich(TheRatio(x)->rt_num,TheRatio(y)->rt_num, { return FALSE; } );
  677.                   return TRUE;
  678.                 }
  679.             }
  680.             else
  681.             # x rational, y Float
  682.             { if (!same_sign_p(x,y)) return FALSE; # verschiedene Vorzeichen?
  683.               if (eq(x,Fixnum_0)) return R_zerop(y);
  684.               # x in a / 2^c zerlegen:
  685.              {var reg1 uintL c;
  686.               var reg1 object a;
  687.               if (RA_integerp(x))
  688.                 { c = 0; a = x; }
  689.                 else
  690.                 { c = I_power2p(TheRatio(x)->rt_den); # Nenner mu▀ Zweierpotenz sein
  691.                   if (c==0) return FALSE;
  692.                   c = c-1; a = TheRatio(x)->rt_num;
  693.                 }
  694.               # NUDS zu |a|>0 bilden:
  695.               {SAVE_NUM_STACK # num_stack retten
  696.                var reg1 uintD* a_MSDptr;
  697.                var reg1 uintC a_len;
  698.                var reg1 uintD* a_LSDptr;
  699.                I_to_NDS(a, a_MSDptr=,a_len=,a_LSDptr=);
  700.                # Nicht alle fⁿhrenden intDsize+1 Bits sind gleich.
  701.                if ((sintD)a_MSDptr[0] < 0) { neg_loop_down(a_LSDptr,len); } # evtl. negieren
  702.                # Nicht alle fⁿhrenden intDsize+1 Bits sind =0.
  703.                if (a_MSDptr[0]==0) { a_MSDptr++; a_len--; } # normalisieren
  704.                # Nun ist a_MSDptr[0]/=0 und a_len>0.
  705.                # Je nach Typ des Floats y = (-1)^s * m * 2^e verzweigen und
  706.                # die Gleichung m * 2^(e+c) = |a| testen. Dazu mu▀ erst einmal
  707.                # (wegen 2^(e-1) <= |y| < 2^e)
  708.                #       e+c = integer_length(|a|)
  709.                #           = intDsize*(a_len-1)+integer_length(a_msd)
  710.                # gelten.
  711.                floatcase(y,
  712.                  { # SF y entpacken:
  713.                    var reg3 signean sign;
  714.                    var reg2 sintL e;
  715.                    var reg1 uint32 mant;
  716.                    SF_decode(y, { goto no; }, ,e=,mant=);
  717.                    e = e+c-1; if (e<0) goto no; # e+c<=0 < integer_length(|a|) ?
  718.                    if (!(floor(e,intDsize) == (uintL)a_len-1)) goto no;
  719.                    e = e % intDsize; # sollte = integer_length(a_msd)-1 sein:
  720.                    if (!((a_MSDptr[0]>>e) == 1)) goto no;
  721.                    # Nun ist die Exponentengleichung erfⁿllt.
  722.  
  723.                  });
  724.  
  725.                no:
  726.                RESTORE_NUM_STACK # num_stack zurⁿck
  727.                return FALSE;
  728.     }   }   }}}
  729.  
  730. #endif
  731.  
  732. # R_R_max_R(x,y) liefert (max x y), wo x und y reelle Zahlen sind.
  733. # kann GC ausl÷sen
  734.   local object R_R_max_R (object x, object y);
  735.   local object R_R_max_R(x,y)
  736.     var reg1 object x;
  737.     var reg2 object y;
  738.     { pushSTACK(x); pushSTACK(y); # beide retten
  739.      {var reg3 object erg =
  740.         (R_R_comp(x,y) >= 0 # vergleichen
  741.          ? STACK_1 # x>=y -> x
  742.          : STACK_0 # x<y -> y
  743.         );
  744.       skipSTACK(2);
  745.       return erg;
  746.     }}
  747.  
  748. # R_R_min_R(x,y) liefert (min x y), wo x und y reelle Zahlen sind.
  749. # kann GC ausl÷sen
  750.   local object R_R_min_R (object x, object y);
  751.   local object R_R_min_R(x,y)
  752.     var reg1 object x;
  753.     var reg2 object y;
  754.     { pushSTACK(x); pushSTACK(y); # beide retten
  755.      {var reg3 object erg =
  756.         (R_R_comp(x,y) <= 0 # vergleichen
  757.          ? STACK_1 # x<=y -> x
  758.          : STACK_0 # x>y -> y
  759.         );
  760.       skipSTACK(2);
  761.       return erg;
  762.     }}
  763.  
  764. # R_signum_R(x) liefert (signum x), wo x eine reelle Zahl ist.
  765. # kann GC ausl÷sen
  766.   local object R_signum_R (object x);
  767.   local object R_signum_R(x)
  768.     var reg1 object x;
  769.     { if (R_rationalp(x))
  770.         # x rational
  771.         { if (R_minusp(x)) { return Fixnum_minus1; } # x<0 -> -1
  772.           elif (eq(x,Fixnum_0)) { return x; } # x=0 -> 0
  773.           else { return Fixnum_1; } # x>0 -> +1
  774.         }
  775.         else
  776.         # x Float
  777.         { floatcase(x,
  778.           /* x SF */ { if (R_minusp(x)) { return SF_minus1; } # x<0 -> -1.0
  779.                        elif (SF_zerop(x)) { return x; } # x=0 -> 0.0
  780.                        else { return SF_1; } # x>0 -> +1.0
  781.                      },
  782.           /* x FF */ { if (R_minusp(x)) { return FF_minus1; } # x<0 -> -1.0
  783.                        elif (FF_zerop(x)) { return x; } # x=0 -> 0.0
  784.                        else { return FF_1; } # x>0 -> +1.0
  785.                      },
  786.           /* x DF */ { if (R_minusp(x)) { return DF_minus1; } # x<0 -> -1.0
  787.                        elif (DF_zerop(x)) { return x; } # x=0 -> 0.0
  788.                        else { return DF_1; } # x>0 -> +1.0
  789.                      },
  790.           /* x LF */ { if (LF_zerop(x)) { return x; } #  # x=0 -> 0.0
  791.                        else { encode_LF1s(R_sign(x),TheLfloat(x)->len, return); } # je nach Vorzeichen von x
  792.                      }
  793.                    );
  794.     }   }
  795.  
  796. # R_sqrt_R(x) = (sqrt x) zieht die Wurzel aus einer reellen Zahl x >=0.
  797. # kann GC ausl÷sen
  798.   local object R_sqrt_R (object x);
  799.   local object R_sqrt_R(x)
  800.     var reg1 object x;
  801.     { if (R_rationalp(x))
  802.         # x rationale Zahl >=0
  803.         { pushSTACK(x); # x retten
  804.           x = RA_sqrtp(x); # auf Quadrat testen
  805.           if (!eq(x,nullobj))
  806.             { skipSTACK(1); return x; } # war Quadrat, x ist die Wurzel
  807.             else
  808.             # x in Float umwandeln, dann die Wurzel ziehen:
  809.             { return F_sqrt_F(RA_float_F(popSTACK())); }
  810.         }
  811.         else
  812.         { return F_sqrt_F(x); }
  813.     }
  814.   #define RA_sqrt_R  R_sqrt_R
  815.  
  816. # R_I_expt_R(x,y) = (expt x y), wo x eine reelle Zahl und y ein Integer ist.
  817. # kann GC ausl÷sen
  818.   local object R_I_expt_R (object x, object y);
  819.   # Methode:
  820.   # Fⁿr y>0:
  821.   #   a:=x, b:=y.
  822.   #   Solange b gerade, setze a:=a*a, b:=b/2. [a^b bleibt invariant, = x^y.]
  823.   #   c:=a.
  824.   #   Solange b:=floor(b/2) >0 ist,
  825.   #     setze a:=a*a, und falls b ungerade, setze c:=a*c.
  826.   #   Ergebnis c.
  827.   # Fⁿr y=0: Ergebnis 1.
  828.   # Fⁿr y<0: (/ (expt x (- y))).
  829.   local object R_I_expt_R(x,y)
  830.     var reg3 object x;
  831.     var reg1 object y;
  832.     { if (eq(y,Fixnum_0)) { return Fixnum_1; } # y=0 -> Ergebnis 1
  833.       pushSTACK(x);
  834.      {var reg4 boolean y_negative = FALSE;
  835.       if (R_minusp(y)) { y = I_minus_I(y); y_negative = TRUE; } # Betrag von y nehmen
  836.       # Nun ist y>0.
  837.       if (R_rationalp(x)) # x rational (Abfrage nicht GC-gefΣhrdet!) ?
  838.         { x = RA_I_expt_RA(popSTACK(),y); } # ja -> schnellere Routine
  839.         else
  840.         { pushSTACK(y);
  841.           # Stackaufbau: a, b.
  842.           while (!I_oddp(y))
  843.             { var reg2 object a = STACK_1; STACK_1 = R_R_mal_R(a,a); # a:=a*a
  844.               STACK_0 = y = I_I_ash_I(STACK_0,Fixnum_minus1); # b := (ash b -1)
  845.             }
  846.           pushSTACK(STACK_1); # c:=a
  847.           # Stackaufbau: a, b, c.
  848.           until (eq(y=STACK_1,Fixnum_1)) # Solange b/=1
  849.             { STACK_1 = I_I_ash_I(y,Fixnum_minus1); # b := (ash b -1)
  850.              {var reg2 object a = STACK_2; STACK_2 = a = R_R_mal_R(a,a); # a:=a*a
  851.               if (I_oddp(STACK_1)) { STACK_0 = R_R_mal_R(a,STACK_0); } # evtl. c:=a*c
  852.             }}
  853.           x = STACK_0; skipSTACK(3);
  854.         }
  855.       # (expt x (abs y)) ist jetzt in x.
  856.       return (y_negative ? R_durch_R(x) : x); # evtl. noch Kehrwert nehmen
  857.     }}
  858.  
  859. # R_rationalize_RA(x) liefert (rationalize x), wo x eine reelle Zahl ist.
  860. # kann GC ausl÷sen
  861.   local object R_rationalize_RA (object x);
  862.   # Methode (rekursiv dargestellt):
  863.   # Falls x rational ist: x.
  864.   # Falls x=0.0: 0.
  865.   # Falls x<0.0: (- (rationalize (- x)))
  866.   # Falls x>0.0:
  867.   #   (Integer-Decode-Float x) liefert m,e,s=1.
  868.   #   Falls e>=0 : Liefere x=m*2^e als Ergebnis.
  869.   #   Suche rationale Zahl zwischen a=(m-1/2)*2^e und b=(m+1/2)*2^e mit
  870.   #   m÷glichst kleinem ZΣhler und Nenner. (a,b einschlie▀lich, aber da a,b
  871.   #   den Nenner 2^(|e|+1) haben, wΣhrend x selbst den Nenner <=2^|e| hat,
  872.   #   k÷nnen weder a noch b als Ergebnis herauskommen.)
  873.   #   Suche also bei gegebenem a,b (0<a<b) Bruch y mit a <= y <= b.
  874.   #   Rekursiv:
  875.   #     c:=(ceiling a)
  876.   #     if c<b then return c      ; weil a<=c<b, c ganz
  877.   #            else ; a nicht ganz (sonst c=a<b)
  878.   #              k:=c-1 ; k=floor(a), k < a < b <= k+1
  879.   #              return y = k + 1/(Bruch zwischen 1/(b-k) und 1/(a-k))
  880.   #                                ; wobei 1 <= 1/(b-k) < 1/(a-k)
  881.   # Man sieht, da▀ hierbei eine Kettenbruchentwicklung auftritt.
  882.   # Methode (iterativ):
  883.   # Falls x rational: x.
  884.   # (Integer-Decode-Float x) liefert m,e,s.
  885.   # e>=0 -> m*2^e*s als Ergebnis (darin ist x=0.0 inbegriffen).
  886.   # Bilde a:=(2*m-1)*2^(e-1) und b:=(2*m+1)*2^(e-1), rationale Zahlen >0,
  887.   #   (unkⁿrzbar, da Nenner Zweierpotenz und ZΣhler ungerade).
  888.   # Starte Kettenbruchentwicklung (d.h. p[-1]:=0, p[0]:=1, q[-1]:=1, q[0]:=0, i:=0.)
  889.   # Schleife:
  890.   #   c:=(ceiling a)
  891.   #   if c>=b then k:=c-1, "Ziffer k", (a,b) := (1/(b-k),1/(a-k)), goto Schleife
  892.   # "Ziffer c".
  893.   # (Dabei bedeutet "Ziffer a" die Iteration
  894.   #   i:=i+1, p[i]:=a*p[i-1]+p[i-2], q[i]:=a*q[i-1]+q[i-2].)
  895.   # Ende, liefere s * (p[i]/q[i]), das ist wegen der Invarianten
  896.   #   p[i]*q[i-1]-p[i-1]*q[i]=(-1)^i  ein bereits gekⁿrzter Bruch.
  897.   local object R_rationalize_RA(x)
  898.     var reg3 object x;
  899.     { if (R_rationalp(x)) { return x; } # x rational -> x als Ergebnis.
  900.       F_integer_decode_float_I_I_I(x);
  901.       # Stackaufbau: m, e, s.
  902.       if (!R_mminusp(STACK_1))
  903.         # e>=0.
  904.         { var reg1 object y = I_I_ash_I(STACK_2,STACK_1); # (ash m e) bilden
  905.           if (R_minusp(STACK_0)) { y = I_minus_I(y); } # Bei s<0: y := (- y)
  906.           skipSTACK(3); return y;
  907.         }
  908.       # e<0.
  909.       {var reg1 object m2 = I_I_ash_I(STACK_2,Fixnum_1); # 2*m
  910.        pushSTACK(m2); pushSTACK(I_minus1_plus_I(m2)); # 2*m-1 bilden
  911.        STACK_1 = I_1_plus_I(STACK_1); # 2*m+1 bilden
  912.       }
  913.       # Stackaufbau: -, e, s, 2*m+1, 2*m-1.
  914.       STACK_3 = I_I_ash_I(Fixnum_1,I_1_plus_I(I_minus_I(STACK_3))); # (ash 1 (1+ (- e)))
  915.       # Stackaufbau: -, 2^(1-e), s, 2*m+1, 2*m-1.
  916.       STACK_0 = I_I_to_RT(STACK_0,STACK_3); # (2*m-1)/(2^(1-e)) = a
  917.       STACK_1 = I_I_to_RT(STACK_1,STACK_3); # (2*m+1)/(2^(1-e)) = b
  918.       # Stackaufbau: -, 2^(1-e), s, b, a.
  919.       pushSTACK(Fixnum_0); pushSTACK(Fixnum_1);
  920.       pushSTACK(Fixnum_1); pushSTACK(Fixnum_0);
  921.       # Stackaufbau: -, -, s, b, a, p[i-1], p[i], q[i-1], q[i].
  922.       loop
  923.         { RA_ceiling_I_RA(STACK_4); # c := (ceiling a)
  924.           # Stackaufbau: ..., c, -.
  925.           if (RA_RA_comp(STACK_1,STACK_(5+2))<0) break; # bei c<b Schleifenende
  926.          {var reg1 object k = I_minus1_plus_I(STACK_1); # k = c-1
  927.           skipSTACK(2);
  928.           # "Ziffer" k :
  929.           STACK_7 = k; # k retten
  930.           k = I_I_mal_I(k,STACK_2); # mit p[i] multiplizieren
  931.           k = I_I_plus_I(k,STACK_3); # und p[i-1] addieren
  932.           STACK_3 = STACK_2; STACK_2 = k; # als p[i+1] ablegen
  933.           k = STACK_7;
  934.           k = I_I_mal_I(k,STACK_0); # mit q[i] multiplizieren
  935.           k = I_I_plus_I(k,STACK_1); # und q[i-1] addieren
  936.           STACK_1 = STACK_0; STACK_0 = k; # als q[i+1] ablegen
  937.          }# neues b ausrechnen: b := (/ (- a k))
  938.          {var reg1 object new_b = RA_durch_RA(RA_RA_minus_RA(STACK_4,STACK_7));
  939.           var reg2 object old_b = STACK_5;
  940.           STACK_5 = new_b;
  941.           # neues a ausrechnen: a := (/ (- b k))
  942.           STACK_4 = RA_durch_RA(RA_RA_minus_RA(old_b,STACK_7));
  943.         }}
  944.       # letzte "Ziffer" k=c :
  945.      {var reg1 object q = I_I_mal_I(STACK_1,STACK_(0+2)); # c mit q[i] multiplizieren
  946.       q = I_I_plus_I(q,STACK_(1+2)); # und q[i-1] addieren
  947.       STACK_(0+2) = q; # als letztes q[i] ablegen
  948.      }
  949.      { var reg1 object p = I_I_mal_I(STACK_1,STACK_(2+2)); # c mit p[i] multiplizieren
  950.        p = I_I_plus_I(p,STACK_(3+2)); # und p[i-1] addieren, gibt letztes p[i]
  951.        # Ergebnis ist (s*p[i])/q[i]:
  952.        if (R_mminusp(STACK_(6+2))) { p = I_minus_I(p); } # bei s<0: (- p[i]) statt p[i]
  953.       {var reg2 object q = STACK_(0+2);
  954.        skipSTACK(9+2); # Stack aufrΣumen
  955.        return I_I_to_RA(p,q); # (/ +-p[i] q[i]) bilden
  956.     }}}
  957.  
  958.