home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / intlog.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  45.8 KB  |  1,077 lines
  1. # Logische Operationen auf Integers
  2.  
  3. # Liefert die Anzahl Digits, die ein Integer als DS bräuchte.
  4. # (Leicht aufgerundet.)
  5.   local uintC I_to_DS_need (object obj);
  6.   local uintC I_to_DS_need(obj)
  7.     var reg1 object obj;
  8.     { if (I_fixnump(obj))
  9.         return FN_maxlength; # das wird reichen
  10.         else
  11.         return TheBignum(obj)->length;
  12.     }
  13.  
  14. # Integer to Digit sequence, n Digits
  15. # I_to_DS_n(obj,n,ptr=);
  16. # Integer obj zu einer Digit sequence MSDptr/n/LSDptr machen,
  17. # die genau n Digits hat (sollte n >= Bedarf und >= FN_maxlength sein).
  18. # Die neue Digit-sequence darf modifiziert werden.
  19. # < ptr: MSDptr der neuen DS
  20. # Dabei wird num_stack erniedrigt.
  21.   #define I_to_DS_n(obj,n,ptr_zuweisung)  \
  22.     {var reg1 uintD* destptr;                 \
  23.      num_stack_need(n,_EMA_,destptr=);             \
  24.      ptr_zuweisung I_to_DS_n_(obj,n,destptr); \
  25.     }
  26.   local uintD* I_to_DS_n_ (object obj, uintC n, uintD* destptr);
  27.   local uintD* I_to_DS_n_(obj,n,destptr)
  28.     var reg4 object obj;
  29.     var reg3 uintC n;
  30.     var reg1 uintD* destptr;
  31.     { # Nun sind unterhalb von destptr n Digits Platz.
  32.       # oberen Teil der DS aus obj füllen, dabei destptr erniedrigen:
  33.       if (I_fixnump(obj))
  34.         # Fixnum:
  35.         { var reg2 uint32 wert = FN_to_L(obj);
  36.           #define FN_maxlength_a  (intLsize/intDsize)
  37.           #define FN_maxlength_b  (FN_maxlength<=FN_maxlength_a ? FN_maxlength : FN_maxlength_a)
  38.           # FN_maxlength Digits ablegen. Davon kann man FN_maxlength_b Digits aus wert nehmen.
  39.           #if (FN_maxlength_b > 1)
  40.           doconsttimes(FN_maxlength_b-1,
  41.             *--destptr = (uintD)wert; wert = wert >> intDsize;
  42.             );
  43.           #endif
  44.           *--destptr = (uintD)wert;
  45.           #if (FN_maxlength > FN_maxlength_b)
  46.           # Es ist oint_data_len = intLsize, brauche
  47.           # noch FN_maxlength-FN_maxlength_b = 1 Digit.
  48.           *--destptr = (sintD)R_sign(obj);
  49.           #endif
  50.           n -= FN_maxlength;
  51.         }
  52.         else
  53.         # Bignum:
  54.         { var reg2 uintC len = TheBignum(obj)->length;
  55.           # Pointer bestimmen:
  56.           var reg1 uintD* ptr = &TheBignum(obj)->data[(uintP)len];
  57.           n -= len;
  58.           destptr = copy_loop_down(ptr,destptr,len); # DS kopieren
  59.         }
  60.       # unteren Teil mit Fülldigits, gebildet aus dem Vorzeichen, füllen:
  61.       if (!(n==0))
  62.         { destptr = fill_loop_down(destptr,n,sign_of_sintD(destptr[0])); }
  63.       # destptr zeigt nun aufs untere Ende der DS.
  64.       return destptr;
  65.     }
  66.  
  67. # Logische Operationen auf Integers:
  68. # Methode: aus den Längen der beiden Argumente eine obere Schranke für
  69. # die Länge des Ergebnisses berechnen (das Maximum der beiden Längen und
  70. # FN_maxlength), so daß das MSD für unendlich viele Bits steht.
  71. # Dann beide Argumente in gleichgroße Digit sequences umwandeln, Operation
  72. # mit einer einfachen Schleife durchführen.
  73.  
  74. # (LOGIOR x y), wenn x, y Integers sind.
  75. # Ergebnis Integer.
  76. # kann GC auslösen.
  77.   local object I_I_logior_I (object x, object y);
  78.   local object I_I_logior_I(x,y)
  79.     var reg3 object x;
  80.     var reg3 object y;
  81.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  82.         { return as_object # bitweise als Fixnum zurück
  83.                  (as_oint(x) | as_oint(y));
  84.         }
  85.         else
  86.         { SAVE_NUM_STACK # num_stack retten
  87.           var reg5 uintC n; # Anzahl der Digits
  88.          {var reg5 uintC nx = I_to_DS_need(x);
  89.           var reg5 uintC ny = I_to_DS_need(y);
  90.           n = (nx>=ny ? nx : ny);
  91.          }
  92.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  93.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  94.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  95.             or_loop_up(xptr,yptr,n); # mit OR verknüpfen
  96.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  97.             return DS_to_I(zptr,n); # Ergebnis als Integer
  98.     }   }}}}
  99.  
  100. # (LOGXOR x y), wenn x, y Integers sind.
  101. # Ergebnis Integer.
  102. # kann GC auslösen.
  103.   local object I_I_logxor_I (object x, object y);
  104.   local object I_I_logxor_I(x,y)
  105.     var reg3 object x;
  106.     var reg3 object y;
  107.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  108.         { return as_object # bitweise als Fixnum zurück
  109.                  ((as_oint(x) ^ as_oint(y)) | ((oint)fixnum_type << oint_type_shift));
  110.         }
  111.         else
  112.         { SAVE_NUM_STACK # num_stack retten
  113.           var reg5 uintC n; # Anzahl der Digits
  114.          {var reg5 uintC nx = I_to_DS_need(x);
  115.           var reg5 uintC ny = I_to_DS_need(y);
  116.           n = (nx>=ny ? nx : ny);
  117.          }
  118.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  119.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  120.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  121.             xor_loop_up(xptr,yptr,n); # mit XOR verknüpfen
  122.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  123.             return DS_to_I(zptr,n); # Ergebnis als Integer
  124.     }   }}}}
  125.  
  126. # (LOGAND x y), wenn x, y Integers sind.
  127. # Ergebnis Integer.
  128. # kann GC auslösen.
  129.   local object I_I_logand_I (object x, object y);
  130.   local object I_I_logand_I(x,y)
  131.     var reg3 object x;
  132.     var reg3 object y;
  133.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  134.         { return as_object # bitweise als Fixnum zurück
  135.                  (as_oint(x) & as_oint(y));
  136.         }
  137.         else
  138.         { SAVE_NUM_STACK # num_stack retten
  139.           var reg5 uintC n; # Anzahl der Digits
  140.          {var reg5 uintC nx = I_to_DS_need(x);
  141.           var reg5 uintC ny = I_to_DS_need(y);
  142.           n = (nx>=ny ? nx : ny);
  143.          }
  144.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  145.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  146.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  147.             and_loop_up(xptr,yptr,n); # mit AND verknüpfen
  148.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  149.             return DS_to_I(zptr,n); # Ergebnis als Integer
  150.     }   }}}}
  151.  
  152. # (LOGEQV x y), wenn x, y Integers sind.
  153. # Ergebnis Integer.
  154. # kann GC auslösen.
  155.   local object I_I_logeqv_I (object x, object y);
  156.   local object I_I_logeqv_I(x,y)
  157.     var reg3 object x;
  158.     var reg3 object y;
  159.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  160.         { return as_object # bitweise als Fixnum zurück
  161.                  ( ~(as_oint(x) ^ as_oint(y))
  162.                    & (((oint)fixnum_type << oint_type_shift) | FN_value_vz_mask)
  163.                  );
  164.         }
  165.         else
  166.         { SAVE_NUM_STACK # num_stack retten
  167.           var reg5 uintC n; # Anzahl der Digits
  168.          {var reg5 uintC nx = I_to_DS_need(x);
  169.           var reg5 uintC ny = I_to_DS_need(y);
  170.           n = (nx>=ny ? nx : ny);
  171.          }
  172.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  173.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  174.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  175.             eqv_loop_up(xptr,yptr,n); # mit NOT XOR verknüpfen
  176.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  177.             return DS_to_I(zptr,n); # Ergebnis als Integer
  178.     }   }}}}
  179.  
  180. # (LOGNAND x y), wenn x, y Integers sind.
  181. # Ergebnis Integer.
  182. # kann GC auslösen.
  183.   local object I_I_lognand_I (object x, object y);
  184.   local object I_I_lognand_I(x,y)
  185.     var reg3 object x;
  186.     var reg3 object y;
  187.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  188.         { return as_object # bitweise als Fixnum zurück
  189.                  ((as_oint(x) & as_oint(y)) ^ FN_value_vz_mask);
  190.         }
  191.         else
  192.         { SAVE_NUM_STACK # num_stack retten
  193.           var reg5 uintC n; # Anzahl der Digits
  194.          {var reg5 uintC nx = I_to_DS_need(x);
  195.           var reg5 uintC ny = I_to_DS_need(y);
  196.           n = (nx>=ny ? nx : ny);
  197.          }
  198.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  199.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  200.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  201.             nand_loop_up(xptr,yptr,n); # mit NOT AND verknüpfen
  202.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  203.             return DS_to_I(zptr,n); # Ergebnis als Integer
  204.     }   }}}}
  205.  
  206. # (LOGNOR x y), wenn x, y Integers sind.
  207. # Ergebnis Integer.
  208. # kann GC auslösen.
  209.   local object I_I_lognor_I (object x, object y);
  210.   local object I_I_lognor_I(x,y)
  211.     var reg3 object x;
  212.     var reg3 object y;
  213.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  214.         { return as_object # bitweise als Fixnum zurück
  215.                  ((as_oint(x) | as_oint(y)) ^ FN_value_vz_mask);
  216.         }
  217.         else
  218.         { SAVE_NUM_STACK # num_stack retten
  219.           var reg5 uintC n; # Anzahl der Digits
  220.          {var reg5 uintC nx = I_to_DS_need(x);
  221.           var reg5 uintC ny = I_to_DS_need(y);
  222.           n = (nx>=ny ? nx : ny);
  223.          }
  224.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  225.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  226.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  227.             nor_loop_up(xptr,yptr,n); # mit NOT OR verknüpfen
  228.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  229.             return DS_to_I(zptr,n); # Ergebnis als Integer
  230.     }   }}}}
  231.  
  232. # (LOGANDC2 x y), wenn x, y Integers sind.
  233. # Ergebnis Integer.
  234. # kann GC auslösen.
  235.   local object I_I_logandc2_I (object x, object y);
  236.   local object I_I_logandc2_I(x,y)
  237.     var reg3 object x;
  238.     var reg3 object y;
  239.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  240.         { return as_object # bitweise als Fixnum zurück
  241.                  ((as_oint(x) & ~as_oint(y)) | ((oint)fixnum_type << oint_type_shift));
  242.         }
  243.         else
  244.         { SAVE_NUM_STACK # num_stack retten
  245.           var reg5 uintC n; # Anzahl der Digits
  246.          {var reg5 uintC nx = I_to_DS_need(x);
  247.           var reg5 uintC ny = I_to_DS_need(y);
  248.           n = (nx>=ny ? nx : ny);
  249.          }
  250.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  251.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  252.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  253.             andc2_loop_up(xptr,yptr,n); # mit AND NOT verknüpfen
  254.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  255.             return DS_to_I(zptr,n); # Ergebnis als Integer
  256.     }   }}}}
  257.  
  258. # (LOGANDC1 x y), wenn x, y Integers sind.
  259. # Ergebnis Integer.
  260. # kann GC auslösen.
  261. #if 1 # Macro spart Code
  262.   #define I_I_logandc1_I(x,y)  I_I_logandc2_I(y,x)
  263. #else
  264.   local object I_I_logandc1_I (object x, object y);
  265.   local object I_I_logandc1_I(x,y)
  266.     var reg1 object x;
  267.     var reg1 object y;
  268.     { return I_I_logandc2_I(y,x); }
  269. #endif
  270.  
  271. # (LOGORC2 x y), wenn x, y Integers sind.
  272. # Ergebnis Integer.
  273. # kann GC auslösen.
  274.   local object I_I_logorc2_I (object x, object y);
  275.   local object I_I_logorc2_I(x,y)
  276.     var reg3 object x;
  277.     var reg3 object y;
  278.     { if (I_fixnump(x) && I_fixnump(y)) # Beides Fixnums -> ganz einfach:
  279.         { return as_object # bitweise als Fixnum zurück
  280.                  ( (as_oint(x) | ~as_oint(y))
  281.                    & (((oint)fixnum_type << oint_type_shift) | FN_value_vz_mask)
  282.                  );
  283.         }
  284.         else
  285.         { SAVE_NUM_STACK # num_stack retten
  286.           var reg5 uintC n; # Anzahl der Digits
  287.          {var reg5 uintC nx = I_to_DS_need(x);
  288.           var reg5 uintC ny = I_to_DS_need(y);
  289.           n = (nx>=ny ? nx : ny);
  290.          }
  291.          {  var reg1 uintD* xptr; I_to_DS_n(x,n,xptr=); # Pointer in DS zu x
  292.           { var reg2 uintD* yptr; I_to_DS_n(y,n,yptr=); # Pointer in DS zu y
  293.            {var reg4 uintD* zptr = xptr; # Pointer aufs Ergebnis
  294.             orc2_loop_up(xptr,yptr,n); # mit OR NOT verknüpfen
  295.             RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  296.             return DS_to_I(zptr,n); # Ergebnis als Integer
  297.     }   }}}}
  298.  
  299. # (LOGORC1 x y), wenn x, y Integers sind.
  300. # Ergebnis Integer.
  301. # kann GC auslösen.
  302. #if 1 # Macro spart Code
  303.   #define I_I_logorc1_I(x,y)  I_I_logorc2_I(y,x)
  304. #else
  305.   local object I_I_logorc1_I (object x, object y);
  306.   local object I_I_logorc1_I(x,y)
  307.     var reg1 object x;
  308.     var reg1 object y;
  309.     { return I_I_logorc2_I(y,x); }
  310. #endif
  311.  
  312. # (LOGNOT x), wenn x ein Integer sind.
  313. # Ergebnis Integer.
  314. # kann GC auslösen.
  315.   local object I_lognot_I (object x);
  316.   local object I_lognot_I(x)
  317.     var reg3 object x;
  318.     { if (I_fixnump(x)) # Fixnum -> ganz einfach:
  319.         { return as_object # bitweise als Fixnum zurück
  320.                  (as_oint(x) ^ FN_value_vz_mask);
  321.         }
  322.         else
  323.         # Bignum:
  324.         { SAVE_NUM_STACK # num_stack retten
  325.           var reg5 uintD* MSDptr;
  326.           var reg5 uintC n;
  327.           BN_to_NDS(x, MSDptr=,n=,_EMA_); # NDS zu x bilden
  328.           # Es ist n>=bn_minlength,
  329.           # und die ersten intDsize+1 Bit sind nicht alle gleich.
  330.           not_loop_up(MSDptr,n); # mit NOT komplementieren,
  331.                           # wegen n>0 wird auch das Vorzeichenbit umgedreht
  332.           # MSDptr/n/LSDptr ist immer noch eine NDS, da n>=bn_minlength
  333.           # und die ersten intDsize+1 Bit nicht alle gleich sind.
  334.           RESTORE_NUM_STACK # num_stack (vorzeitig) zurück
  335.           return NDS_to_I(MSDptr,n); # Ergebnis als Integer
  336.     }   }
  337.  
  338. # Konstanten für BOOLE:
  339. # Bit-wert in 'integer1' + 2 * Bit-wert in 'integer2' = k
  340. # Fixnum mit 4 Bits: Bit k gibt an, was bei diesen zwei Bit-werten kommt.
  341. #           Name             k=0 k=1 k=2 k=3 (Bitwerte: [00] [10] [01] [11])
  342.   #define boole_clr     0  #  0   0   0   0
  343.   #define boole_set    15  #  1   1   1   1
  344.   #define boole_1      10  #  0   1   0   1
  345.   #define boole_2      12  #  0   0   1   1
  346.   #define boole_c1      5  #  1   0   1   0
  347.   #define boole_c2      3  #  1   1   0   0
  348.   #define boole_and     8  #  0   0   0   1
  349.   #define boole_ior    14  #  0   1   1   1
  350.   #define boole_xor     6  #  0   1   1   0
  351.   #define boole_eqv     9  #  1   0   0   1
  352.   #define boole_nand    7  #  1   1   1   0
  353.   #define boole_nor     1  #  1   0   0   0
  354.   #define boole_andc1   4  #  0   0   1   0
  355.   #define boole_andc2   2  #  0   1   0   0
  356.   #define boole_orc1   13  #  1   0   1   1
  357.   #define boole_orc2   11  #  1   1   0   1
  358.  
  359. # (BOOLE op x y), wenn x und y Integers und op ein Objekt sind.
  360. # Ergebnis Integer.
  361. # OP_I_I_boole_I(op,x,y)
  362. # kann GC auslösen
  363.   local object OP_I_I_boole_I (object op, object x, object y);
  364.   local object OP_I_I_boole_I(op,x,y)
  365.     var reg1 object op;
  366.     var reg2 object x;
  367.     var reg3 object y;
  368.     { switch (as_oint(op) ^ as_oint(Fixnum_0))
  369.         { case (oint)( boole_clr )<<oint_data_shift:
  370.             return Fixnum_0;
  371.           case (oint)( boole_set )<<oint_data_shift:
  372.             return Fixnum_minus1;
  373.           case (oint)( boole_1 )<<oint_data_shift:
  374.             return x;
  375.           case (oint)( boole_2 )<<oint_data_shift:
  376.             return y;
  377.           case (oint)( boole_c1 )<<oint_data_shift:
  378.             return I_lognot_I(x);
  379.           case (oint)( boole_c2 )<<oint_data_shift:
  380.             return I_lognot_I(y);
  381.           case (oint)( boole_and )<<oint_data_shift:
  382.             return I_I_logand_I(x,y);
  383.           case (oint)( boole_ior )<<oint_data_shift:
  384.             return I_I_logior_I(x,y);
  385.           case (oint)( boole_xor )<<oint_data_shift:
  386.             return I_I_logxor_I(x,y);
  387.           case (oint)( boole_eqv )<<oint_data_shift:
  388.             return I_I_logeqv_I(x,y);
  389.           case (oint)( boole_nand )<<oint_data_shift:
  390.             return I_I_lognand_I(x,y);
  391.           case (oint)( boole_nor )<<oint_data_shift:
  392.             return I_I_lognor_I(x,y);
  393.           case (oint)( boole_andc1 )<<oint_data_shift:
  394.             return I_I_logandc1_I(x,y);
  395.           case (oint)( boole_andc2 )<<oint_data_shift:
  396.             return I_I_logandc2_I(x,y);
  397.           case (oint)( boole_orc1 )<<oint_data_shift:
  398.             return I_I_logorc1_I(x,y);
  399.           case (oint)( boole_orc2 )<<oint_data_shift:
  400.             return I_I_logorc2_I(x,y);
  401.           default: # falscher Operator
  402.             pushSTACK(op); # Wert für Slot DATUM von TYPE-ERROR
  403.             pushSTACK(O(type_boole)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  404.             pushSTACK(op); pushSTACK(S(boole));
  405.             //: DEUTSCH "~: ~ ist keine gültige Boolesche Operation."
  406.             //: ENGLISH "~: ~ is not a valid boolean operation"
  407.             //: FRANCAIS "~ : ~ n'est pas une opération booléenne admise."
  408.             fehler(type_error, GETTEXT("~: ~ is not a valid boolean operation"));
  409.     }   }
  410.  
  411. # Prüft, ob (LOGTEST x y), wo x und y Integers sind.
  412. # (LOGTEST x y) = (NOT (ZEROP (LOGAND x y))).
  413. # I_I_logtest(x,y)
  414. # < ergebnis: /=0, falls ja; =0, falls nein.
  415.   local boolean I_I_logtest (object x, object y);
  416.   local boolean I_I_logtest(x,y)
  417.     var reg4 object x;
  418.     var reg5 object y;
  419.     # Methode:
  420.     #  Fixnums separat behandeln.
  421.     #  Sei oBdA x die kürzere der beiden Zahlen (in Digits).
  422.     #  x echt kürzer und x<0 -> [eines der most signif. intDsize+1 Bits von y ist 1] Ja.
  423.     #  Beide gleich lang oder x>=0 ->
  424.     #   Kann mich auf die untersten length(x) Digits beschraenken.
  425.     #   Mit AND durchlaufen, abbrechen (mit "Ja") falls /=0. Am Ende: Nein.
  426.     { if (I_fixnump(x))
  427.         if (I_fixnump(y))
  428.           # beides Fixnums
  429.           { if ((as_oint(x) & as_oint(y) & FN_value_vz_mask)==0)
  430.               return FALSE;
  431.               else
  432.               return TRUE;
  433.           }
  434.           else
  435.           # x Fixnum, y Bignum, also ist x echt kürzer
  436.           { xFN_yBN:
  437.             if (R_minusp(x)) return TRUE; # x<0 -> ja.
  438.             # x>=0. Kombiniere x mit den pFN_maxlength letzten Digits von y.
  439.            {var reg7 uintD* yLSDptr;
  440.             var reg6 uintL x_ = posfixnum_to_L(x);
  441.             BN_to_NDS_nocopy(y,_EMA_,_EMA_,yLSDptr=);
  442.             #if (pFN_maxlength > 1)
  443.             doconsttimes(pFN_maxlength-1,
  444.               if (*--yLSDptr & (uintD)x_) return TRUE;
  445.               x_ = x_ >> intDsize;
  446.               );
  447.             #endif
  448.             if (*--yLSDptr & (uintD)x_) return TRUE;
  449.             return FALSE;
  450.           }}
  451.         else
  452.         if (I_fixnump(y))
  453.           # x Bignum, y Fixnum
  454.           {{var reg1 object h = x; x = y; y = h; } # x und y vertauschen
  455.            goto xFN_yBN; # und weiter wie oben
  456.           }
  457.           else
  458.           # x,y Bignums
  459.           { var reg6 uintD* xMSDptr;
  460.             var reg6 uintC xlen;
  461.             var reg6 uintD* yMSDptr;
  462.             var reg6 uintC ylen;
  463.             BN_to_NDS_nocopy(x, xMSDptr=,xlen=,_EMA_);
  464.             BN_to_NDS_nocopy(y, yMSDptr=,ylen=,_EMA_);
  465.             # Beachte: xlen>0, ylen>0.
  466.             if (!(xlen==ylen))
  467.               # beide verschieden lang
  468.               { if (xlen>ylen)
  469.                   # vertauschen
  470.                   {{var reg1 uintD* temp = xMSDptr; xMSDptr = yMSDptr; yMSDptr = temp; }
  471.                    xlen = ylen;
  472.                   }
  473.                 # jetzt ist x die echt kürzere DS.
  474.                 if ((sintD)xMSDptr[0]<0) # der echt kürzere ist negativ?
  475.                   return TRUE;
  476.                 # Der echt kürzere ist positiv.
  477.               }
  478.             # xMSDptr/xlen/.. ist die kürzere DS, yMSDptr/../.. ist die längere DS.
  479.             return and_test_loop_up(xMSDptr,yMSDptr,xlen);
  480.     }     }
  481.  
  482. # Prüft, ob (LOGBITP x y), wo x und y Integers sind.
  483. # I_I_logbitp(x,y)
  484. # Ergebnis: /=0, wenn ja; =0, wenn nein.
  485.   local boolean I_I_logbitp (object x, object y);
  486.   local boolean I_I_logbitp(x,y)
  487.     var reg4 object x;
  488.     var reg5 object y;
  489.     # Methode:
  490.     # Falls x<0, Error.
  491.     # Falls x>=0: Falls x>=intDsize*Länge(y), teste Vorzeichen von y.
  492.     #             Sonst x=intDsize*k+i, Teste Bit i vom Worte Nr. k+1 (von oben herab).
  493.     { if (!R_minusp(x)) # x>=0 ?
  494.         { if (I_fixnump(x))
  495.             { var reg1 uintL x_ = posfixnum_to_L(x);
  496.               var reg2 uintC ylen;
  497.               var reg3 uintD* yLSDptr;
  498.               I_to_NDS_nocopy(y,_EMA_,ylen=,yLSDptr=); # DS zu y
  499.               if (x_ < intDsize*(uintL)ylen)
  500.                 # x ist ein Fixnum >=0, < intDsize*ylen
  501.                 { if (yLSDptr[-(uintP)floor(x_,intDsize)-1] & bit(x_%intDsize))
  502.                     return TRUE;
  503.                     else
  504.                     return FALSE;
  505.             }   }
  506.           # Vorzeichen von y testen
  507.           if (R_minusp(y))
  508.             return TRUE;
  509.             else
  510.             return FALSE;
  511.         }
  512.         else
  513.         # x<0
  514.         { pushSTACK(x); # Wert für Slot DATUM von TYPE-ERROR
  515.           pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  516.           pushSTACK(x); pushSTACK(S(logbitp));
  517.           //: DEUTSCH "~: Negativer Index: ~"
  518.           //: ENGLISH "~: index ~ is negative"
  519.           //: FRANCAIS "~ : Index négatif: ~"
  520.           fehler(type_error, GETTEXT("~: index ~ is negative"));
  521.     }   }
  522.  
  523. # Prüft, ob (ODDP x), wo x ein Integer ist.
  524. # I_oddp(x)
  525. # Ergebnis: /=0, falls ja; =0, falls nein.
  526.   local boolean I_oddp (object x);
  527.   local boolean I_oddp(x)
  528.     var reg1 object x;
  529.     { if (I_fixnump(x))
  530.         # Fixnum: Bit 0 abprüfen
  531.         { if (as_oint(x) & wbit(0+oint_data_shift))
  532.             return TRUE;
  533.             else
  534.             return FALSE;
  535.         }
  536.         else
  537.         # Bignum: Bit 0 im letzten Digit abprüfen
  538.         { var reg1 Bignum x_ = TheBignum(x);
  539.           if (x_->data[(uintP)(x_->length)-1] & bit(0))
  540.             return TRUE;
  541.             else
  542.             return FALSE;
  543.     }   }
  544.  
  545. # (ASH x y), wo x und y Integers sind. Ergebnis Integer.
  546. # I_I_ash_I(x,y)
  547. # kann GC auslösen
  548.   global object I_I_ash_I (object x, object y);
  549.   global object I_I_ash_I(x,y)
  550.     var reg3 object x;
  551.     var reg4 object y;
  552.     # Methode:
  553.     # x = 0 -> 0 als Ergebnis
  554.     # y = 0 -> x als Ergebnis
  555.     # y > 0 -> y = intDsize*k + i, j=k+(1 falls i>0, 0 falls i=0).
  556.     #          j Wörter mehr reservieren, k Nullwörter, dann übertragen,
  557.     #          bei i>0: um i Bits links schieben (i=1 geht einfacher).
  558.     # y < 0 -> y <= - intDsize * (Länge(A0) in Digits) -> Ergebnis = 0 oder -1.
  559.     #          Sonst: -y = intDsize*k + i mit k<Länge(A0).
  560.     #                  Übertrage die (Länge(A0)-k) MSDigits,
  561.     #                  falls i>0: schiebe sie um i Bits nach rechts (i=1 geht einfacher).
  562.     { if (eq(x,Fixnum_0)) return x; # x=0 -> 0 als Ergebnis
  563.       else
  564.       if (eq(y,Fixnum_0)) return x; # y=0 -> x als Ergebnis
  565.       else
  566.      {SAVE_NUM_STACK # num_stack retten
  567.       if (!(R_minusp(y)))
  568.         # y>0
  569.         if (I_bignump(y) # y ein Bignum
  570.             || ((log2_intDsize+intCsize < oint_data_len) # intDsize*2^intCsize < 2^oint_data_len ?
  571.                 && (as_oint(y) >= as_oint(fixnum(intDsize*bitc(intCsize)))) # ein Fixnum > Bitlänge aller Integers
  572.            )   )
  573.           # y so groß, daß selbst (ASH 1 y) einen Überlauf gäbe.
  574.           goto badamount;
  575.           else
  576.           { var reg2 uintL y_ = (as_oint(y)-as_oint(Fixnum_0))>>oint_data_shift; # Wert von y, >=0, <intDsize*2^intCsize
  577.             var reg2 uintL i = y_%intDsize; # i = y mod intDsize, >=0, <intDsize
  578.             var reg2 uintL k = floor(y_,intDsize); # k = y div intDsize, >=0, <2^intCsize
  579.             var reg5 uintD* LSDptr;
  580.             var reg6 uintC len;
  581.             var reg7 uintD* x_LSDptr;
  582.             I_to_NDS_nocopy(x,_EMA_,len=,x_LSDptr=); # DS zu x bilden.
  583.             if (len >= (uintC)(~(uintC)k)) # kann len+k+1 Überlauf geben?
  584.               goto badamount; # ja -> Fehler
  585.             num_stack_need_1(len+(uintC)k,_EMA_,LSDptr=);
  586.             LSDptr = clear_loop_down(LSDptr,k); # k Nulldigits
  587.            {var reg5 uintD* MSDptr = copy_loop_down(x_LSDptr,LSDptr,len);
  588.             # Nun ist MSDptr/len/LSDptr die DS zu x.
  589.             # Oberhalb von ihr liegen k Nulldigits, unterhalb ist 1 Digit Platz.
  590.             # MSDptr/len+k/.. ist jetzt die Gesamt-DS.
  591.             # Noch um i Bits nach links schieben:
  592.             if (!(i==0)) # Bei i>0
  593.               { # noch ein weiteres Digit dazunehmen (Vorzeichen)
  594.                 {var reg1 uintD sign = sign_of_sintD(MSDptr[0]);
  595.                  *--MSDptr = sign;
  596.                  len++;
  597.                 }
  598.                 # Schiebeschleife: die unteren len Digits um i Bits schieben
  599.                 if (i==1)
  600.                   { shift1left_loop_down(LSDptr,len); }
  601.                   else
  602.                   { shiftleft_loop_down(LSDptr,len,i,0); }
  603.               }
  604.             x = DS_to_I(MSDptr,len+(uintC)k);
  605.           }}
  606.         else
  607.         # y<0
  608.         if (I_bignump(y)) goto sign; # y ein Bignum -> Vorzeichen von x zurück
  609.           else
  610.           { var reg2 uintL y_ = ((as_oint(Fixnum_minus1)-as_oint(y))>>oint_data_shift)+1; # Wert von -y, >0
  611.             var reg2 uintL i = y_%intDsize; # i = (-y) mod intDsize, >=0, <intDsize
  612.             var reg2 uintL k = floor(y_,intDsize); # k = (-y) div intDsize, >=0
  613.             # DS zu x bilden:
  614.             var reg5 uintD* MSDptr;
  615.             var reg6 uintC len;
  616.             I_to_NDS(x, MSDptr=,len=,_EMA_); # DS zu x bilden.
  617.             if (k>=len) goto sign; # -y >= intDsize*len -> Vorzeichen von x zurück
  618.             len -= k; # rechte k Digits einfach streichen
  619.             # Noch ist len>0. Um i Bits nach rechts schieben:
  620.             if (!(i==0)) # Bei i>0:
  621.               { # Schiebe len Digits ab MSDptr um i Bits nach rechts:
  622.                 if (i==1)
  623.                   { shift1right_loop_up(MSDptr,len,sign_of_sintD(MSDptr[0])); }
  624.                   else
  625.                   { shiftrightsigned_loop_up(MSDptr,len,i); }
  626.               }
  627.             x = DS_to_I(MSDptr,len);
  628.           }
  629.       if (FALSE)
  630.         sign: # Ergebnis ist 0, falls x>=0, und -1, falls x<0:
  631.         { x = (R_minusp(x) ? Fixnum_minus1 : Fixnum_0 ); }
  632.       RESTORE_NUM_STACK # num_stack zurück
  633.       return x;
  634.       badamount:
  635.         pushSTACK(y); pushSTACK(S(ash));
  636.         //: DEUTSCH "~: Zu große Schiebezahl ~"
  637.         //: ENGLISH "~: too large shift amount ~"
  638.         //: FRANCAIS "~ : Décalage ~ trop grand"
  639.         fehler(error, GETTEXT("~: too large shift amount ~"));
  640.     }}
  641.  
  642. # (LOGCOUNT x), wo x ein Integer ist. Ergebnis Integer >=0.
  643. # I_logcount_I(x)
  644. # kann GC auslösen
  645.   local object I_logcount_I (object x);
  646.   # Bits von x8 zählen: (Input x8, Output x8)
  647.   #define logcount_8()  \
  648.     ( # x8 besteht aus 8 1-Bit-Zählern (0,1).       \
  649.       x8 = (x8 & 0x55U) + ((x8 & 0xAAU) >> 1),      \
  650.       # x8 besteht aus 4 2-Bit-Zählern (0,1,2).     \
  651.       x8 = (x8 & 0x33U) + ((x8 & 0xCCU) >> 2),      \
  652.       # x8 besteht aus 2 4-Bit-Zählern (0,1,2,3,4). \
  653.       x8 = (x8 & 0x0FU) + (x8 >> 4)                 \
  654.       # x8 besteht aus 1 8-Bit-Zähler (0,...,8).    \
  655.     )
  656.   # Bits von x16 zählen: (Input x16, Output x16)
  657.   #define logcount_16()  \
  658.     ( # x16 besteht aus 16 1-Bit-Zählern (0,1).       \
  659.       x16 = (x16 & 0x5555U) + ((x16 & 0xAAAAU) >> 1), \
  660.       # x16 besteht aus 8 2-Bit-Zählern (0,1,2).      \
  661.       x16 = (x16 & 0x3333U) + ((x16 & 0xCCCCU) >> 2), \
  662.       # x16 besteht aus 4 4-Bit-Zählern (0,1,2,3,4).  \
  663.       x16 = (x16 & 0x0F0FU) + ((x16 & 0xF0F0U) >> 4), \
  664.       # x16 besteht aus 2 8-Bit-Zählern (0,...,8).    \
  665.       x16 = (x16 & 0x00FFU) + (x16 >> 8)              \
  666.       # x16 besteht aus 1 16-Bit-Zähler (0,...,16).   \
  667.     )
  668.   # Bits von x32 zählen: (Input x32, Output x16)
  669.   #define logcount_32()  \
  670.     ( # x32 besteht aus 32 1-Bit-Zählern (0,1).                 \
  671.       x32 = (x32 & 0x55555555UL) + ((x32 & 0xAAAAAAAAUL) >> 1), \
  672.       # x32 besteht aus 16 2-Bit-Zählern (0,1,2).               \
  673.       x32 = (x32 & 0x33333333UL) + ((x32 & 0xCCCCCCCCUL) >> 2), \
  674.       # x32 besteht aus 8 4-Bit-Zählern (0,1,2,3,4).            \
  675.       x16 = high16(x32)+low16(x32),                             \
  676.       # x16 besteht aus 4 4-Bit-Zählern (0,...,8).              \
  677.       x16 = (x16 & 0x0F0FU) + ((x16 & 0xF0F0U) >> 4),           \
  678.       # x16 besteht aus 2 8-Bit-Zählern (0,...,16).             \
  679.       x16 = (x16 & 0x00FFU) + (x16 >> 8)                        \
  680.       # x16 besteht aus 1 16-Bit-Zähler (0,...,32).             \
  681.     )
  682.   #if (intWLsize==intLsize)
  683.     #define x16  x32
  684.   #endif
  685.   local object I_logcount_I(x)
  686.     var reg3 object x;
  687.     { if (I_fixnump(x))
  688.         { var reg1 uint16 x16; # Hilfsvariable
  689.          {var reg1 uint32 x32 = FN_to_L(x); # x als 32-Bit-Zahl
  690.           if (FN_L_minusp(x,(sint32)x32)) { x32 = ~ x32; } # falls <0, komplementieren
  691.           logcount_32(); # Bits von x32 zählen
  692.           return fixnum((uintL)x16);
  693.         }}
  694.         else
  695.         { var reg6 uintD* MSDptr;
  696.           var reg3 uintC len;
  697.           BN_to_NDS_nocopy(x, MSDptr=,len=,_EMA_); # DS zu x bilden, len>0.
  698.          {var reg4 uintL bitcount = 0; # Bitzähler
  699.           var reg2 uintD* ptr = MSDptr; # läuft durch die Digits durch
  700.           var reg5 uintD sign = sign_of_sintD(ptr[0]); # Vorzeichen
  701.           #if (intDsize==8)
  702.           dotimespC(len,len,
  703.             { var reg1 uintD x8 = (*ptr++) ^ sign; # nächstes intDsize-Bit-Paket,
  704.                                     # bei negativen Zahlen komplementiert
  705.               # Bits von x8 zählen, Gesamtzähler erhöhen:
  706.               bitcount += (uintL)(logcount_8(), x8);
  707.             });
  708.           #endif
  709.           #if (intDsize==16)
  710.           dotimespC(len,len,
  711.             { var reg1 uintD x16 = (*ptr++) ^ sign; # nächstes intDsize-Bit-Paket,
  712.                                     # bei negativen Zahlen komplementiert
  713.               # Bits von x16 zählen, Gesamtzähler erhöhen:
  714.               bitcount += (uintL)(logcount_16(), x16);
  715.             });
  716.           #endif
  717.           #if (intDsize==32)
  718.           dotimespC(len,len,
  719.             { var reg1 uint16 x16; # Hilfsvariable
  720.              {var reg1 uintD x32 = (*ptr++) ^ sign; # nächstes intDsize-Bit-Paket,
  721.                                     # bei negativen Zahlen komplementiert
  722.               # Bits von x32 zählen, Gesamtzähler erhöhen:
  723.               bitcount += (uintL)(logcount_32(), x16);
  724.             }});
  725.           #endif
  726.           # 0 <= bitcount < intDsize*2^intCsize, paßt evtl. in ein Fixnum.
  727.           if (log2_intDsize+intCsize<=oint_data_len) # intDsize*2^intCsize <= 2^oint_data_len ?
  728.             return fixnum(bitcount);
  729.             else
  730.             return UL_to_I(bitcount);
  731.     }   }}
  732.   #undef x16
  733.   #undef logcount_32
  734.   #undef logcount_16
  735.   #undef logcount_8
  736.  
  737. # Bits eines Digit zählen:
  738. # integerlengthD(digit,size=);
  739. # setzt size auf die höchste in digit vorkommende Bitnummer.
  740. # > digit: ein uintD >0
  741. # < size: >0, <=intDsize, mit 2^(size-1) <= digit < 2^size
  742. #if defined(GNU) && defined(MC680Y0) && !defined(NO_ASM)
  743.   #define integerlength8(digit,size_zuweisung)  \
  744.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit          \
  745.       __asm__("bfffo %1{#0:#8},%0" : "=d" (zero_counter) : "dm" ((uint8)(digit)) ); \
  746.       size_zuweisung (8-zero_counter);                                              \
  747.     }
  748. #elif defined(SPARC)
  749.   #define integerlength8(digit,size_zuweisung)  \
  750.     integerlength32((uint32)(digit),size_zuweisung) # siehe unten
  751. #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  752.   #define integerlength8(digit,size_zuweisung)  \
  753.     integerlength16((uint16)(digit),size_zuweisung)
  754. #else
  755.   #define integerlength8(digit,size_zuweisung)  \
  756.     { var reg2 uintC bitsize = 1;                            \
  757.       var reg1 uintBWL x8 = (uint8)(digit);                  \
  758.       # x8 hat höchstens 8 Bits.                             \
  759.       if (x8 >= bit(4)) { x8 = x8>>4; bitsize += 4; }        \
  760.       # x8 hat höchstens 4 Bits.                             \
  761.       if (x8 >= bit(2)) { x8 = x8>>2; bitsize += 2; }        \
  762.       # x8 hat höchstens 2 Bits.                             \
  763.       if (x8 >= bit(1)) { /* x8 = x8>>1; */ bitsize += 1; }  \
  764.       # x8 hat höchstens 1 Bit. Dieses Bit muß gesetzt sein. \
  765.       size_zuweisung bitsize;                                \
  766.     }
  767. #endif
  768. #if defined(GNU) && defined(MC680Y0) && !defined(NO_ASM)
  769.   #define integerlength16(digit,size_zuweisung)  \
  770.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit            \
  771.       __asm__("bfffo %1{#0:#16},%0" : "=d" (zero_counter) : "dm" ((uint16)(digit)) ); \
  772.       size_zuweisung (16-zero_counter);                                               \
  773.     }
  774. #elif defined(SPARC)
  775.   #define integerlength16(digit,size_zuweisung)  \
  776.     integerlength32((uint32)(digit),size_zuweisung) # siehe unten
  777. #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  778.   #define integerlength16(digit,size_zuweisung)  \
  779.     { var reg1 uintW one_position; # Position der führenden 1               \
  780.       __asm__("bsrw %1,%0" : "=r" (one_position) : "r" ((uint16)(digit)) ); \
  781.       size_zuweisung (1+one_position);                                      \
  782.     }
  783. # Die weiteren kommen von gcc/longlong.h :
  784. #elif defined(GNU) && defined(__ibm032__) && !defined(NO_ASM) # RT/ROMP
  785.   #define integerlength16(digit,size_zuweisung)  \
  786.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit \
  787.       __asm__("clz %0,%1" : "=r" (zero_counter) : "r" ((uint32)(digit)) ); \
  788.       size_zuweisung (16-zero_counter);                                    \
  789.     }
  790. #else
  791.   #define integerlength16(digit,size_zuweisung)  \
  792.     { var reg2 uintC bitsize = 1;                              \
  793.       var reg1 uintWL x16 = (uint16)(digit);                   \
  794.       # x16 hat höchstens 16 Bits.                             \
  795.       if (x16 >= bit(8)) { x16 = x16>>8; bitsize += 8; }       \
  796.       # x16 hat höchstens 8 Bits.                              \
  797.       if (x16 >= bit(4)) { x16 = x16>>4; bitsize += 4; }       \
  798.       # x16 hat höchstens 4 Bits.                              \
  799.       if (x16 >= bit(2)) { x16 = x16>>2; bitsize += 2; }       \
  800.       # x16 hat höchstens 2 Bits.                              \
  801.       if (x16 >= bit(1)) { /* x16 = x16>>1; */ bitsize += 1; } \
  802.       # x16 hat höchstens 1 Bit. Dieses Bit muß gesetzt sein.  \
  803.       size_zuweisung bitsize;                                  \
  804.     }
  805. #endif
  806. #if defined(GNU) && defined(MC680Y0) && !defined(NO_ASM)
  807.   #define integerlength32(digit,size_zuweisung)  \
  808.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit            \
  809.       __asm__("bfffo %1{#0:#32},%0" : "=d" (zero_counter) : "dm" ((uint32)(digit)) ); \
  810.       size_zuweisung (32-zero_counter);                                               \
  811.     }
  812. #elif defined(SPARC) && defined(FAST_DOUBLE)
  813.   #define integerlength32(digit,size_zuweisung)  \
  814.     {var union { double f; uint32 i[2]; } __fi;                     \
  815.      # Bilde 2^52 + digit:                                          \
  816.      __fi.i[0] = (uint32)(DF_mant_len+1+DF_exp_mid) << (DF_mant_len-32); # Vorzeichen 0, Exponent 53 \
  817.      __fi.i[1] = (digit); # untere 32 Bits setzen (benutzt BIG_ENDIAN_P !) \
  818.      # subtrahiere 2^52:                                            \
  819.      __fi.f = __fi.f - (double)(4503599627370496.0L);               \
  820.      # Hole davon den Exponenten:                                   \
  821.      size_zuweisung ((__fi.i[0] >> (DF_mant_len-32)) - DF_exp_mid); \
  822.     }
  823. #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  824.   #define integerlength32(digit,size_zuweisung)  \
  825.     { var reg1 uintL one_position; # Position der führenden 1                \
  826.       __asm__("bsrl %1,%0" : "=r" (one_position) : "rm" ((uint32)(digit)) ); \
  827.       size_zuweisung (1+one_position);                                       \
  828.     }
  829. #elif defined(HPPA) && !defined(NO_ASM)
  830.   #define integerlength32(digit,size_zuweisung)  \
  831.     size_zuweisung length32(digit);
  832.   extern uintL length32 (uintL digit); # extern in Assembler
  833. # Die weiteren kommen von gcc/longlong.h :
  834. #elif defined(GNU) && (defined(__a29k__) || defined(___AM29K__)) && !defined(NO_ASM)
  835.   #define integerlength32(digit,size_zuweisung)  \
  836.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit \
  837.       __asm__("clz %0,%1" : "=r" (zero_counter) : "r" ((uint32)(digit)) ); \
  838.       size_zuweisung (32-zero_counter);                                    \
  839.     }
  840. #elif defined(GNU) && defined(__gmicro__) && !defined(NO_ASM)
  841.   #define integerlength32(digit,size_zuweisung)  \
  842.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit    \
  843.       __asm__("bsch/1 %1,%0" : "=g" (zero_counter) : "g" ((uint32)(digit)) ); \
  844.       size_zuweisung (32-zero_counter);                                       \
  845.     }
  846. #elif defined(GNU) && defined(RS6000) && !defined(NO_ASM)
  847.   #define integerlength32(digit,size_zuweisung)  \
  848.     { var reg1 uintL zero_counter; # zählt die führenden Nullbits in digit   \
  849.       __asm__("cntlz %0,%1" : "=r" (zero_counter) : "r" ((uint32)(digit)) ); \
  850.       size_zuweisung (32-zero_counter);                                      \
  851.     }
  852. #elif defined(GNU) && defined(M88000) && !defined(NO_ASM)
  853.   #define integerlength32(digit,size_zuweisung)  \
  854.     { var reg1 uintL one_position; # Position der führenden 1              \
  855.       __asm__("ff1 %0,%1" : "=r" (one_position) : "r" ((uint32)(digit)) ); \
  856.       size_zuweisung (1+one_position);                                     \
  857.     }
  858. #elif defined(GNU) && defined(__ibm032__) && !defined(NO_ASM) # RT/ROMP
  859.   #define integerlength32(digit,size_zuweisung)  \
  860.     { var reg2 uintL x32 = (uint32)(digit);                \
  861.       if (x32 >= bit(16))                                  \
  862.         { integerlength16(x32>>16,size_zuweisung 16 + ); } \
  863.         else                                               \
  864.         { integerlength16(x32,size_zuweisung); }           \
  865.     }
  866. #else
  867.   #if (intWLsize==intLsize)
  868.     #define integerlength32(digit,size_zuweisung)  \
  869.       { var reg2 uintC bitsize = 1;                              \
  870.         var reg1 uintL x32 = (uint32)(digit);                    \
  871.         # x32 hat höchstens 32 Bits.                             \
  872.         if (x32 >= bit(16)) { x32 = x32>>16; bitsize += 16; }    \
  873.         # x32 hat höchstens 16 Bits.                             \
  874.         if (x32 >= bit(8)) { x32 = x32>>8; bitsize += 8; }       \
  875.         # x32 hat höchstens 8 Bits.                              \
  876.         if (x32 >= bit(4)) { x32 = x32>>4; bitsize += 4; }       \
  877.         # x32 hat höchstens 4 Bits.                              \
  878.         if (x32 >= bit(2)) { x32 = x32>>2; bitsize += 2; }       \
  879.         # x32 hat höchstens 2 Bits.                              \
  880.         if (x32 >= bit(1)) { /* x32 = x32>>1; */ bitsize += 1; } \
  881.         # x32 hat höchstens 1 Bit. Dieses Bit muß gesetzt sein.  \
  882.         size_zuweisung bitsize;                                  \
  883.       }
  884.   #else
  885.     #define integerlength32(digit,size_zuweisung)  \
  886.       { var reg3 uintC bitsize = 1;                              \
  887.         var reg2 uintL x32 = (digit);                            \
  888.         var reg1 uintWL x16;                                     \
  889.         # x32 hat höchstens 32 Bits.                             \
  890.         if (x32 >= bit(16)) { x16 = x32>>16; bitsize += 16; } else { x16 = x32; } \
  891.         # x16 hat höchstens 16 Bits.                             \
  892.         if (x16 >= bit(8)) { x16 = x16>>8; bitsize += 8; }       \
  893.         # x16 hat höchstens 8 Bits.                              \
  894.         if (x16 >= bit(4)) { x16 = x16>>4; bitsize += 4; }       \
  895.         # x16 hat höchstens 4 Bits.                              \
  896.         if (x16 >= bit(2)) { x16 = x16>>2; bitsize += 2; }       \
  897.         # x16 hat höchstens 2 Bits.                              \
  898.         if (x16 >= bit(1)) { /* x16 = x16>>1; */ bitsize += 1; } \
  899.         # x16 hat höchstens 1 Bit. Dieses Bit muß gesetzt sein.  \
  900.         size_zuweisung bitsize;                                  \
  901.       }
  902.   #endif
  903. #endif
  904. #if (intDsize==8)
  905.   #define integerlengthD  integerlength8
  906. #endif
  907. #if (intDsize==16)
  908.   #define integerlengthD  integerlength16
  909. #endif
  910. #if (intDsize==32)
  911.   #define integerlengthD  integerlength32
  912. #endif
  913.  
  914. # (INTEGER-LENGTH x), wo x ein Integer ist. Ergebnis uintL.
  915. # I_integer_length(x)
  916.   global uintL I_integer_length (object x);
  917.   global uintL I_integer_length(x)
  918.     var reg3 object x;
  919.     { if (I_fixnump(x))
  920.         { var reg2 uintL bitcount = 0;
  921.           var reg1 uint32 x_ = FN_to_L(x); # x als 32-Bit-Zahl
  922.           if (FN_L_minusp(x,(sint32)x_)) { x_ = ~ x_; } # falls <0, komplementieren
  923.           if (!(x_==0)) { integerlength32(x_,bitcount=); }
  924.           return bitcount; # 0 <= bitcount < 32.
  925.         }
  926.         else
  927.         { var reg4 uintD* MSDptr;
  928.           var reg5 uintC len;
  929.           BN_to_NDS_nocopy(x, MSDptr=,len=,_EMA_); # normalisierte DS zu x bilden.
  930.          {var reg2 uintL bitcount = intDsize*(uintL)(len-1); # Anzahl Digits mal intDsize
  931.           # MSDigit nehmen, testen, welches das höchste Bit ist, das vom
  932.           # Vorzeichenbit abweicht:
  933.           var reg1 uintD msd = MSDptr[0]; # MSDigit
  934.           if ((sintD)msd < 0) { msd = ~msd; } # falls negativ, invertieren
  935.           # Position des höchsten Bits in msd suchen und entsprechend bit_count
  936.           # erhöhen (um höchstens intDsize-1):
  937.           if (!(msd == 0)) { integerlengthD(msd, bitcount += ); }
  938.           return bitcount; # 0 <= bitcount < intDsize*2^intCsize.
  939.     }   }}
  940.  
  941. # (INTEGER-LENGTH x), wo x ein Integer ist. Ergebnis Integer >=0.
  942. # I_integer_length_I(x)
  943. # kann GC auslösen
  944.   local object I_integer_length_I (object x);
  945.   local object I_integer_length_I(x)
  946.     var reg3 object x;
  947.     { if (I_fixnump(x))
  948.         { var reg2 uintL bitcount = 0;
  949.           var reg1 uint32 x_ = FN_to_L(x); # x als 32-Bit-Zahl
  950.           if (FN_L_minusp(x,(sint32)x_)) { x_ = ~ x_; } # falls <0, komplementieren
  951.           if (!(x_==0)) { integerlength32(x_,bitcount=); }
  952.           # 0 <= bitcount < 32, paßt in ein Fixnum.
  953.           return fixnum(bitcount);
  954.         }
  955.         else
  956.         { var reg4 uintD* MSDptr;
  957.           var reg5 uintC len;
  958.           BN_to_NDS_nocopy(x, MSDptr=,len=,_EMA_); # normalisierte DS zu x bilden.
  959.          {var reg2 uintL bitcount = intDsize*(uintL)(len-1); # Anzahl Digits mal intDsize
  960.           # MSDigit nehmen, testen, welches das höchste Bit ist, das vom
  961.           # Vorzeichenbit abweicht:
  962.           var reg1 uintD msd = MSDptr[0]; # MSDigit
  963.           if ((sintD)msd < 0) { msd = ~msd; } # falls negativ, invertieren
  964.           # Position des höchsten Bits in msd suchen und entsprechend bit_count
  965.           # erhöhen (um höchstens intDsize-1):
  966.           if (!(msd == 0)) { integerlengthD(msd, bitcount += ); }
  967.           # 0 <= bitcount < intDsize*2^intCsize, paßt evtl. in ein Fixnum.
  968.           if (log2_intDsize+intCsize<=oint_data_len) # intDsize*2^intCsize <= 2^oint_data_len ?
  969.             return fixnum(bitcount);
  970.             else
  971.             return UL_to_I(bitcount);
  972.     }   }}
  973.  
  974. # Hintere Nullbits eines 32-Bit-Wortes zählen:
  975. # ord2_32(digit,count=);
  976. # setzt size auf die kleinste in digit vorkommende Bitnummer.
  977. # > digit: ein uint32 >0
  978. # < count: >=0, <32, mit 2^count | digit, digit/2^count ungerade
  979.   #if defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  980.     #define ord2_32(digit,count_zuweisung)  \
  981.       { var reg1 uintL one_position; # Position der letzten 1                  \
  982.         __asm__("bsfl %1,%0" : "=r" (one_position) : "rm" ((uint32)(digit)) ); \
  983.         count_zuweisung one_position;                                          \
  984.       }
  985.   #endif
  986.  
  987. # Hintere Nullbits eines Digits zählen:
  988. # ord2_D(digit,count=);
  989. # setzt size auf die kleinste in digit vorkommende Bitnummer.
  990. # > digit: ein uintD >0
  991. # < count: >=0, <intDsize, mit 2^count | digit, digit/2^count ungerade
  992.   #ifdef ord2_32
  993.     #define ord2_D(digit,count_zuweisung)  \
  994.       ord2_32((uint32)(digit),count_zuweisung)
  995.   #endif
  996.  
  997. # (ORD2 x) = max{n>=0: 2^n | x }, wo x ein Integer /=0 ist. Ergebnis uintL.
  998. # I_ord2(x)
  999.   local uintL I_ord2 (object x);
  1000. # Methode 1a:
  1001. #   Sei n = ord2(x). Dann ist logxor(x,x-1) = 2^n + (2^n-1) = 2^(n+1)-1.
  1002. #   Also  (ord2 x) = (1- (integer-length (logxor x (1- x)))) .
  1003. # Methode 1b:
  1004. #   Sei n = ord2(x). Dann ist logand(x,-x) = 2^n.
  1005. #   Also  (ord2 x) = (1- (integer-length (logand x (- x)))) .
  1006. # Methode 1c:
  1007. #   Sei n = ord2(x). Dann ist lognot(logior(x,-x)) = 2^n-1.
  1008. #   Also  (ord2 x) = (integer-length (lognot (logior x (- x)))) .
  1009. # Methode 2:
  1010. #   Nullbits am Schluß von x abzählen:
  1011. #   (ord2 x) = intDsize * Anzahl der Nulldigits am Schluß
  1012. #              + Anzahl der Nullbits am Ende des letzten Digits /=0.
  1013.   #ifndef ord2_32
  1014.     # Hier muß digit eine Variable sein. digit wird verändert!
  1015.     #define ord2_32(digit,count_zuweisung)  \
  1016.       digit = digit ^ (digit - 1); # Methode 1a \
  1017.       integerlength32(digit,count_zuweisung -1 + )
  1018.   #endif
  1019.   #ifndef ord2_D
  1020.     # Hier muß digit eine Variable sein. digit wird verändert!
  1021.     #define ord2_D(digit,count_zuweisung)  \
  1022.       digit = digit ^ (digit - 1); # Methode 1a \
  1023.       integerlengthD(digit,count_zuweisung -1 + )
  1024.   #endif
  1025.   local uintL I_ord2(x)
  1026.     var reg4 object x;
  1027.     { if (I_fixnump(x))
  1028.         { var reg1 uint32 x_ = FN_to_L(x); # x als 32-Bit-Zahl
  1029.           #if (oint_data_len < 32)
  1030.           ord2_32(x_,return);
  1031.           #else # oint_data_len=32, x_ kann auch =0 sein.
  1032.           # Bei x = most-negative-fixnum funktioniert nur Methode 1c.
  1033.           x_ = x_ | (- x_); x_ = ~ x_;
  1034.           integerlength32(x_,return);
  1035.           #endif
  1036.         }
  1037.         else
  1038.         { var reg2 uintL bitcount = 0;
  1039.           var reg1 uintD* ptr;
  1040.           BN_to_NDS_nocopy(x,_EMA_,_EMA_,ptr=); # normalisierte DS zu x bilden.
  1041.           while (*--ptr == 0) { bitcount += intDsize; } # Nulldigits abzählen
  1042.          {var reg3 uintD lsd = *ptr; # letztes Digit /=0
  1043.           ord2_D(lsd,bitcount +=); # dessen Nullbits abzählen
  1044.           return bitcount;
  1045.         }}
  1046.     }
  1047.  
  1048. # I_power2p(x) stellt fest, ob ein Integer x>0 eine Zweierpotenz ist.
  1049. # Ergebnis: n>0, wenn x=2^(n-1), 0 sonst.
  1050.   local uintL I_power2p (object x);
  1051. # Methode 1: Wenn ord2(x) = integer_length(x)-1.
  1052. # Methode 2: Wenn logand(x,x-1) = 0.
  1053. # Methode 3: Wenn das erste Digit /=0 eine Zweierpotenz ist und alle weiteren
  1054. #            Digits Null sind.
  1055.   local uintL I_power2p(x)
  1056.     var reg2 object x;
  1057.     { if (I_fixnump(x))
  1058.         { var reg1 uintL x_ = posfixnum_to_L(x);
  1059.           if (!((x_ & (x_-1)) == 0)) return 0; # keine Zweierpotenz
  1060.           integerlength32(x_,return); # Zweierpotenz: n = integer_length(x)
  1061.         }
  1062.         else
  1063.         { var reg1 uintD* MSDptr;
  1064.           var reg4 uintC len;
  1065.           BN_to_NDS_nocopy(x, MSDptr=,len=,_EMA_); # normalisierte DS zu x bilden.
  1066.          {var reg3 uintD msd = MSDptr[0];
  1067.           if (msd==0) { MSDptr++; msd = MSDptr[0]; len--; }
  1068.           # len = Anzahl der Digits ab MSDptr, len>0, msd = erstes Digit (/=0)
  1069.           if (!((msd & (msd-1)) == 0)) return 0; # erstes Digit muß Zweierpotenz sein
  1070.           if (test_loop_up(&MSDptr[1],len-1)) return 0; # danach alles Nullen
  1071.           {var reg5 uintL msdlen;
  1072.            integerlengthD(msd, msdlen=);
  1073.            return intDsize*(uintL)len + msdlen; # integer_length(x) als Ergebnis
  1074.         }}}
  1075.     }
  1076.  
  1077.