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