home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / flo_rest.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  52.2 KB  |  1,279 lines
  1. # restliche Float-Funktionen
  2.  
  3.  
  4. # Macro: verteilt je nach Float-Typ eines Floats x auf 4 Statements.
  5. # floatcase(x, SF_statement,FF_statement,DF_statement,LF_statement);
  6. # x sollte eine Variable sein.
  7.   #define floatcase(obj, SF_statement,FF_statement,DF_statement,LF_statement) \
  8.     { if (!wbit_test(as_oint(obj),float1_bit_o))   \
  9.         if (!wbit_test(as_oint(obj),float2_bit_o)) \
  10.           { SF_statement }                         \
  11.           else                                     \
  12.           { FF_statement }                         \
  13.         else                                       \
  14.         if (!wbit_test(as_oint(obj),float2_bit_o)) \
  15.           { DF_statement }                         \
  16.           else                                     \
  17.           { LF_statement }                         \
  18.     }
  19. # DF_statement darf kein #if enthalten. Daher:
  20.   #ifdef intQsize
  21.     #define ifdef_intQsize(A,B)  A
  22.   #else
  23.     #define ifdef_intQsize(A,B)  B
  24.   #endif
  25.  
  26.  
  27. # Generiert eine Float-Operation F_op_F wie F_minus_F oder F_durch_F
  28.   #define GEN_F_op1(op)  \
  29.     local object CONCAT3(F_,op,_F) PARM1(x,            \
  30.       var reg1 object x)                               \
  31.       { floatcase(x,                                   \
  32.                   { return CONCAT3(SF_,op,_SF) (x); }, \
  33.                   { return CONCAT3(FF_,op,_FF) (x); }, \
  34.                   { return CONCAT3(DF_,op,_DF) (x); }, \
  35.                   { return CONCAT3(LF_,op,_LF) (x); }  \
  36.                  );                                    \
  37.       }
  38.  
  39. # F_minus_F(x) liefert (- x), wo x ein Float ist.
  40. # kann GC auslösen
  41.   local object F_minus_F (object x);
  42.   GEN_F_op1(minus)
  43.  
  44. # F_abs_F(x) liefert (abs x), wo x ein Float ist.
  45. # kann GC auslösen
  46.   local object F_abs_F (object x);
  47.   local object F_abs_F(x)
  48.     var reg1 object x;
  49.     { return (R_minusp(x) ? F_minus_F(x) : x); } # x<0 -> (- x), x>=0 -> x
  50.  
  51. # SF_durch_SF(x) liefert (/ x), wo x ein SF ist.
  52.   #define SF_durch_SF(x)  SF_SF_durch_SF(SF_1,x)
  53.  
  54. # FF_durch_FF(x) liefert (/ x), wo x ein FF ist.
  55. # kann GC auslösen
  56.   #define FF_durch_FF(x)  FF_FF_durch_FF(FF_1,x)
  57.  
  58. # DF_durch_DF(x) liefert (/ x), wo x ein DF ist.
  59. # kann GC auslösen
  60.   #define DF_durch_DF(x)  DF_DF_durch_DF(DF_1,x)
  61.  
  62. # LF_durch_LF(x) liefert (/ x), wo x ein LF ist.
  63. # kann GC auslösen
  64.   local object LF_durch_LF (object x);
  65.   local object LF_durch_LF(x)
  66.     var reg1 object x;
  67.     { pushSTACK(x);
  68.       encode_LF1(TheLfloat(x)->len, x=);
  69.       return LF_LF_durch_LF(x,popSTACK());
  70.     }
  71.  
  72. # F_durch_F(x) liefert (/ x), wo x ein Float ist.
  73. # kann GC auslösen
  74.   local object F_durch_F (object x);
  75.   GEN_F_op1(durch)
  76.  
  77. # F_sqrt_F(x) liefert (sqrt x), wo x ein Float >=0 ist.
  78. # kann GC auslösen
  79.   local object F_sqrt_F (object x);
  80.   GEN_F_op1(sqrt)
  81.  
  82.  
  83. # Generiert eine Float-Funktion mit zwei Argumenten.
  84. # Die Funktion wird erst ausgeführt, nachdem beide Argumente auf dasselbe
  85. # Float-Format (das längere von beiden) gebracht wurden; danach werden die
  86. # r (=0,1 oder 2) Ergebnisse auf das kürzere der beiden Float-Formate
  87. # gebracht.
  88. # s (=0 oder 1): Da LF_LF_comp Long-Floats verschiedener Längen verarbeitet,
  89. # braucht bei s=1 ein SF, FF oder DF nur zu einem LF der Länge LF_minlen
  90. # gemacht zu werden.
  91.   #define GEN_F_op2(arg1,arg2,SF_op,FF_op,DF_op,LF_op,r,s,RETURN)  \
  92.     { floatcase(arg1,                                                                                                  \
  93.       /* arg1 SF */ { floatcase(arg2,                                                                                  \
  94.                       /* arg2 SF */ { RETURN SF_op(arg1,arg2); },                                                      \
  95.                       /* arg2 FF */ { pushSTACK(arg2); arg1 = SF_to_FF(arg1); arg2 = popSTACK();                       \
  96.                                       RETURN CONCAT(TO_F_,r) (FF_op(arg1,arg2),FF_to_SF);                              \
  97.                                     },                                                                                 \
  98.                       /* arg2 DF */ { pushSTACK(arg2); arg1 = SF_to_DF(arg1); arg2 = popSTACK();                       \
  99.                                       RETURN CONCAT(TO_F_,r) (DF_op(arg1,arg2),DF_to_SF);                              \
  100.                                     },                                                                                 \
  101.                       /* arg2 LF */ { pushSTACK(arg2); arg1 = SF_to_LF(arg1,CONCAT(LFlen,s)(arg2)); arg2 = popSTACK(); \
  102.                                       RETURN CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_to_SF);                              \
  103.                                     }                                                                                  \
  104.                                );                                                                                      \
  105.                     },                                                                                                 \
  106.       /* arg1 FF */ { floatcase(arg2,                                                                                  \
  107.                       /* arg2 SF */ { pushSTACK(arg1); arg2 = SF_to_FF(arg2); arg1 = popSTACK();                       \
  108.                                       RETURN CONCAT(TO_F_,r) (FF_op(arg1,arg2),FF_to_SF);                              \
  109.                                     },                                                                                 \
  110.                       /* arg2 FF */ { RETURN FF_op(arg1,arg2); },                                                      \
  111.                       /* arg2 DF */ { pushSTACK(arg2); arg1 = FF_to_DF(arg1); arg2 = popSTACK();                       \
  112.                                       RETURN CONCAT(TO_F_,r) (DF_op(arg1,arg2),DF_to_FF);                              \
  113.                                     },                                                                                 \
  114.                       /* arg2 LF */ { pushSTACK(arg2); arg1 = FF_to_LF(arg1,CONCAT(LFlen,s)(arg2)); arg2 = popSTACK(); \
  115.                                       RETURN CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_to_FF);                              \
  116.                                     }                                                                                  \
  117.                                );                                                                                      \
  118.                     },                                                                                                 \
  119.       /* arg1 DF */ { floatcase(arg2,                                                                                  \
  120.                       /* arg2 SF */ { pushSTACK(arg1); arg2 = SF_to_DF(arg2); arg1 = popSTACK();                       \
  121.                                       RETURN CONCAT(TO_F_,r) (DF_op(arg1,arg2),DF_to_SF);                              \
  122.                                     },                                                                                 \
  123.                       /* arg2 FF */ { pushSTACK(arg1); arg2 = FF_to_DF(arg2); arg1 = popSTACK();                       \
  124.                                       RETURN CONCAT(TO_F_,r) (DF_op(arg1,arg2),DF_to_FF);                              \
  125.                                     },                                                                                 \
  126.                       /* arg2 DF */ { RETURN DF_op(arg1,arg2); },                                                      \
  127.                       /* arg2 LF */ { pushSTACK(arg2); arg1 = DF_to_LF(arg1,CONCAT(LFlen,s)(arg2)); arg2 = popSTACK(); \
  128.                                       RETURN CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_to_DF);                              \
  129.                                     }                                                                                  \
  130.                                );                                                                                      \
  131.                     },                                                                                                 \
  132.       /* arg1 LF */ { floatcase(arg2,                                                                                  \
  133.                       /* arg2 SF */ { pushSTACK(arg1); arg2 = SF_to_LF(arg2,CONCAT(LFlen,s)(arg1)); arg1 = popSTACK(); \
  134.                                       RETURN CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_to_SF);                              \
  135.                                     },                                                                                 \
  136.                       /* arg2 FF */ { pushSTACK(arg1); arg2 = FF_to_LF(arg2,CONCAT(LFlen,s)(arg1)); arg1 = popSTACK(); \
  137.                                       RETURN CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_to_FF);                              \
  138.                                     },                                                                                 \
  139.                       /* arg2 DF */ { pushSTACK(arg1); arg2 = DF_to_LF(arg2,CONCAT(LFlen,s)(arg1)); arg1 = popSTACK(); \
  140.                                       RETURN CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_to_DF);                              \
  141.                                     },                                                                                 \
  142.                       /* arg2 LF */ { CONCAT(GEN_LF_op2_,s)(arg1,arg2,LF_op,r,_EMA_ RETURN); }                         \
  143.                                );                                                                                      \
  144.                     }                                                                                                  \
  145.                );                                                                                                      \
  146.     }
  147.   # Hilfmacro, wenn arg1 und arg2 beide LF sind:
  148.   #define GEN_LF_op2_0(arg1,arg2,LF_op,r,ergebnis_zuweisung)  \
  149.     { var reg3 uintC len1 = TheLfloat(arg1)->len;                                \
  150.       var reg4 uintC len2 = TheLfloat(arg2)->len;                                \
  151.       if (len1==len2) # gleich -> direkt ausführen                               \
  152.         { ergebnis_zuweisung LF_op(arg1,arg2); }                                 \
  153.       elif (len1>len2) # -> arg2 auf die Länge von arg1 bringen                  \
  154.         { pushSTACK(arg1); arg2 = LF_extend_LF(arg2,len1); arg1 = popSTACK();    \
  155.           ergebnis_zuweisung CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_shorten_LF_2); \
  156.         }                                                                        \
  157.       else # (len1<len2) -> arg1 auf die Länge von arg2 bringen                  \
  158.         { pushSTACK(arg2); arg1 = LF_extend_LF(arg1,len2); arg2 = popSTACK();    \
  159.           ergebnis_zuweisung CONCAT(TO_F_,r) (LF_op(arg1,arg2),LF_shorten_LF_1); \
  160.         }                                                                        \
  161.     }
  162.   #define GEN_LF_op2_1(arg1,arg2,LF_op,r,ergebnis_zuweisung)  \
  163.     ergebnis_zuweisung LF_op(arg1,arg2);
  164.   #define LF_shorten_LF_1(arg)  LF_shorten_LF(arg,len1)
  165.   #define LF_shorten_LF_2(arg)  LF_shorten_LF(arg,len2)
  166.   # Hilfsmacro zum Besorgen der Ziel-Länge für Konversion SF,FF,DF -> LF :
  167.   #define LFlen0(arg)  TheLfloat(arg)->len
  168.   #define LFlen1(arg)  LF_minlen
  169.   # Hilfsmacro zur Konversion des Ergebnisses zurück zum kürzeren Format:
  170.   #define TO_F_0(erg,to)  erg
  171.   #define TO_F_1(erg,to)  to(erg)
  172.   #define TO_F_2(erg,to)  \
  173.     erg; # Operation durchführen                 \
  174.     { STACK_1 = to(STACK_1); # 1. Wert umwandeln \
  175.       STACK_0 = to(STACK_0); # 2. Wert umwandeln \
  176.     }
  177.  
  178. # F_F_plus_F(x,y) liefert (+ x y), wo x und y Floats sind.
  179. # kann GC auslösen
  180.   local object F_F_plus_F (object x, object y);
  181.   local object F_F_plus_F(x,y)
  182.     var reg1 object x;
  183.     var reg2 object y;
  184.     { GEN_F_op2(x,y,SF_SF_plus_SF,FF_FF_plus_FF,DF_DF_plus_DF,LF_LF_plus_LF,1,0,return) }
  185.  
  186. # F_F_minus_F(x,y) liefert (- x y), wo x und y Floats sind.
  187. # kann GC auslösen
  188.   local object F_F_minus_F (object x, object y);
  189.   local object F_F_minus_F(x,y)
  190.     var reg1 object x;
  191.     var reg2 object y;
  192.     { GEN_F_op2(x,y,SF_SF_minus_SF,FF_FF_minus_FF,DF_DF_minus_DF,LF_LF_minus_LF,1,0,return) }
  193.  
  194. # F_F_mal_F(x,y) liefert (* x y), wo x und y Floats sind.
  195. # kann GC auslösen
  196.   local object F_F_mal_F (object x, object y);
  197.   local object F_F_mal_F(x,y)
  198.     var reg1 object x;
  199.     var reg2 object y;
  200.     { GEN_F_op2(x,y,SF_SF_mal_SF,FF_FF_mal_FF,DF_DF_mal_DF,LF_LF_mal_LF,1,0,return) }
  201.  
  202. # F_F_durch_F(x,y) liefert (/ x y), wo x und y Floats sind.
  203. # kann GC auslösen
  204.   local object F_F_durch_F (object x, object y);
  205.   local object F_F_durch_F(x,y)
  206.     var reg1 object x;
  207.     var reg2 object y;
  208.     { GEN_F_op2(x,y,SF_SF_durch_SF,FF_FF_durch_FF,DF_DF_durch_DF,LF_LF_durch_LF,1,0,return) }
  209.  
  210. # F_F_comp(x,y) vergleicht zwei Floats x und y.
  211. # Ergebnis: 0 falls x=y, +1 falls x>y, -1 falls x<y.
  212. # kann GC auslösen
  213.   local signean F_F_comp (object x, object y);
  214.   local signean F_F_comp(x,y)
  215.     var reg1 object x;
  216.     var reg2 object y;
  217.     { GEN_F_op2(x,y,SF_SF_comp,FF_FF_comp,DF_DF_comp,LF_LF_comp,0,1,return) }
  218.  
  219.  
  220. # Generiert eine Funktion wie SF_ffloor_SF
  221. # Methode: x<0 -> von der 0 wegrunden, sonst zur 0 hinrunden.
  222.   #define GEN_ffloor(F)  \
  223.     local object CONCAT3(F,_ffloor_,F) PARM1(x, \
  224.       var reg1 object x)                        \
  225.       { return (R_minusp(x)                     \
  226.                 ? CONCAT3(F,_futruncate_,F) (x) \
  227.                 : CONCAT3(F,_ftruncate_,F) (x)  \
  228.                );                               \
  229.       }
  230.  
  231. # SF_ffloor_SF(x) liefert (ffloor x), wo x ein SF ist.
  232.   local object SF_ffloor_SF (object x);
  233.   GEN_ffloor(SF)
  234.  
  235. # FF_ffloor_FF(x) liefert (ffloor x), wo x ein FF ist.
  236. # kann GC auslösen
  237.   local object FF_ffloor_FF (object x);
  238.   GEN_ffloor(FF)
  239.  
  240. # DF_ffloor_DF(x) liefert (ffloor x), wo x ein DF ist.
  241. # kann GC auslösen
  242.   local object DF_ffloor_DF (object x);
  243.   GEN_ffloor(DF)
  244.  
  245. # LF_ffloor_LF(x) liefert (ffloor x), wo x ein LF ist.
  246. # kann GC auslösen
  247.   local object LF_ffloor_LF (object x);
  248.   GEN_ffloor(LF)
  249.  
  250. # Generiert eine Funktion wie SF_fceiling_SF
  251. # Methode: x<0 -> zur 0 hinrunden, sonst von der 0 wegrunden.
  252.   #define GEN_fceiling(F)  \
  253.     local object CONCAT3(F,_fceiling_,F) PARM1(x, \
  254.       var reg1 object x)                          \
  255.       { return (R_minusp(x)                       \
  256.                 ? CONCAT3(F,_ftruncate_,F) (x)    \
  257.                 : CONCAT3(F,_futruncate_,F) (x)   \
  258.                );                                 \
  259.       }
  260.  
  261. # SF_fceiling_SF(x) liefert (fceiling x), wo x ein SF ist.
  262.   local object SF_fceiling_SF (object x);
  263.   GEN_fceiling(SF)
  264.  
  265. # FF_fceiling_FF(x) liefert (fceiling x), wo x ein FF ist.
  266. # kann GC auslösen
  267.   local object FF_fceiling_FF (object x);
  268.   GEN_fceiling(FF)
  269.  
  270. # DF_fceiling_DF(x) liefert (fceiling x), wo x ein DF ist.
  271. # kann GC auslösen
  272.   local object DF_fceiling_DF (object x);
  273.   GEN_fceiling(DF)
  274.  
  275. # LF_fceiling_LF(x) liefert (fceiling x), wo x ein LF ist.
  276. # kann GC auslösen
  277.   local object LF_fceiling_LF (object x);
  278.   GEN_fceiling(LF)
  279.  
  280.  
  281. # Generiert eine Funktion wie SF_fround_SF_SF
  282.   #define GEN_fround(F,rounding)  \
  283.     local void CONCAT7(F,_f,rounding,_,F,_,F) PARM1(x,                                \
  284.       var reg1 object x)                                                              \
  285.       { pushSTACK(x);                                                                 \
  286.        {var reg2 object y = CONCAT5(F,_f,rounding,_,F) (x); # ganzer Anteil von x     \
  287.         x = STACK_0; STACK_0 = y;                                                     \
  288.         pushSTACK( CONCAT5(F,_,F,_minus_,F) (x,y) ); # x-y = gebrochener Anteil von x \
  289.       }}
  290.  
  291. # SF_ffloor_SF_SF(x) liefert (ffloor x), wo x ein SF ist.
  292. # Beide Werte in den Stack.
  293.   local void SF_ffloor_SF_SF (object x);
  294.   GEN_fround(SF,floor)
  295.  
  296. # FF_ffloor_FF_FF(x) liefert (ffloor x), wo x ein FF ist.
  297. # Beide Werte in den Stack.
  298. # kann GC auslösen
  299.   local void FF_ffloor_FF_FF (object x);
  300.   GEN_fround(FF,floor)
  301.  
  302. # DF_ffloor_DF_DF(x) liefert (ffloor x), wo x ein DF ist.
  303. # Beide Werte in den Stack.
  304. # kann GC auslösen
  305.   local void DF_ffloor_DF_DF (object x);
  306.   GEN_fround(DF,floor)
  307.  
  308. # LF_ffloor_LF_LF(x) liefert (ffloor x), wo x ein LF ist.
  309. # Beide Werte in den Stack.
  310. # kann GC auslösen
  311.   local void LF_ffloor_LF_LF (object x);
  312.   GEN_fround(LF,floor)
  313.  
  314. # SF_fceiling_SF_SF(x) liefert (fceiling x), wo x ein SF ist.
  315. # Beide Werte in den Stack.
  316.   local void SF_fceiling_SF_SF (object x);
  317.   GEN_fround(SF,ceiling)
  318.  
  319. # FF_fceiling_FF_FF(x) liefert (fceiling x), wo x ein FF ist.
  320. # Beide Werte in den Stack.
  321. # kann GC auslösen
  322.   local void FF_fceiling_FF_FF (object x);
  323.   GEN_fround(FF,ceiling)
  324.  
  325. # DF_fceiling_DF_DF(x) liefert (fceiling x), wo x ein DF ist.
  326. # Beide Werte in den Stack.
  327. # kann GC auslösen
  328.   local void DF_fceiling_DF_DF (object x);
  329.   GEN_fround(DF,ceiling)
  330.  
  331. # LF_fceiling_LF_LF(x) liefert (fceiling x), wo x ein LF ist.
  332. # Beide Werte in den Stack.
  333. # kann GC auslösen
  334.   local void LF_fceiling_LF_LF (object x);
  335.   GEN_fround(LF,ceiling)
  336.  
  337. # SF_ftruncate_SF_SF(x) liefert (ftruncate x), wo x ein SF ist.
  338. # Beide Werte in den Stack.
  339.   local void SF_ftruncate_SF_SF (object x);
  340.   GEN_fround(SF,truncate)
  341.  
  342. # FF_ftruncate_FF_FF(x) liefert (ftruncate x), wo x ein FF ist.
  343. # Beide Werte in den Stack.
  344. # kann GC auslösen
  345.   local void FF_ftruncate_FF_FF (object x);
  346.   GEN_fround(FF,truncate)
  347.  
  348. # DF_ftruncate_DF_DF(x) liefert (ftruncate x), wo x ein DF ist.
  349. # Beide Werte in den Stack.
  350. # kann GC auslösen
  351.   local void DF_ftruncate_DF_DF (object x);
  352.   GEN_fround(DF,truncate)
  353.  
  354. # LF_ftruncate_LF_LF(x) liefert (ftruncate x), wo x ein LF ist.
  355. # Beide Werte in den Stack.
  356. # kann GC auslösen
  357.   local void LF_ftruncate_LF_LF (object x);
  358.   GEN_fround(LF,truncate)
  359.  
  360. # SF_fround_SF_SF(x) liefert (fround x), wo x ein SF ist.
  361. # Beide Werte in den Stack.
  362.   local void SF_fround_SF_SF (object x);
  363.   GEN_fround(SF,round)
  364.  
  365. # FF_fround_FF_FF(x) liefert (fround x), wo x ein FF ist.
  366. # Beide Werte in den Stack.
  367. # kann GC auslösen
  368.   local void FF_fround_FF_FF (object x);
  369.   GEN_fround(FF,round)
  370.  
  371. # DF_fround_DF_DF(x) liefert (fround x), wo x ein DF ist.
  372. # Beide Werte in den Stack.
  373. # kann GC auslösen
  374.   local void DF_fround_DF_DF (object x);
  375.   GEN_fround(DF,round)
  376.  
  377. # LF_fround_LF_LF(x) liefert (fround x), wo x ein LF ist.
  378. # Beide Werte in den Stack.
  379. # kann GC auslösen
  380.   local void LF_fround_LF_LF (object x);
  381.   GEN_fround(LF,round)
  382.  
  383.  
  384. # Generiert eine Funktion wie SF_round_I_SF
  385.   #define GEN_round(F,rounding)  \
  386.     local void CONCAT7(F,_,rounding,_,I,_,F) PARM1(x,                      \
  387.       var reg1 object x)                                                   \
  388.       { CONCAT7(F,_f,rounding,_,F,_,F) (x);                                \
  389.         STACK_1 = CONCAT3(F,_to_,I) (STACK_1); # ganzer Anteil als Integer \
  390.       }
  391.  
  392. # SF_floor_I_SF(x) liefert (floor x), wo x ein SF ist.
  393. # Beide Werte in den Stack.
  394.   local void SF_floor_I_SF (object x);
  395.   GEN_round(SF,floor)
  396.  
  397. # FF_floor_I_FF(x) liefert (floor x), wo x ein FF ist.
  398. # Beide Werte in den Stack.
  399. # kann GC auslösen
  400.   local void FF_floor_I_FF (object x);
  401.   GEN_round(FF,floor)
  402.  
  403. # DF_floor_I_DF(x) liefert (floor x), wo x ein DF ist.
  404. # Beide Werte in den Stack.
  405. # kann GC auslösen
  406.   local void DF_floor_I_DF (object x);
  407.   GEN_round(DF,floor)
  408.  
  409. # LF_floor_I_LF(x) liefert (floor x), wo x ein LF ist.
  410. # Beide Werte in den Stack.
  411. # kann GC auslösen
  412.   local void LF_floor_I_LF (object x);
  413.   GEN_round(LF,floor)
  414.  
  415. # SF_ceiling_I_SF(x) liefert (ceiling x), wo x ein SF ist.
  416. # Beide Werte in den Stack.
  417.   local void SF_ceiling_I_SF (object x);
  418.   GEN_round(SF,ceiling)
  419.  
  420. # FF_ceiling_I_FF(x) liefert (ceiling x), wo x ein FF ist.
  421. # Beide Werte in den Stack.
  422. # kann GC auslösen
  423.   local void FF_ceiling_I_FF (object x);
  424.   GEN_round(FF,ceiling)
  425.  
  426. # DF_ceiling_I_DF(x) liefert (ceiling x), wo x ein DF ist.
  427. # Beide Werte in den Stack.
  428. # kann GC auslösen
  429.   local void DF_ceiling_I_DF (object x);
  430.   GEN_round(DF,ceiling)
  431.  
  432. # LF_ceiling_I_LF(x) liefert (ceiling x), wo x ein LF ist.
  433. # Beide Werte in den Stack.
  434. # kann GC auslösen
  435.   local void LF_ceiling_I_LF (object x);
  436.   GEN_round(LF,ceiling)
  437.  
  438. # SF_truncate_I_SF(x) liefert (truncate x), wo x ein SF ist.
  439. # Beide Werte in den Stack.
  440.   local void SF_truncate_I_SF (object x);
  441.   GEN_round(SF,truncate)
  442.  
  443. # FF_truncate_I_FF(x) liefert (truncate x), wo x ein FF ist.
  444. # Beide Werte in den Stack.
  445. # kann GC auslösen
  446.   local void FF_truncate_I_FF (object x);
  447.   GEN_round(FF,truncate)
  448.  
  449. # DF_truncate_I_DF(x) liefert (truncate x), wo x ein DF ist.
  450. # Beide Werte in den Stack.
  451. # kann GC auslösen
  452.   local void DF_truncate_I_DF (object x);
  453.   GEN_round(DF,truncate)
  454.  
  455. # LF_truncate_I_LF(x) liefert (truncate x), wo x ein LF ist.
  456. # Beide Werte in den Stack.
  457. # kann GC auslösen
  458.   local void LF_truncate_I_LF (object x);
  459.   GEN_round(LF,truncate)
  460.  
  461. # SF_round_I_SF(x) liefert (round x), wo x ein SF ist.
  462. # Beide Werte in den Stack.
  463.   local void SF_round_I_SF (object x);
  464.   GEN_round(SF,round)
  465.  
  466. # FF_round_I_FF(x) liefert (round x), wo x ein FF ist.
  467. # Beide Werte in den Stack.
  468. # kann GC auslösen
  469.   local void FF_round_I_FF (object x);
  470.   GEN_round(FF,round)
  471.  
  472. # DF_round_I_DF(x) liefert (round x), wo x ein DF ist.
  473. # Beide Werte in den Stack.
  474. # kann GC auslösen
  475.   local void DF_round_I_DF (object x);
  476.   GEN_round(DF,round)
  477.  
  478. # LF_round_I_LF(x) liefert (round x), wo x ein LF ist.
  479. # Beide Werte in den Stack.
  480. # kann GC auslösen
  481.   local void LF_round_I_LF (object x);
  482.   GEN_round(LF,round)
  483.  
  484.  
  485. # Generiert eine Funktion wie F_fround_F_F
  486.   #define GEN_F_fround(rounding)  \
  487.     local void CONCAT3(F_f,rounding,_F_F) PARM1(x,                \
  488.       var reg1 object x)                                          \
  489.       { floatcase(x,                                              \
  490.                   { CONCAT3(SF_f,rounding,_SF_SF) (x); return; }, \
  491.                   { CONCAT3(FF_f,rounding,_FF_FF) (x); return; }, \
  492.                   { CONCAT3(DF_f,rounding,_DF_DF) (x); return; }, \
  493.                   { CONCAT3(LF_f,rounding,_LF_LF) (x); return; }  \
  494.                  );                                               \
  495.       }
  496.  
  497. # F_ffloor_F_F(x) liefert (ffloor x), wo x ein Float ist.
  498. # Beide Werte in den Stack.
  499. # kann GC auslösen
  500.   local void F_ffloor_F_F (object x);
  501.   GEN_F_fround(floor)
  502.  
  503. # F_fceiling_F_F(x) liefert (fceiling x), wo x ein Float ist.
  504. # Beide Werte in den Stack.
  505. # kann GC auslösen
  506.   local void F_fceiling_F_F (object x);
  507.   GEN_F_fround(ceiling)
  508.  
  509. # F_ftruncate_F_F(x) liefert (ftruncate x), wo x ein Float ist.
  510. # Beide Werte in den Stack.
  511. # kann GC auslösen
  512.   local void F_ftruncate_F_F (object x);
  513.   GEN_F_fround(truncate)
  514.  
  515. # F_fround_F_F(x) liefert (fround x), wo x ein Float ist.
  516. # Beide Werte in den Stack.
  517. # kann GC auslösen
  518.   local void F_fround_F_F (object x);
  519.   GEN_F_fround(round)
  520.  
  521.  
  522. # Generiert eine Funktion wie F_round_I_F
  523.   #define GEN_F_round(rounding)  \
  524.     local void CONCAT3(F_,rounding,_I_F) PARM1(x,               \
  525.       var reg1 object x)                                        \
  526.       { floatcase(x,                                            \
  527.                   { CONCAT3(SF_,rounding,_I_SF) (x); return; }, \
  528.                   { CONCAT3(FF_,rounding,_I_FF) (x); return; }, \
  529.                   { CONCAT3(DF_,rounding,_I_DF) (x); return; }, \
  530.                   { CONCAT3(LF_,rounding,_I_LF) (x); return; }  \
  531.                  );                                             \
  532.       }
  533.  
  534. # F_floor_I_F(x) liefert (floor x), wo x ein Float ist.
  535. # Beide Werte in den Stack.
  536. # kann GC auslösen
  537.   local void F_floor_I_F (object x);
  538.   GEN_F_round(floor)
  539.  
  540. # F_ceiling_I_F(x) liefert (ceiling x), wo x ein Float ist.
  541. # Beide Werte in den Stack.
  542. # kann GC auslösen
  543.   local void F_ceiling_I_F (object x);
  544.   GEN_F_round(ceiling)
  545.  
  546. # F_truncate_I_F(x) liefert (truncate x), wo x ein Float ist.
  547. # Beide Werte in den Stack.
  548. # kann GC auslösen
  549.   local void F_truncate_I_F (object x);
  550.   GEN_F_round(truncate)
  551.  
  552. # F_round_I_F(x) liefert (round x), wo x ein Float ist.
  553. # Beide Werte in den Stack.
  554. # kann GC auslösen
  555.   local void F_round_I_F (object x);
  556.   GEN_F_round(round)
  557.  
  558.  
  559. # Generiert eine Funktion wie F_F_floor_I_F
  560.   #define GEN_F_F_round(rounding)  \
  561.     # Liefert ganzzahligen Quotienten und Rest \
  562.     # einer Division reeller Zahlen.           \
  563.     # (q,r) := (rounding x y)                  \
  564.     # F_F_rounding_I_F(x,y);                   \
  565.     # > x,y: reelle Zahlen                     \
  566.     # < STACK_1: Quotient q, ein Integer       \
  567.     # < STACK_0: Rest r, eine reelle Zahl      \
  568.     # Erniedrigt STACK um 2                    \
  569.     # kann GC auslösen                         \
  570.     # Methode:                                               \
  571.     # F_rounding_I_F(x/y) -> (q,r). Liefere q und x-y*q=y*r. \
  572.     local void CONCAT3(F_F_,rounding,_I_F) PARM2(x,y,        \
  573.       var reg2 object x,                                     \
  574.       var reg1 object y)                                     \
  575.       { pushSTACK(y);                                        \
  576.         CONCAT3(F_,rounding,_I_F) (F_F_durch_F(x,y)); # ganzzahligen Anteil des Quotienten bilden \
  577.         y = STACK_2; STACK_2 = STACK_1;                      \
  578.         STACK_1 = F_F_mal_F(y,STACK_0); # Nachkommateil mit y multiplizieren \
  579.         skipSTACK(1);                                        \
  580.       }
  581.  
  582. # F_F_floor_I_F(x,y) liefert (floor x y), wo x und y Floats sind.
  583. # Beide Werte in den Stack.
  584. # kann GC auslösen
  585.   local void F_F_floor_I_F (object x, object y);
  586.   GEN_F_F_round(floor)
  587.  
  588. #if 0 # unbenutzt
  589.  
  590. # F_F_ceiling_I_F(x,y) liefert (ceiling x y), wo x und y Floats sind.
  591. # Beide Werte in den Stack.
  592. # kann GC auslösen
  593.   local void F_F_ceiling_I_F (object x, object y);
  594.   GEN_F_F_round(ceiling)
  595.  
  596. # F_F_truncate_I_F(x,y) liefert (truncate x y), wo x und y Floats sind.
  597. # Beide Werte in den Stack.
  598. # kann GC auslösen
  599.   local void F_F_truncate_I_F (object x, object y);
  600.   GEN_F_F_round(truncate)
  601.  
  602. # F_F_round_I_F(x,y) liefert (round x y), wo x und y Floats sind.
  603. # Beide Werte in den Stack.
  604. # kann GC auslösen
  605.   local void F_F_round_I_F (object x, object y);
  606.   GEN_F_F_round(round)
  607.  
  608. #endif
  609.  
  610.  
  611. # F_to_SF(x) wandelt ein Float x in ein Short-Float um und rundet dabei.
  612.   local object F_to_SF (object x);
  613.   local object F_to_SF(x)
  614.     var reg1 object x;
  615.     { floatcase(x,
  616.                 { return x; },
  617.                 { return FF_to_SF(x); },
  618.                 { return DF_to_SF(x); },
  619.                 { return LF_to_SF(x); }
  620.                );
  621.     }
  622.  
  623. # F_to_FF(x) wandelt ein Float x in ein Single-Float um und rundet dabei.
  624. # kann GC auslösen
  625.   local object F_to_FF (object x);
  626.   local object F_to_FF(x)
  627.     var reg1 object x;
  628.     { floatcase(x,
  629.                 { return SF_to_FF(x); },
  630.                 { return x; },
  631.                 { return DF_to_FF(x); },
  632.                 { return LF_to_FF(x); }
  633.                );
  634.     }
  635.  
  636. # F_to_DF(x) wandelt ein Float x in ein Double-Float um und rundet dabei.
  637. # kann GC auslösen
  638.   local object F_to_DF (object x);
  639.   local object F_to_DF(x)
  640.     var reg1 object x;
  641.     { floatcase(x,
  642.                 { return SF_to_DF(x); },
  643.                 { return FF_to_DF(x); },
  644.                 { return x; },
  645.                 { return LF_to_DF(x); }
  646.                );
  647.     }
  648.  
  649. # F_to_LF(x,len) wandelt ein Float x in ein Long-Float mit len Digits um
  650. # und rundet dabei.
  651. # > uintC len: gewünschte Anzahl Digits, >=LF_minlen
  652. # kann GC auslösen
  653.   local object F_to_LF (object x, uintC len);
  654.   local object F_to_LF(x,len)
  655.     var reg1 object x;
  656.     var reg2 uintC len;
  657.     { floatcase(x,
  658.                 { return SF_to_LF(x,len); },
  659.                 { return FF_to_LF(x,len); },
  660.                 { return DF_to_LF(x,len); },
  661.                 { return LF_to_LF(x,len); }
  662.                );
  663.     }
  664.  
  665. # F_F_float_F(x,y) wandelt ein Float x in das Float-Format des Floats y um
  666. # und rundet dabei nötigenfalls.
  667. # > x,y: Floats
  668. # < ergebnis: (float x y)
  669. # kann GC auslösen
  670.   local object F_F_float_F (object x, object y);
  671.   local object F_F_float_F(x,y)
  672.     var reg2 object x;
  673.     var reg1 object y;
  674.     { floatcase(y,
  675.                 { return F_to_SF(x); },
  676.                 { return F_to_FF(x); },
  677.                 { return F_to_DF(x); },
  678.                 { return F_to_LF(x,TheLfloat(y)->len); }
  679.                );
  680.     }
  681.  
  682.  
  683. # Vergrößert eine Long-Float-Länge n, so daß aus d = intDsize*n
  684. # mindestens d+sqrt(d)+2 wird.
  685. # Methode bei intDsize=16:
  686. # n -> n+1 für n<=12 wegen 16n+sqrt(16n)+2 < 16(n+1)
  687. # n -> n+2 für n<=56 wegen 16n+sqrt(16n)+2 < 16(n+2)
  688. # n -> n+4 für n<=240
  689. # n -> n+8 für n<=992
  690. # n -> n+16 für n<=4032
  691. # n -> n+32 für n<=16256
  692. # n -> n+65 für n<=65535
  693. # Allgemein: intDsize*n + sqrt(intDsize*n) + 2 < intDsize*(n+inc)
  694. # <==>       sqrt(intDsize*n) + 2 < intDsize*inc
  695. # <==>       sqrt(intDsize*n) < intDsize*inc - 2
  696. # <==>       intDsize*n < intDsize^2*inc^2 - 4*intDsize*inc + 4
  697. # <==>       n <= intDsize*inc^2 - 4*inc
  698.   local uintC lf_len_extend (uintC n);
  699.   local uintC lf_len_extend(n)
  700.     var reg1 uintC n;
  701.     { var reg2 uintC inc =
  702.         #define FITS(n,k)  ((n) <= (uintL)((intDsize*(k)-4)*(k)))
  703.         #define n_max  (uintL)(bitm(intCsize)-1)
  704.         #define TEST(i)  FITS(n_max,1UL<<i) || FITS(n,1UL<<i) ? 1UL<<i :
  705.         TEST(0) TEST(1) TEST(2) TEST(3) TEST(4) TEST(5) TEST(6) TEST(7)
  706.         TEST(8) TEST(9) TEST(10) TEST(11) TEST(12) TEST(13)
  707.         (fehler_LF_toolong(),0);
  708.         #undef TEST
  709.         #undef n_max
  710.         #undef FITS
  711.       if ((n = n+inc) < inc) { fehler_LF_toolong(); }
  712.       return n;
  713.     }
  714.  
  715. # F_extend_F(x) erweitert die Genauigkeit eines Floats x um eine Stufe
  716. # SF -> FF -> DF -> LF(4) -> LF(5) -> LF(6) -> ...
  717. # Ein Float mit d Mantissenbits wird so zu einem Float mit
  718. # mindestens d+sqrt(d)+2 Mantissenbits.
  719. # SF -> FF wegen 17+sqrt(17)+2 = 23.2 < 24
  720. # FF -> DF wegen 24+sqrt(24)+2 = 30.9 < 53
  721. # DF -> LF(4) wegen 53+sqrt(53)+2 = 62.3 < 64
  722. # LF(n) -> LF(n+1) für n<=12 wegen 16n+sqrt(16n)+2 < 16(n+1)
  723. # LF(n) -> LF(n+2) für n<=56 wegen 16n+sqrt(16n)+2 < 16(n+2)
  724. # LF(n) -> LF(n+4) für n<=240
  725. # LF(n) -> LF(n+8) für n<=992
  726. # LF(n) -> LF(n+16) für n<=4032
  727. # LF(n) -> LF(n+32) für n<=16256
  728. # LF(n) -> LF(n+65) für n<=65535
  729. # kann GC auslösen
  730.   local object F_extend_F (object x);
  731.   local object F_extend_F(x)
  732.     var reg1 object x;
  733.     { floatcase(x,
  734.                 { return (SF_mant_len+1<=17 ? SF_to_FF(x) # 17+sqrt(17)+2 = 23.2 < 24
  735.                                             : SF_to_DF(x) # 24+sqrt(24)+2 = 30.9 < 53
  736.                          );
  737.                 },
  738.                 { return FF_to_DF(x); }, # 24+sqrt(24)+2 = 30.9 < 53
  739.                 { return DF_to_LF(x,ceiling(63,intDsize)); }, # 53+sqrt(53)+2 = 62.3 < 63
  740.                 { return LF_extend_LF(x,lf_len_extend(TheLfloat(x)->len)); }
  741.                );
  742.     }
  743.  
  744.  
  745. # F_decode_float_F_I_F(x) liefert zu einem Float x:
  746. # (decode-float x), alle drei Werte in den Stack.
  747. # x = 0.0 liefert (0.0, 0, 1.0).
  748. # x = (-1)^s * 2^e * m liefert ((-1)^0 * 2^0 * m, e als Integer, (-1)^s).
  749. # kann GC auslösen
  750.   local void F_decode_float_F_I_F (object x);
  751.   local void F_decode_float_F_I_F(x)
  752.     var reg1 object x;
  753.     { floatcase(x,
  754.       /* x SF */ { # x entpacken:
  755.                    var reg4 signean sign;
  756.                    var reg3 sintWL exp;
  757.                    var reg2 uint32 mant;
  758.                    SF_decode(x, { pushSTACK(SF_0); pushSTACK(Fixnum_0); pushSTACK(SF_1); return; },
  759.                                 sign=,exp=,mant=
  760.                             );
  761.                    encode_SF(0,0,mant, x=); pushSTACK(x); # (-1)^0 * 2^0 * m erzeugen
  762.                    pushSTACK(L_to_FN((sintL)exp)); # e als Fixnum
  763.                    encode_SF(sign,1,bit(SF_mant_len), x=); pushSTACK(x); # (-1)^s erzeugen
  764.                    return;
  765.                  },
  766.       /* x FF */ { # x entpacken:
  767.                    var reg4 signean sign;
  768.                    var reg3 sintWL exp;
  769.                    var reg2 uint32 mant;
  770.                    FF_decode(x, { pushSTACK(FF_0); pushSTACK(Fixnum_0); pushSTACK(FF_1); return; },
  771.                                 sign=,exp=,mant=
  772.                             );
  773.                    encode_FF(0,0,mant, x=); pushSTACK(x); # (-1)^0 * 2^0 * m erzeugen
  774.                    pushSTACK(L_to_FN((sintL)exp)); # e als Fixnum
  775.                    encode_FF(sign,1,bit(FF_mant_len), x=); pushSTACK(x); # (-1)^s erzeugen
  776.                    return;
  777.                  },
  778.       /* x DF */ { # x entpacken:
  779.                    var reg4 signean sign;
  780.                    var reg3 sintWL exp;
  781.                    ifdef_intQsize(
  782.                      { var reg2 uint64 mant;
  783.                        DF_decode(x, { pushSTACK(DF_0); pushSTACK(Fixnum_0); pushSTACK(DF_1); return; },
  784.                                     sign=,exp=,mant=
  785.                                 );
  786.                        encode_DF(0,0,mant, x=); pushSTACK(x); # (-1)^0 * 2^0 * m erzeugen
  787.                        pushSTACK(L_to_FN((sintL)exp)); # e als Fixnum
  788.                        encode_DF(sign,1,bit(DF_mant_len), x=); pushSTACK(x); # (-1)^s erzeugen
  789.                      },
  790.                      { var reg2 uint32 manthi;
  791.                        var reg2 uint32 mantlo;
  792.                        DF_decode2(x, { pushSTACK(DF_0); pushSTACK(Fixnum_0); pushSTACK(DF_1); return; },
  793.                                      sign=,exp=,manthi=,mantlo=
  794.                                 );
  795.                        encode2_DF(0,0,manthi,mantlo, x=); pushSTACK(x); # (-1)^0 * 2^0 * m erzeugen
  796.                        pushSTACK(L_to_FN((sintL)exp)); # e als Fixnum
  797.                        encode2_DF(sign,1,bit(DF_mant_len-32),0, x=); pushSTACK(x); # (-1)^s erzeugen
  798.                      });
  799.                    return;
  800.                  },
  801.       /* x LF */ { # x entpacken:
  802.                    var reg4 signean sign;
  803.                    var reg3 sintL exp;
  804.                    var reg2 uintC mantlen;
  805.                    LF_decode(x, { pushSTACK(x); # 0.0
  806.                                   pushSTACK(Fixnum_0); # 0
  807.                                   encode_LF1(mantlen, x=); pushSTACK(x); # 1.0
  808.                                   return;
  809.                                 },
  810.                              sign=,exp=,_EMA_,mantlen=,_EMA_);
  811.                    pushSTACK(x); # x retten
  812.                    x = allocate_lfloat(mantlen,0+LF_exp_mid,0); # (-1)^0 * 2^0 * m erzeugen
  813.                    copy_loop_up(&TheLfloat(STACK_0)->data[0],&TheLfloat(x)->data[0],mantlen); # m hineinkopieren
  814.                    STACK_0 = x; # 1. Wert fertig
  815.                    pushSTACK(L_to_I(exp)); # e als Fixnum
  816.                    encode_LF1s(sign,mantlen, x=); pushSTACK(x); # (-1)^s erzeugen
  817.                    return;
  818.                  }
  819.                );
  820.     }
  821.  
  822. # F_exponent_L(x) liefert zu einem Float x:
  823. # den Exponenten von (decode-float x).
  824. # x = 0.0 liefert 0.
  825. # x = (-1)^s * 2^e * m liefert e.
  826.   local sintL F_exponent_L (object x);
  827.   local sintL F_exponent_L(x)
  828.     var reg1 object x;
  829.     { floatcase(x,
  830.       /* x SF */ { var reg2 uintBWL uexp = SF_uexp(x);
  831.                    if (uexp==0) { return 0; }
  832.                    return (sintL)(sintWL)((uintWL)uexp - SF_exp_mid);
  833.                  },
  834.       /* x FF */ { var reg2 uintBWL uexp = FF_uexp(ffloat_value(x));
  835.                    if (uexp==0) { return 0; }
  836.                    return (sintL)(sintWL)((uintWL)uexp - FF_exp_mid);
  837.                  },
  838.       /* x DF */ { var reg2 uintWL uexp = DF_uexp(TheDfloat(x)->float_value_semhi);
  839.                    if (uexp==0) { return 0; }
  840.                    return (sintL)(sintWL)(uexp - DF_exp_mid);
  841.                  },
  842.       /* x LF */ { var reg2 uintL uexp = TheLfloat(x)->expo;
  843.                    if (uexp==0) { return 0; }
  844.                    return (sintL)(uexp - LF_exp_mid);
  845.                  }
  846.                );
  847.     }
  848.  
  849. # SF_I_scale_float_SF(x,delta) liefert x*2^delta, wo x ein SF ist.
  850.   local object SF_I_scale_float_SF (object x, object delta);
  851.   # Methode:
  852.   # x=0.0 -> x als Ergebnis
  853.   # delta muß ein Fixnum betragsmäßig <= SF_exp_high-SF_exp_low sein.
  854.   # Neues SF mit um delta vergrößertem Exponenten bilden.
  855.   local object SF_I_scale_float_SF(x,delta)
  856.     var reg1 object x;
  857.     var reg2 object delta;
  858.     { # x entpacken:
  859.       var reg5 signean sign;
  860.       var reg4 sintWL exp;
  861.       var reg6 uint32 mant;
  862.       SF_decode(x, { return x; }, sign=,exp=,mant=);
  863.       if (!R_minusp(delta))
  864.         # delta>=0
  865.         { var reg3 uintL udelta;
  866.           if (I_fixnump(delta)
  867.               && ((udelta = posfixnum_to_L(delta)) <= (uintL)(SF_exp_high-SF_exp_low))
  868.              )
  869.             { exp = exp+udelta;
  870.               encode_SF(sign,exp,mant, return);
  871.             }
  872.             else
  873.             { fehler_overflow(); }
  874.         }
  875.         else
  876.         # delta<0
  877.         { var reg3 uintL udelta;
  878.           if (I_fixnump(delta)
  879.               && ((udelta = negfixnum_abs_L(delta)) <= (uintL)(SF_exp_high-SF_exp_low))
  880.               && ((oint_data_len<intLsize) || !(udelta==0))
  881.              )
  882.             { exp = exp-udelta;
  883.               encode_SF(sign,exp,mant, return);
  884.             }
  885.             else
  886.             if (underflow_allowed())
  887.               { fehler_underflow(); }
  888.               else
  889.               { return SF_0; }
  890.         }
  891.     }
  892.  
  893. # FF_I_scale_float_FF(x,delta) liefert x*2^delta, wo x ein FF ist.
  894. # kann GC auslösen
  895.   local object FF_I_scale_float_FF (object x, object delta);
  896.   # Methode:
  897.   # x=0.0 -> x als Ergebnis
  898.   # delta muß ein Fixnum betragsmäßig <= FF_exp_high-FF_exp_low sein.
  899.   # Neues FF mit um delta vergrößertem Exponenten bilden.
  900.   local object FF_I_scale_float_FF(x,delta)
  901.     var reg1 object x;
  902.     var reg2 object delta;
  903.     { # x entpacken:
  904.       var reg5 signean sign;
  905.       var reg4 sintWL exp;
  906.       var reg6 uint32 mant;
  907.       FF_decode(x, { return x; }, sign=,exp=,mant=);
  908.       if (!R_minusp(delta))
  909.         # delta>=0
  910.         { var reg3 uintL udelta;
  911.           if (I_fixnump(delta)
  912.               && ((udelta = posfixnum_to_L(delta)) <= (uintL)(FF_exp_high-FF_exp_low))
  913.              )
  914.             { exp = exp+udelta;
  915.               encode_FF(sign,exp,mant, return);
  916.             }
  917.             else
  918.             { fehler_overflow(); }
  919.         }
  920.         else
  921.         # delta<0
  922.         { var reg3 uintL udelta;
  923.           if (I_fixnump(delta)
  924.               && ((udelta = negfixnum_abs_L(delta)) <= (uintL)(FF_exp_high-FF_exp_low))
  925.               && ((oint_data_len<intLsize) || !(udelta==0))
  926.              )
  927.             { exp = exp-udelta;
  928.               encode_FF(sign,exp,mant, return);
  929.             }
  930.             else
  931.             if (underflow_allowed())
  932.               { fehler_underflow(); }
  933.               else
  934.               { return FF_0; }
  935.         }
  936.     }
  937.  
  938. # DF_I_scale_float_DF(x,delta) liefert x*2^delta, wo x ein DF ist.
  939. # kann GC auslösen
  940.   local object DF_I_scale_float_DF (object x, object delta);
  941.   # Methode:
  942.   # x=0.0 -> x als Ergebnis
  943.   # delta muß ein Fixnum betragsmäßig <= DF_exp_high-DF_exp_low sein.
  944.   # Neues DF mit um delta vergrößertem Exponenten bilden.
  945.   local object DF_I_scale_float_DF(x,delta)
  946.     var reg1 object x;
  947.     var reg2 object delta;
  948.     { # x entpacken:
  949.       var reg5 signean sign;
  950.       var reg4 sintWL exp;
  951.       #ifdef intQsize
  952.       var reg6 uint64 mant;
  953.       DF_decode(x, { return x; }, sign=,exp=,mant=);
  954.       #else
  955.       var reg6 uint32 manthi;
  956.       var reg7 uint32 mantlo;
  957.       DF_decode2(x, { return x; }, sign=,exp=,manthi=,mantlo=);
  958.       #endif
  959.       if (!R_minusp(delta))
  960.         # delta>=0
  961.         { var reg3 uintL udelta;
  962.           if (I_fixnump(delta)
  963.               && ((udelta = posfixnum_to_L(delta)) <= (uintL)(DF_exp_high-DF_exp_low))
  964.              )
  965.             { exp = exp+udelta;
  966.               #ifdef intQsize
  967.               encode_DF(sign,exp,mant, return);
  968.               #else
  969.               encode2_DF(sign,exp,manthi,mantlo, return);
  970.               #endif
  971.             }
  972.             else
  973.             { fehler_overflow(); }
  974.         }
  975.         else
  976.         # delta<0
  977.         { var reg3 uintL udelta;
  978.           if (I_fixnump(delta)
  979.               && ((udelta = negfixnum_abs_L(delta)) <= (uintL)(DF_exp_high-DF_exp_low))
  980.               && ((oint_data_len<intLsize) || !(udelta==0))
  981.              )
  982.             { exp = exp-udelta;
  983.               #ifdef intQsize
  984.               encode_DF(sign,exp,mant, return);
  985.               #else
  986.               encode2_DF(sign,exp,manthi,mantlo, return);
  987.               #endif
  988.             }
  989.             else
  990.             if (underflow_allowed())
  991.               { fehler_underflow(); }
  992.               else
  993.               { return DF_0; }
  994.         }
  995.     }
  996.  
  997. # LF_I_scale_float_LF(x,delta) liefert x*2^delta, wo x ein LF ist.
  998. # kann GC auslösen
  999.   local object LF_I_scale_float_LF (object x, object delta);
  1000.   # Methode:
  1001.   # delta=0 -> x als Ergebnis
  1002.   # x=0.0 -> x als Ergebnis
  1003.   # delta muß ein Fixnum betragsmäßig <= LF_exp_high-LF_exp_low sein.
  1004.   # Neues LF mit um delta vergrößertem Exponenten bilden.
  1005.   local object LF_I_scale_float_LF(x,delta)
  1006.     var reg3 object x;
  1007.     var reg4 object delta;
  1008.     { if (eq(delta,Fixnum_0)) { return x; } # delta=0 -> x als Ergebnis
  1009.      {var reg5 uintL uexp = TheLfloat(x)->expo;
  1010.       if (uexp==0) { return x; }
  1011.       pushSTACK(x); # x retten
  1012.       { var reg2 uintL udelta;
  1013.         # |delta| muß <= LF_exp_high-LF_exp_low < 2^32 sein. Wie bei I_to_UL:
  1014.         switch (typecode(delta))
  1015.           { case_posfixnum: # Fixnum >=0
  1016.               udelta = posfixnum_to_L(delta); goto pos;
  1017.             case_posbignum: # Bignum >0
  1018.               { var reg1 Bignum bn = TheBignum(delta);
  1019.                 #define IF_LENGTH(i)  \
  1020.                   if (bn_minlength <= i) # genau i Digits überhaupt möglich?       \
  1021.                     if (bn->length == i) # genau i Digits?                         \
  1022.                       # 2^((i-1)*intDsize-1) <= obj < 2^(i*intDsize-1)             \
  1023.                       if ( (i*intDsize-1 > 32)                                     \
  1024.                            && ( ((i-1)*intDsize-1 >= 32)                           \
  1025.                                 || (bn->data[0] >= (uintD)bitc(32-(i-1)*intDsize)) \
  1026.                          )    )                                                    \
  1027.                         goto overflow;                                             \
  1028.                         else
  1029.                 IF_LENGTH(1)
  1030.                   { udelta = get_uint1D_Dptr(bn->data); goto pos; }
  1031.                 IF_LENGTH(2)
  1032.                   { udelta = get_uint2D_Dptr(bn->data); goto pos; }
  1033.                 IF_LENGTH(3)
  1034.                   { udelta = get_uint3D_Dptr(bn->data); goto pos; }
  1035.                 IF_LENGTH(4)
  1036.                   { udelta = get_uint4D_Dptr(bn->data); goto pos; }
  1037.                 IF_LENGTH(5)
  1038.                   { udelta = get_uint4D_Dptr(&bn->data[1]); goto pos; }
  1039.                 #undef IF_LENGTH
  1040.               }
  1041.               goto overflow; # delta zu groß
  1042.             case_negfixnum: # Fixnum <0
  1043.               udelta = negfixnum_to_L(delta); goto neg;
  1044.             case_negbignum: # Bignum <0
  1045.               { var reg1 Bignum bn = TheBignum(delta);
  1046.                 #define IF_LENGTH(i)  \
  1047.                   if (bn_minlength <= i) # genau i Digits überhaupt möglich?         \
  1048.                     if (bn->length == i) # genau i Digits?                           \
  1049.                       # - 2^((i-1)*intDsize-1) > obj >= - 2^(i*intDsize-1)           \
  1050.                       if ( (i*intDsize-1 > 32)                                       \
  1051.                            && ( ((i-1)*intDsize-1 >= 32)                             \
  1052.                                 || (bn->data[0] < (uintD)(-bitc(32-(i-1)*intDsize))) \
  1053.                          )    )                                                      \
  1054.                         goto underflow;                                              \
  1055.                         else
  1056.                 IF_LENGTH(1)
  1057.                   { udelta = get_sint1D_Dptr(bn->data); goto neg; }
  1058.                 IF_LENGTH(2)
  1059.                   { udelta = get_sint2D_Dptr(bn->data); goto neg; }
  1060.                 IF_LENGTH(3)
  1061.                   { udelta = get_sint3D_Dptr(bn->data); goto neg; }
  1062.                 IF_LENGTH(4)
  1063.                   { udelta = get_sint4D_Dptr(bn->data); goto neg; }
  1064.                 IF_LENGTH(5)
  1065.                   { udelta = get_sint4D_Dptr(&bn->data[1]); goto neg; }
  1066.                 #undef IF_LENGTH
  1067.               }
  1068.               goto underflow; # delta zu klein
  1069.             pos: # udelta = delta >=0
  1070.               if (   ((uexp = uexp+udelta) < udelta) # Exponent-Überlauf?
  1071.                   #ifndef UNIX_DEC_ULTRIX_GCCBUG
  1072.                   || (uexp > LF_exp_high) # oder Exponent zu groß?
  1073.                   #endif
  1074.                  )
  1075.                 { fehler_overflow(); } # ja -> Überlauf
  1076.               break; # sonst OK
  1077.             neg: # delta <0, udelta = 2^32+delta
  1078.               if (   ((uexp = uexp+udelta) >= udelta) # oder Exponent-Unterlauf?
  1079.                   || (uexp < LF_exp_low) # oder Exponent zu klein?
  1080.                  )
  1081.                 goto underflow; # ja -> Unterlauf
  1082.               break; # sonst OK
  1083.             default: # unpassender Integer
  1084.               if (!R_minusp(delta))
  1085.                 { overflow: fehler_overflow(); } # delta zu groß
  1086.                 else
  1087.                 { underflow: # delta zu klein
  1088.                   if (underflow_allowed())
  1089.                     { fehler_underflow(); }
  1090.                     else
  1091.                     { skipSTACK(1);
  1092.                       encode_LF0(TheLfloat(x)->len,return);
  1093.                 }   }
  1094.           }
  1095.        {var reg1 uintC mantlen = TheLfloat(x)->len;
  1096.         x = allocate_lfloat(mantlen,uexp,R_sign(x)); # neues Long-Float
  1097.         copy_loop_up(&TheLfloat(popSTACK())->data[0],&TheLfloat(x)->data[0],mantlen); # füllen
  1098.         return x;
  1099.     }}}}
  1100.  
  1101. # F_I_scale_float_F(x,delta) liefert x*2^delta, wo x ein Float ist.
  1102. # kann GC auslösen
  1103.   local object F_I_scale_float_F (object x, object delta);
  1104.   local object F_I_scale_float_F(x,delta)
  1105.     var reg1 object x;
  1106.     var reg2 object delta;
  1107.     { floatcase(x,
  1108.                 { return SF_I_scale_float_SF(x,delta); },
  1109.                 { return FF_I_scale_float_FF(x,delta); },
  1110.                 { return DF_I_scale_float_DF(x,delta); },
  1111.                 { return LF_I_scale_float_LF(x,delta); }
  1112.                );
  1113.     }
  1114.  
  1115. # F_float_radix_I(x) liefert (float-radix x), wo x ein Float ist.
  1116.   local object F_float_radix_I (object x);
  1117. #if 0
  1118.   local object F_float_radix_I(x)
  1119.     var reg1 object x;
  1120.     { return fixnum(2); } # stets 2 als Ergebnis
  1121. #else # Macro spart Code
  1122.   #define F_float_radix_I(obj)  (unused (obj), fixnum(2)) # stets 2 als Ergebnis
  1123. #endif
  1124.  
  1125. # F_float_sign_F(x) liefert (float-sign x), wo x ein Float ist.
  1126. # kann GC auslösen
  1127.   local object F_float_sign_F (object x);
  1128.   # Methode: x>=0 -> Ergebnis 1.0; x<0 -> Ergebnis -1.0
  1129.   local object F_float_sign_F(x)
  1130.     var reg1 object x;
  1131.     { floatcase(x,
  1132.       /* x SF */ { encode_SF(R_sign(x),1,bit(SF_mant_len), return); },
  1133.       /* x FF */ # { encode_FF(R_sign(x),1,bit(FF_mant_len), return); }, # besser:
  1134.                  { return (!R_minusp(x) ? FF_1 : FF_minus1); },
  1135.       /* x DF */ # { ifdef_intQsize(
  1136.                  #     encode_DF(R_sign(x),1,bit(DF_mant_len), return); ,
  1137.                  #     encode2_DF(R_sign(x),1,bit(DF_mant_len-32),0, return); )
  1138.                  # }
  1139.                  # besser:
  1140.                  { return (!R_minusp(x) ? DF_1 : DF_minus1); },
  1141.       /* x LF */ { encode_LF1s(R_sign(x),TheLfloat(x)->len, return); }
  1142.                );
  1143.     }
  1144.  
  1145. # F_F_float_sign_F(x) liefert (float-sign x y), wo x und y Floats sind.
  1146. # kann GC auslösen
  1147.   local object F_F_float_sign_F (object x, object y);
  1148.   # Methode:
  1149.   # Falls x<0 xor y<0, Ergebnis (- y), sonst Ergebnis y.
  1150.   local object F_F_float_sign_F(x,y)
  1151.     var reg2 object x;
  1152.     var reg1 object y;
  1153.     { return (!same_sign_p(x,y) ? F_minus_F(y) : y); }
  1154.  
  1155. # F_float_digits(x) liefert (float-digits x), wo x ein Float ist.
  1156. # < ergebnis: ein uintL >0
  1157.   local uintL F_float_digits (object x);
  1158.   local uintL F_float_digits(x)
  1159.     var reg1 object x;
  1160.     { floatcase(x,
  1161.                 { return SF_mant_len+1; }, # 17
  1162.                 { return FF_mant_len+1; }, # 24
  1163.                 { return DF_mant_len+1; }, # 53
  1164.                 { return intDsize*(uintL)(TheLfloat(x)->len); } # 16n
  1165.                );
  1166.     }
  1167.  
  1168. # F_float_digits_I(x) liefert (float-digits x), wo x ein Float ist.
  1169. # < ergebnis: ein Integer >0
  1170. # kann GC auslösen
  1171.   local object F_float_digits_I (object x);
  1172.   local object F_float_digits_I(x)
  1173.     var reg1 object x;
  1174.     { floatcase(x,
  1175.                 { return fixnum(SF_mant_len+1); }, # Fixnum 17
  1176.                 { return fixnum(FF_mant_len+1); }, # Fixnum 24
  1177.                 { return fixnum(DF_mant_len+1); }, # Fixnum 53
  1178.                 { var reg2 uintL bitcount = intDsize*(uintL)(TheLfloat(x)->len); # 16n
  1179.                   return (log2_intDsize+intCsize<=oint_data_len # intDsize*2^intCsize <= 2^oint_data_len ?
  1180.                           ? fixnum(bitcount)
  1181.                           : UL_to_I(bitcount)
  1182.                          );
  1183.                 }
  1184.                );
  1185.     }
  1186.  
  1187. # F_float_precision_I(x) liefert (float-precision x), wo x ein Float ist.
  1188. # < ergebnis: ein Integer >=0
  1189. # kann GC auslösen
  1190.   local object F_float_precision_I (object x);
  1191.   # Methode: Falls x=0.0, Ergebnis 0, sonst (float-digits x).
  1192.   local object F_float_precision_I(x)
  1193.     var reg1 object x;
  1194.     { floatcase(x,
  1195.                 { if (SF_zerop(x)) { return Fixnum_0; }
  1196.                   return fixnum(SF_mant_len+1); # Fixnum 17
  1197.                 },
  1198.                 { if (FF_zerop(x)) { return Fixnum_0; }
  1199.                   return fixnum(FF_mant_len+1); # Fixnum 24
  1200.                 },
  1201.                 { if (DF_zerop(x)) { return Fixnum_0; }
  1202.                   return fixnum(DF_mant_len+1); # Fixnum 53
  1203.                 },
  1204.                 { if (LF_zerop(x)) { return Fixnum_0; }
  1205.                  {var reg2 uintL bitcount = intDsize*(uintL)(TheLfloat(x)->len); # 16n
  1206.                   return (log2_intDsize+intCsize<=oint_data_len # intDsize*2^intCsize <= 2^oint_data_len ?
  1207.                           ? fixnum(bitcount)
  1208.                           : UL_to_I(bitcount)
  1209.                          );
  1210.                 }}
  1211.                );
  1212.     }
  1213.  
  1214. # F_integer_decode_float_I_I_I(x) liefert zu einem Float x:
  1215. # (integer-decode-float x), alle drei Werte in den Stack.
  1216. # x = 0.0 liefert (0, 0, 1).
  1217. # x = (-1)^s * 2^e * m bei Float-Precision p liefert
  1218. #   (Mantisse 2^p * m als Integer, e-p als Integer, (-1)^s als Fixnum).
  1219. # kann GC auslösen
  1220.   local void F_integer_decode_float_I_I_I (object x);
  1221.   local void F_integer_decode_float_I_I_I(x)
  1222.     var reg1 object x;
  1223.     { floatcase(x,
  1224.       /* x SF */ { # x entpacken:
  1225.                    var reg3 sintWL exp;
  1226.                    var reg2 uint32 mant;
  1227.                    SF_decode(x, { goto zero; },_EMA_,exp=,mant=);
  1228.                    pushSTACK(fixnum(mant)); # Mantisse als Fixnum (>0, <2^17)
  1229.                    pushSTACK(L_to_FN((sintL)(exp-(SF_mant_len+1)))); # e-17 als Fixnum
  1230.                  },
  1231.       /* x FF */ { # x entpacken:
  1232.                    var reg3 sintWL exp;
  1233.                    var reg2 uint32 mant;
  1234.                    FF_decode(x, { goto zero; },_EMA_,exp=,mant=);
  1235.                    pushSTACK( # Mantisse (>0, <2^24) als Integer
  1236.                               (FF_mant_len+1 <= oint_data_len
  1237.                                ? fixnum(mant) # Mantisse als Fixnum
  1238.                                : UL_to_I(mant) # oder evtl. als Bignum
  1239.                             ) );
  1240.                    pushSTACK(L_to_FN((sintL)(exp-(FF_mant_len+1)))); # e-24 als Fixnum
  1241.                  },
  1242.       /* x DF */ { # x entpacken:
  1243.                    var reg3 sintWL exp;
  1244.                    ifdef_intQsize(
  1245.                      { var reg2 uint64 mant;
  1246.                        DF_decode(x, { goto zero; },_EMA_,exp=,mant=);
  1247.                        pushSTACK(Q_to_I(mant)); # Mantisse (>0, <2^53) als Bignum
  1248.                      },
  1249.                      { var reg2 uint32 manthi;
  1250.                        var reg2 uint32 mantlo;
  1251.                        DF_decode2(x, { goto zero; },_EMA_,exp=,manthi=,mantlo=);
  1252.                        pushSTACK(L2_to_I(manthi,mantlo)); # Mantisse (>0, <2^53) als Bignum
  1253.                      });
  1254.                    pushSTACK(L_to_FN((sintL)(exp-(DF_mant_len+1)))); # e-53 als Fixnum
  1255.                  },
  1256.       /* x LF */ { var reg6 uintL uexp = TheLfloat(x)->expo;
  1257.                    if (uexp == 0) goto zero;
  1258.                    pushSTACK(x); # x retten
  1259.                   {var reg3 uintC len = TheLfloat(x)->len; # Anzahl Mantissendigits
  1260.                    var reg4 uintC len1 = len+1; # brauche 1 Digit mehr
  1261.                    if (uintCoverflow(len1)) { fehler_LF_toolong(); }
  1262.                    # intDsize*len >= 53 >= 33 >= oint_data_len+1, also len >= bn_minlength.
  1263.                    {var reg5 object mant = allocate_bignum(len1,0); # Integer für Mantisse
  1264.                     var reg2 uintD* mantptr = &TheBignum(mant)->data[0];
  1265.                     *mantptr++ = 0; # vorne 1 Nulldigit, damit es eine NDS wird
  1266.                     copy_loop_up(&TheLfloat(STACK_0)->data[0],mantptr,len); # NUDS kopieren
  1267.                     STACK_0 = mant; # 1. Wert fertig
  1268.                    }
  1269.                    # e-16n = uexp-LF_exp_mid-16n als Integer bilden:
  1270.                    {var reg2 uintL sub = LF_exp_mid + intDsize*(uintL)len;
  1271.                     pushSTACK(UL_UL_minus_I(uexp,sub));
  1272.                  }}}
  1273.                );
  1274.       pushSTACK(!R_minusp(x) ? Fixnum_1 : Fixnum_minus1); # Vorzeichen von x (nicht GC-gefährdet!)
  1275.       return;
  1276.       zero: pushSTACK(Fixnum_0); pushSTACK(Fixnum_0); pushSTACK(Fixnum_1); return;
  1277.     }
  1278.  
  1279.