home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / intlog.d < prev    next >
Encoding:
Text File  |  1994-06-18  |  45.8 KB  |  1,083 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,,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=,); # 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.             fehler(type_error,
  406.                    DEUTSCH ? "~: ~ ist keine gⁿltige Boolesche Operation." :
  407.                    ENGLISH ? "~: ~ is not a valid boolean operation" :
  408.                    FRANCAIS ? "~ : ~ n'est pas une opΘration boolΘenne admise." :
  409.                    ""
  410.                   );
  411.     }   }
  412.  
  413. # Prⁿft, ob (LOGTEST x y), wo x und y Integers sind.
  414. # (LOGTEST x y) = (NOT (ZEROP (LOGAND x y))).
  415. # I_I_logtest(x,y)
  416. # < ergebnis: /=0, falls ja; =0, falls nein.
  417.   local boolean I_I_logtest (object x, object y);
  418.   local boolean I_I_logtest(x,y)
  419.     var reg4 object x;
  420.     var reg5 object y;
  421.     # Methode:
  422.     #  Fixnums separat behandeln.
  423.     #  Sei oBdA x die kⁿrzere der beiden Zahlen (in Digits).
  424.     #  x echt kⁿrzer und x<0 -> [eines der most signif. intDsize+1 Bits von y ist 1] Ja.
  425.     #  Beide gleich lang oder x>=0 ->
  426.     #   Kann mich auf die untersten length(x) Digits beschraenken.
  427.     #   Mit AND durchlaufen, abbrechen (mit "Ja") falls /=0. Am Ende: Nein.
  428.     { if (I_fixnump(x))
  429.         if (I_fixnump(y))
  430.           # beides Fixnums
  431.           { if ((as_oint(x) & as_oint(y) & FN_value_vz_mask)==0)
  432.               return FALSE;
  433.               else
  434.               return TRUE;
  435.           }
  436.           else
  437.           # x Fixnum, y Bignum, also ist x echt kⁿrzer
  438.           { xFN_yBN:
  439.             if (R_minusp(x)) return TRUE; # x<0 -> ja.
  440.             # x>=0. Kombiniere x mit den pFN_maxlength letzten Digits von y.
  441.            {var reg7 uintD* yLSDptr;
  442.             var reg6 uintL x_ = posfixnum_to_L(x);
  443.             BN_to_NDS_nocopy(y, ,,yLSDptr=);
  444.             #if (pFN_maxlength > 1)
  445.             doconsttimes(pFN_maxlength-1,
  446.               if (*--yLSDptr & (uintD)x_) return TRUE;
  447.               x_ = x_ >> intDsize;
  448.               );
  449.             #endif
  450.             if (*--yLSDptr & (uintD)x_) return TRUE;
  451.             return FALSE;
  452.           }}
  453.         else
  454.         if (I_fixnump(y))
  455.           # x Bignum, y Fixnum
  456.           {{var reg1 object h = x; x = y; y = h; } # x und y vertauschen
  457.            goto xFN_yBN; # und weiter wie oben
  458.           }
  459.           else
  460.           # x,y Bignums
  461.           { var reg6 uintD* xMSDptr;
  462.             var reg6 uintC xlen;
  463.             var reg6 uintD* yMSDptr;
  464.             var reg6 uintC ylen;
  465.             BN_to_NDS_nocopy(x, xMSDptr=,xlen=,);
  466.             BN_to_NDS_nocopy(y, yMSDptr=,ylen=,);
  467.             # Beachte: xlen>0, ylen>0.
  468.             if (!(xlen==ylen))
  469.               # beide verschieden lang
  470.               { if (xlen>ylen)
  471.                   # vertauschen
  472.                   {{var reg1 uintD* temp = xMSDptr; xMSDptr = yMSDptr; yMSDptr = temp; }
  473.                    xlen = ylen;
  474.                   }
  475.                 # jetzt ist x die echt kⁿrzere DS.
  476.                 if ((sintD)xMSDptr[0]<0) # der echt kⁿrzere ist negativ?
  477.                   return TRUE;
  478.                 # Der echt kⁿrzere ist positiv.
  479.               }
  480.             # xMSDptr/xlen/.. ist die kⁿrzere DS, yMSDptr/../.. ist die lΣngere DS.
  481.             return and_test_loop_up(xMSDptr,yMSDptr,xlen);
  482.     }     }
  483.  
  484. # Prⁿft, ob (LOGBITP x y), wo x und y Integers sind.
  485. # I_I_logbitp(x,y)
  486. # Ergebnis: /=0, wenn ja; =0, wenn nein.
  487.   local boolean I_I_logbitp (object x, object y);
  488.   local boolean I_I_logbitp(x,y)
  489.     var reg4 object x;
  490.     var reg5 object y;
  491.     # Methode:
  492.     # Falls x<0, Error.
  493.     # Falls x>=0: Falls x>=intDsize*LΣnge(y), teste Vorzeichen von y.
  494.     #             Sonst x=intDsize*k+i, Teste Bit i vom Worte Nr. k+1 (von oben herab).
  495.     { if (!R_minusp(x)) # x>=0 ?
  496.         { if (I_fixnump(x))
  497.             { var reg1 uintL x_ = posfixnum_to_L(x);
  498.               var reg2 uintC ylen;
  499.               var reg3 uintD* yLSDptr;
  500.               I_to_NDS_nocopy(y, ,ylen=,yLSDptr=); # DS zu y
  501.               if (x_ < intDsize*(uintL)ylen)
  502.                 # x ist ein Fixnum >=0, < intDsize*ylen
  503.                 { if (yLSDptr[-(uintP)floor(x_,intDsize)-1] & bit(x_%intDsize))
  504.                     return TRUE;
  505.                     else
  506.                     return FALSE;
  507.             }   }
  508.           # Vorzeichen von y testen
  509.           if (R_minusp(y))
  510.             return TRUE;
  511.             else
  512.             return FALSE;
  513.         }
  514.         else
  515.         # x<0
  516.         { pushSTACK(x); # Wert fⁿr Slot DATUM von TYPE-ERROR
  517.           pushSTACK(O(type_posinteger)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  518.           pushSTACK(x); pushSTACK(S(logbitp));
  519.           fehler(type_error,
  520.                  DEUTSCH ? "~: Negativer Index: ~" :
  521.                  ENGLISH ? "~: index ~ is negative" :
  522.                  FRANCAIS ? "~ : Index nΘgatif: ~" :
  523.                  ""
  524.                 );
  525.     }   }
  526.  
  527. # Prⁿft, ob (ODDP x), wo x ein Integer ist.
  528. # I_oddp(x)
  529. # Ergebnis: /=0, falls ja; =0, falls nein.
  530.   local boolean I_oddp (object x);
  531.   local boolean I_oddp(x)
  532.     var reg1 object x;
  533.     { if (I_fixnump(x))
  534.         # Fixnum: Bit 0 abprⁿfen
  535.         { if (as_oint(x) & wbit(0+oint_data_shift))
  536.             return TRUE;
  537.             else
  538.             return FALSE;
  539.         }
  540.         else
  541.         # Bignum: Bit 0 im letzten Digit abprⁿfen
  542.         { var reg1 Bignum x_ = TheBignum(x);
  543.           if (x_->data[(uintP)(x_->length)-1] & bit(0))
  544.             return TRUE;
  545.             else
  546.             return FALSE;
  547.     }   }
  548.  
  549. # (ASH x y), wo x und y Integers sind. Ergebnis Integer.
  550. # I_I_ash_I(x,y)
  551. # kann GC ausl÷sen
  552.   global object I_I_ash_I (object x, object y);
  553.   global object I_I_ash_I(x,y)
  554.     var reg3 object x;
  555.     var reg4 object y;
  556.     # Methode:
  557.     # x = 0 -> 0 als Ergebnis
  558.     # y = 0 -> x als Ergebnis
  559.     # y > 0 -> y = intDsize*k + i, j=k+(1 falls i>0, 0 falls i=0).
  560.     #          j W÷rter mehr reservieren, k Nullw÷rter, dann ⁿbertragen,
  561.     #          bei i>0: um i Bits links schieben (i=1 geht einfacher).
  562.     # y < 0 -> y <= - intDsize * (LΣnge(A0) in Digits) -> Ergebnis = 0 oder -1.
  563.     #          Sonst: -y = intDsize*k + i mit k<LΣnge(A0).
  564.     #                  ▄bertrage die (LΣnge(A0)-k) MSDigits,
  565.     #                  falls i>0: schiebe sie um i Bits nach rechts (i=1 geht einfacher).
  566.     { if (eq(x,Fixnum_0)) return x; # x=0 -> 0 als Ergebnis
  567.       else
  568.       if (eq(y,Fixnum_0)) return x; # y=0 -> x als Ergebnis
  569.       else
  570.      {SAVE_NUM_STACK # num_stack retten
  571.       if (!(R_minusp(y)))
  572.         # y>0
  573.         if (I_bignump(y) # y ein Bignum
  574.             || ((log2_intDsize+intCsize < oint_data_len) # intDsize*2^intCsize < 2^oint_data_len ?
  575.                 && (as_oint(y) >= as_oint(fixnum(intDsize*bitc(intCsize)))) # ein Fixnum > BitlΣnge aller Integers
  576.            )   )
  577.           # y so gro▀, da▀ selbst (ASH 1 y) einen ▄berlauf gΣbe.
  578.           goto badamount;
  579.           else
  580.           { var reg2 uintL y_ = (as_oint(y)-as_oint(Fixnum_0))>>oint_data_shift; # Wert von y, >=0, <intDsize*2^intCsize
  581.             var reg2 uintL i = y_%intDsize; # i = y mod intDsize, >=0, <intDsize
  582.             var reg2 uintL k = floor(y_,intDsize); # k = y div intDsize, >=0, <2^intCsize
  583.             var reg5 uintD* LSDptr;
  584.             var reg6 uintC len;
  585.             var reg7 uintD* x_LSDptr;
  586.             I_to_NDS_nocopy(x, ,len=,x_LSDptr=); # DS zu x bilden.
  587.             if (len >= (uintC)(~(uintC)k)) # kann len+k+1 ▄berlauf geben?
  588.               goto badamount; # ja -> Fehler
  589.             num_stack_need_1(len+(uintC)k,,LSDptr=);
  590.             LSDptr = clear_loop_down(LSDptr,k); # k Nulldigits
  591.            {var reg5 uintD* MSDptr = copy_loop_down(x_LSDptr,LSDptr,len);
  592.             # Nun ist MSDptr/len/LSDptr die DS zu x.
  593.             # Oberhalb von ihr liegen k Nulldigits, unterhalb ist 1 Digit Platz.
  594.             # MSDptr/len+k/.. ist jetzt die Gesamt-DS.
  595.             # Noch um i Bits nach links schieben:
  596.             if (!(i==0)) # Bei i>0
  597.               { # noch ein weiteres Digit dazunehmen (Vorzeichen)
  598.                 {var reg1 uintD sign = sign_of_sintD(MSDptr[0]);
  599.                  *--MSDptr = sign;
  600.                  len++;
  601.                 }
  602.                 # Schiebeschleife: die unteren len Digits um i Bits schieben
  603.                 if (i==1)
  604.                   { shift1left_loop_down(LSDptr,len); }
  605.                   else
  606.                   { shiftleft_loop_down(LSDptr,len,i,0); }
  607.               }
  608.             x = DS_to_I(MSDptr,len+(uintC)k);
  609.           }}
  610.         else
  611.         # y<0
  612.         if (I_bignump(y)) goto sign; # y ein Bignum -> Vorzeichen von x zurⁿck
  613.           else
  614.           { var reg2 uintL y_ = ((as_oint(Fixnum_minus1)-as_oint(y))>>oint_data_shift)+1; # Wert von -y, >0
  615.             var reg2 uintL i = y_%intDsize; # i = (-y) mod intDsize, >=0, <intDsize
  616.             var reg2 uintL k = floor(y_,intDsize); # k = (-y) div intDsize, >=0
  617.             # DS zu x bilden:
  618.             var reg5 uintD* MSDptr;
  619.             var reg6 uintC len;
  620.             I_to_NDS(x, MSDptr=,len=,); # DS zu x bilden.
  621.             if (k>=len) goto sign; # -y >= intDsize*len -> Vorzeichen von x zurⁿck
  622.             len -= k; # rechte k Digits einfach streichen
  623.             # Noch ist len>0. Um i Bits nach rechts schieben:
  624.             if (!(i==0)) # Bei i>0:
  625.               { # Schiebe len Digits ab MSDptr um i Bits nach rechts:
  626.                 if (i==1)
  627.                   { shift1right_loop_up(MSDptr,len,sign_of_sintD(MSDptr[0])); }
  628.                   else
  629.                   { shiftrightsigned_loop_up(MSDptr,len,i); }
  630.               }
  631.             x = DS_to_I(MSDptr,len);
  632.           }
  633.       if (FALSE)
  634.         sign: # Ergebnis ist 0, falls x>=0, und -1, falls x<0:
  635.         { x = (R_minusp(x) ? Fixnum_minus1 : Fixnum_0 ); }
  636.       RESTORE_NUM_STACK # num_stack zurⁿck
  637.       return x;
  638.       badamount:
  639.         pushSTACK(y); pushSTACK(S(ash));
  640.         fehler(error,
  641.                DEUTSCH ? "~: Zu gro▀e Schiebezahl ~" :
  642.                ENGLISH ? "~: too large shift amount ~" :
  643.                FRANCAIS ? "~ : DΘcalage ~ trop grand" :
  644.                ""
  645.               );
  646.     }}
  647.  
  648. # (LOGCOUNT x), wo x ein Integer ist. Ergebnis Integer >=0.
  649. # I_logcount_I(x)
  650. # kann GC ausl÷sen
  651.   local object I_logcount_I (object x);
  652.   # Bits von x8 zΣhlen: (Input x8, Output x8)
  653.   #define logcount_8()  \
  654.     ( # x8 besteht aus 8 1-Bit-ZΣhlern (0,1).       \
  655.       x8 = (x8 & 0x55U) + ((x8 & 0xAAU) >> 1),      \
  656.       # x8 besteht aus 4 2-Bit-ZΣhlern (0,1,2).     \
  657.       x8 = (x8 & 0x33U) + ((x8 & 0xCCU) >> 2),      \
  658.       # x8 besteht aus 2 4-Bit-ZΣhlern (0,1,2,3,4). \
  659.       x8 = (x8 & 0x0FU) + (x8 >> 4)                 \
  660.       # x8 besteht aus 1 8-Bit-ZΣhler (0,...,8).    \
  661.     )
  662.   # Bits von x16 zΣhlen: (Input x16, Output x16)
  663.   #define logcount_16()  \
  664.     ( # x16 besteht aus 16 1-Bit-ZΣhlern (0,1).       \
  665.       x16 = (x16 & 0x5555U) + ((x16 & 0xAAAAU) >> 1), \
  666.       # x16 besteht aus 8 2-Bit-ZΣhlern (0,1,2).      \
  667.       x16 = (x16 & 0x3333U) + ((x16 & 0xCCCCU) >> 2), \
  668.       # x16 besteht aus 4 4-Bit-ZΣhlern (0,1,2,3,4).  \
  669.       x16 = (x16 & 0x0F0FU) + ((x16 & 0xF0F0U) >> 4), \
  670.       # x16 besteht aus 2 8-Bit-ZΣhlern (0,...,8).    \
  671.       x16 = (x16 & 0x00FFU) + (x16 >> 8)              \
  672.       # x16 besteht aus 1 16-Bit-ZΣhler (0,...,16).   \
  673.     )
  674.   # Bits von x32 zΣhlen: (Input x32, Output x16)
  675.   #define logcount_32()  \
  676.     ( # x32 besteht aus 32 1-Bit-ZΣhlern (0,1).                 \
  677.       x32 = (x32 & 0x55555555UL) + ((x32 & 0xAAAAAAAAUL) >> 1), \
  678.       # x32 besteht aus 16 2-Bit-ZΣhlern (0,1,2).               \
  679.       x32 = (x32 & 0x33333333UL) + ((x32 & 0xCCCCCCCCUL) >> 2), \
  680.       # x32 besteht aus 8 4-Bit-ZΣhlern (0,1,2,3,4).            \
  681.       x16 = high16(x32)+low16(x32),                             \
  682.       # x16 besteht aus 4 4-Bit-ZΣhlern (0,...,8).              \
  683.       x16 = (x16 & 0x0F0FU) + ((x16 & 0xF0F0U) >> 4),           \
  684.       # x16 besteht aus 2 8-Bit-ZΣhlern (0,...,16).             \
  685.       x16 = (x16 & 0x00FFU) + (x16 >> 8)                        \
  686.       # x16 besteht aus 1 16-Bit-ZΣhler (0,...,32).             \
  687.     )
  688.   #if (intWLsize==intLsize)
  689.     #define x16  x32
  690.   #endif
  691.   local object I_logcount_I(x)
  692.     var reg3 object x;
  693.     { if (I_fixnump(x))
  694.         { var reg1 uint16 x16; # Hilfsvariable
  695.          {var reg1 uint32 x32 = FN_to_L(x); # x als 32-Bit-Zahl
  696.           if (FN_L_minusp(x,(sint32)x32)) { x32 = ~ x32; } # falls <0, komplementieren
  697.           logcount_32(); # Bits von x32 zΣhlen
  698.           return fixnum((uintL)x16);
  699.         }}
  700.         else
  701.         { var reg6 uintD* MSDptr;
  702.           var reg3 uintC len;
  703.           BN_to_NDS_nocopy(x, MSDptr=,len=,); # DS zu x bilden, len>0.
  704.          {var reg4 uintL bitcount = 0; # BitzΣhler
  705.           var reg2 uintD* ptr = MSDptr; # lΣuft durch die Digits durch
  706.           var reg5 uintD sign = sign_of_sintD(ptr[0]); # Vorzeichen
  707.           #if (intDsize==8)
  708.           dotimespC(len,len,
  709.             { var reg1 uintD x8 = (*ptr++) ^ sign; # nΣchstes intDsize-Bit-Paket,
  710.                                     # bei negativen Zahlen komplementiert
  711.               # Bits von x8 zΣhlen, GesamtzΣhler erh÷hen:
  712.               bitcount += (uintL)(logcount_8(), x8);
  713.             });
  714.           #endif
  715.           #if (intDsize==16)
  716.           dotimespC(len,len,
  717.             { var reg1 uintD x16 = (*ptr++) ^ sign; # nΣchstes intDsize-Bit-Paket,
  718.                                     # bei negativen Zahlen komplementiert
  719.               # Bits von x16 zΣhlen, GesamtzΣhler erh÷hen:
  720.               bitcount += (uintL)(logcount_16(), x16);
  721.             });
  722.           #endif
  723.           #if (intDsize==32)
  724.           dotimespC(len,len,
  725.             { var reg1 uint16 x16; # Hilfsvariable
  726.              {var reg1 uintD x32 = (*ptr++) ^ sign; # nΣchstes intDsize-Bit-Paket,
  727.                                     # bei negativen Zahlen komplementiert
  728.               # Bits von x32 zΣhlen, GesamtzΣhler erh÷hen:
  729.               bitcount += (uintL)(logcount_32(), x16);
  730.             }});
  731.           #endif
  732.           # 0 <= bitcount < intDsize*2^intCsize, pa▀t evtl. in ein Fixnum.
  733.           if (log2_intDsize+intCsize<=oint_data_len) # intDsize*2^intCsize <= 2^oint_data_len ?
  734.             return fixnum(bitcount);
  735.             else
  736.             return UL_to_I(bitcount);
  737.     }   }}
  738.   #undef x16
  739.   #undef logcount_32
  740.   #undef logcount_16
  741.   #undef logcount_8
  742.  
  743. # Bits eines Digit zΣhlen:
  744. # integerlengthD(digit,size=);
  745. # setzt size auf die h÷chste in digit vorkommende Bitnummer.
  746. # > digit: ein uintD >0
  747. # < size: >0, <=intDsize, mit 2^(size-1) <= digit < 2^size
  748. #if defined(GNU) && defined(MC680Y0) && !defined(NO_ASM)
  749.   #define integerlength8(digit,size_zuweisung)  \
  750.     { var reg1 uintL zero_counter; # zΣhlt die fⁿhrenden Nullbits in digit          \
  751.       __asm__("bfffo %1{#0:#8},%0" : "=d" (zero_counter) : "dm" ((uint8)(digit)) ); \
  752.       size_zuweisung (8-zero_counter);                                              \
  753.     }
  754. #elif defined(SPARC)
  755.   #define integerlength8(digit,size_zuweisung)  \
  756.     integerlength32((uint32)(digit),size_zuweisung) # siehe unten
  757. #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  758.   #define integerlength8(digit,size_zuweisung)  \
  759.     integerlength16((uint16)(digit),size_zuweisung)
  760. #else
  761.   #define integerlength8(digit,size_zuweisung)  \
  762.     { var reg2 uintC bitsize = 1;                            \
  763.       var reg1 uintBWL x8 = (uint8)(digit);                  \
  764.       # x8 hat h÷chstens 8 Bits.                             \
  765.       if (x8 >= bit(4)) { x8 = x8>>4; bitsize += 4; }        \
  766.       # x8 hat h÷chstens 4 Bits.                             \
  767.       if (x8 >= bit(2)) { x8 = x8>>2; bitsize += 2; }        \
  768.       # x8 hat h÷chstens 2 Bits.                             \
  769.       if (x8 >= bit(1)) { /* x8 = x8>>1; */ bitsize += 1; }  \
  770.       # x8 hat h÷chstens 1 Bit. Dieses Bit mu▀ gesetzt sein. \
  771.       size_zuweisung bitsize;                                \
  772.     }
  773. #endif
  774. #if defined(GNU) && defined(MC680Y0) && !defined(NO_ASM)
  775.   #define integerlength16(digit,size_zuweisung)  \
  776.     { var reg1 uintL zero_counter; # zΣhlt die fⁿhrenden Nullbits in digit            \
  777.       __asm__("bfffo %1{#0:#16},%0" : "=d" (zero_counter) : "dm" ((uint16)(digit)) ); \
  778.       size_zuweisung (16-zero_counter);                                               \
  779.     }
  780. #elif defined(SPARC)
  781.   #define integerlength16(digit,size_zuweisung)  \
  782.     integerlength32((uint32)(digit),size_zuweisung) # siehe unten
  783. #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  784.   #define integerlength16(digit,size_zuweisung)  \
  785.     { var reg1 uintW one_position; # Position der fⁿhrenden 1               \
  786.       __asm__("bsrw %1,%0" : "=r" (one_position) : "r" ((uint16)(digit)) ); \
  787.       size_zuweisung (1+one_position);                                      \
  788.     }
  789. # Die weiteren kommen von gcc/longlong.h :
  790. #elif defined(GNU) && defined(__ibm032__) && !defined(NO_ASM) # RT/ROMP
  791.   #define integerlength16(digit,size_zuweisung)  \
  792.     { var reg1 uintL zero_counter; # zΣhlt die fⁿhrenden Nullbits in digit \
  793.       __asm__("clz %0,%1" : "=r" (zero_counter) : "r" ((uint32)(digit)) ); \
  794.       size_zuweisung (16-zero_counter);                                    \
  795.     }
  796. #else
  797.   #define integerlength16(digit,size_zuweisung)  \
  798.     { var reg2 uintC bitsize = 1;                              \
  799.       var reg1 uintWL x16 = (uint16)(digit);                   \
  800.       # x16 hat h÷chstens 16 Bits.                             \
  801.       if (x16 >= bit(8)) { x16 = x16>>8; bitsize += 8; }       \
  802.       # x16 hat h÷chstens 8 Bits.                              \
  803.       if (x16 >= bit(4)) { x16 = x16>>4; bitsize += 4; }       \
  804.       # x16 hat h÷chstens 4 Bits.                              \
  805.       if (x16 >= bit(2)) { x16 = x16>>2; bitsize += 2; }       \
  806.       # x16 hat h÷chstens 2 Bits.                              \
  807.       if (x16 >= bit(1)) { /* x16 = x16>>1; */ bitsize += 1; } \
  808.       # x16 hat h÷chstens 1 Bit. Dieses Bit mu▀ gesetzt sein.  \
  809.       size_zuweisung bitsize;                                  \
  810.     }
  811. #endif
  812. #if defined(GNU) && defined(MC680Y0) && !defined(NO_ASM)
  813.   #define integerlength32(digit,size_zuweisung)  \
  814.     { var reg1 uintL zero_counter; # zΣhlt die fⁿhrenden Nullbits in digit            \
  815.       __asm__("bfffo %1{#0:#32},%0" : "=d" (zero_counter) : "dm" ((uint32)(digit)) ); \
  816.       size_zuweisung (32-zero_counter);                                               \
  817.     }
  818. #elif defined(SPARC) && defined(FAST_DOUBLE)
  819.   #define integerlength32(digit,size_zuweisung)  \
  820.     {var union { double f; uint32 i[2]; } __fi;                     \
  821.      # Bilde 2^52 + digit:                                          \
  822.      __fi.i[0] = (uint32)(DF_mant_len+1+DF_exp_mid) << (DF_mant_len-32); # Vorzeichen 0, Exponent 53 \
  823.      __fi.i[1] = (digit); # untere 32 Bits setzen (benutzt BIG_ENDIAN_P !) \
  824.      # subtrahiere 2^52:                                            \
  825.      __fi.f = __fi.f - (double)(4503599627370496.0L);               \
  826.      # Hole davon den Exponenten:                                   \
  827.      size_zuweisung ((__fi.i[0] >> (DF_mant_len-32)) - DF_exp_mid); \
  828.     }
  829. #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  830.   #define integerlength32(digit,size_zuweisung)  \
  831.     { var reg1 uintL one_position; # Position der fⁿhrenden 1                \
  832.       __asm__("bsrl %1,%0" : "=r" (one_position) : "rm" ((uint32)(digit)) ); \
  833.       size_zuweisung (1+one_position);                                       \
  834.     }
  835. #elif defined(HPPA) && !defined(NO_ASM)
  836.   #define integerlength32(digit,size_zuweisung)  \
  837.     size_zuweisung length32(digit);
  838.   extern uintL length32 (uintL digit); # extern in Assembler
  839. # Die weiteren kommen von gcc/longlong.h :
  840. #elif defined(GNU) && (defined(__a29k__) || defined(___AM29K__)) && !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__("clz %0,%1" : "=r" (zero_counter) : "r" ((uint32)(digit)) ); \
  844.       size_zuweisung (32-zero_counter);                                    \
  845.     }
  846. #elif defined(GNU) && defined(__gmicro__) && !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__("bsch/1 %1,%0" : "=g" (zero_counter) : "g" ((uint32)(digit)) ); \
  850.       size_zuweisung (32-zero_counter);                                       \
  851.     }
  852. #elif defined(GNU) && defined(RS6000) && !defined(NO_ASM)
  853.   #define integerlength32(digit,size_zuweisung)  \
  854.     { var reg1 uintL zero_counter; # zΣhlt die fⁿhrenden Nullbits in digit   \
  855.       __asm__("cntlz %0,%1" : "=r" (zero_counter) : "r" ((uint32)(digit)) ); \
  856.       size_zuweisung (32-zero_counter);                                      \
  857.     }
  858. #elif defined(GNU) && defined(M88000) && !defined(NO_ASM)
  859.   #define integerlength32(digit,size_zuweisung)  \
  860.     { var reg1 uintL one_position; # Position der fⁿhrenden 1              \
  861.       __asm__("ff1 %0,%1" : "=r" (one_position) : "r" ((uint32)(digit)) ); \
  862.       size_zuweisung (1+one_position);                                     \
  863.     }
  864. #elif defined(GNU) && defined(__ibm032__) && !defined(NO_ASM) # RT/ROMP
  865.   #define integerlength32(digit,size_zuweisung)  \
  866.     { var reg2 uintL x32 = (uint32)(digit);                \
  867.       if (x32 >= bit(16))                                  \
  868.         { integerlength16(x32>>16,size_zuweisung 16 + ); } \
  869.         else                                               \
  870.         { integerlength16(x32,size_zuweisung); }           \
  871.     }
  872. #else
  873.   #if (intWLsize==intLsize)
  874.     #define integerlength32(digit,size_zuweisung)  \
  875.       { var reg2 uintC bitsize = 1;                              \
  876.         var reg1 uintL x32 = (uint32)(digit);                    \
  877.         # x32 hat h÷chstens 32 Bits.                             \
  878.         if (x32 >= bit(16)) { x32 = x32>>16; bitsize += 16; }    \
  879.         # x32 hat h÷chstens 16 Bits.                             \
  880.         if (x32 >= bit(8)) { x32 = x32>>8; bitsize += 8; }       \
  881.         # x32 hat h÷chstens 8 Bits.                              \
  882.         if (x32 >= bit(4)) { x32 = x32>>4; bitsize += 4; }       \
  883.         # x32 hat h÷chstens 4 Bits.                              \
  884.         if (x32 >= bit(2)) { x32 = x32>>2; bitsize += 2; }       \
  885.         # x32 hat h÷chstens 2 Bits.                              \
  886.         if (x32 >= bit(1)) { /* x32 = x32>>1; */ bitsize += 1; } \
  887.         # x32 hat h÷chstens 1 Bit. Dieses Bit mu▀ gesetzt sein.  \
  888.         size_zuweisung bitsize;                                  \
  889.       }
  890.   #else
  891.     #define integerlength32(digit,size_zuweisung)  \
  892.       { var reg3 uintC bitsize = 1;                              \
  893.         var reg2 uintL x32 = (digit);                            \
  894.         var reg1 uintWL x16;                                     \
  895.         # x32 hat h÷chstens 32 Bits.                             \
  896.         if (x32 >= bit(16)) { x16 = x32>>16; bitsize += 16; } else { x16 = x32; } \
  897.         # x16 hat h÷chstens 16 Bits.                             \
  898.         if (x16 >= bit(8)) { x16 = x16>>8; bitsize += 8; }       \
  899.         # x16 hat h÷chstens 8 Bits.                              \
  900.         if (x16 >= bit(4)) { x16 = x16>>4; bitsize += 4; }       \
  901.         # x16 hat h÷chstens 4 Bits.                              \
  902.         if (x16 >= bit(2)) { x16 = x16>>2; bitsize += 2; }       \
  903.         # x16 hat h÷chstens 2 Bits.                              \
  904.         if (x16 >= bit(1)) { /* x16 = x16>>1; */ bitsize += 1; } \
  905.         # x16 hat h÷chstens 1 Bit. Dieses Bit mu▀ gesetzt sein.  \
  906.         size_zuweisung bitsize;                                  \
  907.       }
  908.   #endif
  909. #endif
  910. #if (intDsize==8)
  911.   #define integerlengthD  integerlength8
  912. #endif
  913. #if (intDsize==16)
  914.   #define integerlengthD  integerlength16
  915. #endif
  916. #if (intDsize==32)
  917.   #define integerlengthD  integerlength32
  918. #endif
  919.  
  920. # (INTEGER-LENGTH x), wo x ein Integer ist. Ergebnis uintL.
  921. # I_integer_length(x)
  922.   global uintL I_integer_length (object x);
  923.   global uintL I_integer_length(x)
  924.     var reg3 object x;
  925.     { if (I_fixnump(x))
  926.         { var reg2 uintL bitcount = 0;
  927.           var reg1 uint32 x_ = FN_to_L(x); # x als 32-Bit-Zahl
  928.           if (FN_L_minusp(x,(sint32)x_)) { x_ = ~ x_; } # falls <0, komplementieren
  929.           if (!(x_==0)) { integerlength32(x_,bitcount=); }
  930.           return bitcount; # 0 <= bitcount < 32.
  931.         }
  932.         else
  933.         { var reg4 uintD* MSDptr;
  934.           var reg5 uintC len;
  935.           BN_to_NDS_nocopy(x, MSDptr=,len=,); # normalisierte DS zu x bilden.
  936.          {var reg2 uintL bitcount = intDsize*(uintL)(len-1); # Anzahl Digits mal intDsize
  937.           # MSDigit nehmen, testen, welches das h÷chste Bit ist, das vom
  938.           # Vorzeichenbit abweicht:
  939.           var reg1 uintD msd = MSDptr[0]; # MSDigit
  940.           if ((sintD)msd < 0) { msd = ~msd; } # falls negativ, invertieren
  941.           # Position des h÷chsten Bits in msd suchen und entsprechend bit_count
  942.           # erh÷hen (um h÷chstens intDsize-1):
  943.           if (!(msd == 0)) { integerlengthD(msd, bitcount += ); }
  944.           return bitcount; # 0 <= bitcount < intDsize*2^intCsize.
  945.     }   }}
  946.  
  947. # (INTEGER-LENGTH x), wo x ein Integer ist. Ergebnis Integer >=0.
  948. # I_integer_length_I(x)
  949. # kann GC ausl÷sen
  950.   local object I_integer_length_I (object x);
  951.   local object I_integer_length_I(x)
  952.     var reg3 object x;
  953.     { if (I_fixnump(x))
  954.         { var reg2 uintL bitcount = 0;
  955.           var reg1 uint32 x_ = FN_to_L(x); # x als 32-Bit-Zahl
  956.           if (FN_L_minusp(x,(sint32)x_)) { x_ = ~ x_; } # falls <0, komplementieren
  957.           if (!(x_==0)) { integerlength32(x_,bitcount=); }
  958.           # 0 <= bitcount < 32, pa▀t in ein Fixnum.
  959.           return fixnum(bitcount);
  960.         }
  961.         else
  962.         { var reg4 uintD* MSDptr;
  963.           var reg5 uintC len;
  964.           BN_to_NDS_nocopy(x, MSDptr=,len=,); # normalisierte DS zu x bilden.
  965.          {var reg2 uintL bitcount = intDsize*(uintL)(len-1); # Anzahl Digits mal intDsize
  966.           # MSDigit nehmen, testen, welches das h÷chste Bit ist, das vom
  967.           # Vorzeichenbit abweicht:
  968.           var reg1 uintD msd = MSDptr[0]; # MSDigit
  969.           if ((sintD)msd < 0) { msd = ~msd; } # falls negativ, invertieren
  970.           # Position des h÷chsten Bits in msd suchen und entsprechend bit_count
  971.           # erh÷hen (um h÷chstens intDsize-1):
  972.           if (!(msd == 0)) { integerlengthD(msd, bitcount += ); }
  973.           # 0 <= bitcount < intDsize*2^intCsize, pa▀t evtl. in ein Fixnum.
  974.           if (log2_intDsize+intCsize<=oint_data_len) # intDsize*2^intCsize <= 2^oint_data_len ?
  975.             return fixnum(bitcount);
  976.             else
  977.             return UL_to_I(bitcount);
  978.     }   }}
  979.  
  980. # Hintere Nullbits eines 32-Bit-Wortes zΣhlen:
  981. # ord2_32(digit,count=);
  982. # setzt size auf die kleinste in digit vorkommende Bitnummer.
  983. # > digit: ein uint32 >0
  984. # < count: >=0, <32, mit 2^count | digit, digit/2^count ungerade
  985.   #if defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  986.     #define ord2_32(digit,count_zuweisung)  \
  987.       { var reg1 uintL one_position; # Position der letzten 1                  \
  988.         __asm__("bsfl %1,%0" : "=r" (one_position) : "rm" ((uint32)(digit)) ); \
  989.         count_zuweisung one_position;                                          \
  990.       }
  991.   #endif
  992.  
  993. # Hintere Nullbits eines Digits zΣhlen:
  994. # ord2_D(digit,count=);
  995. # setzt size auf die kleinste in digit vorkommende Bitnummer.
  996. # > digit: ein uintD >0
  997. # < count: >=0, <intDsize, mit 2^count | digit, digit/2^count ungerade
  998.   #ifdef ord2_32
  999.     #define ord2_D(digit,count_zuweisung)  \
  1000.       ord2_32((uint32)(digit),count_zuweisung)
  1001.   #endif
  1002.  
  1003. # (ORD2 x) = max{n>=0: 2^n | x }, wo x ein Integer /=0 ist. Ergebnis uintL.
  1004. # I_ord2(x)
  1005.   local uintL I_ord2 (object x);
  1006. # Methode 1a:
  1007. #   Sei n = ord2(x). Dann ist logxor(x,x-1) = 2^n + (2^n-1) = 2^(n+1)-1.
  1008. #   Also  (ord2 x) = (1- (integer-length (logxor x (1- x)))) .
  1009. # Methode 1b:
  1010. #   Sei n = ord2(x). Dann ist logand(x,-x) = 2^n.
  1011. #   Also  (ord2 x) = (1- (integer-length (logand x (- x)))) .
  1012. # Methode 1c:
  1013. #   Sei n = ord2(x). Dann ist lognot(logior(x,-x)) = 2^n-1.
  1014. #   Also  (ord2 x) = (integer-length (lognot (logior x (- x)))) .
  1015. # Methode 2:
  1016. #   Nullbits am Schlu▀ von x abzΣhlen:
  1017. #   (ord2 x) = intDsize * Anzahl der Nulldigits am Schlu▀
  1018. #              + Anzahl der Nullbits am Ende des letzten Digits /=0.
  1019.   #ifndef ord2_32
  1020.     # Hier mu▀ digit eine Variable sein. digit wird verΣndert!
  1021.     #define ord2_32(digit,count_zuweisung)  \
  1022.       digit = digit ^ (digit - 1); # Methode 1a \
  1023.       integerlength32(digit,count_zuweisung -1 + )
  1024.   #endif
  1025.   #ifndef ord2_D
  1026.     # Hier mu▀ digit eine Variable sein. digit wird verΣndert!
  1027.     #define ord2_D(digit,count_zuweisung)  \
  1028.       digit = digit ^ (digit - 1); # Methode 1a \
  1029.       integerlengthD(digit,count_zuweisung -1 + )
  1030.   #endif
  1031.   local uintL I_ord2(x)
  1032.     var reg4 object x;
  1033.     { if (I_fixnump(x))
  1034.         { var reg1 uint32 x_ = FN_to_L(x); # x als 32-Bit-Zahl
  1035.           #if (oint_data_len < 32)
  1036.           ord2_32(x_,return);
  1037.           #else # oint_data_len=32, x_ kann auch =0 sein.
  1038.           # Bei x = most-negative-fixnum funktioniert nur Methode 1c.
  1039.           x_ = x_ | (- x_); x_ = ~ x_;
  1040.           integerlength32(x_,return);
  1041.           #endif
  1042.         }
  1043.         else
  1044.         { var reg2 uintL bitcount = 0;
  1045.           var reg1 uintD* ptr;
  1046.           BN_to_NDS_nocopy(x, ,,ptr=); # normalisierte DS zu x bilden.
  1047.           while (*--ptr == 0) { bitcount += intDsize; } # Nulldigits abzΣhlen
  1048.          {var reg3 uintD lsd = *ptr; # letztes Digit /=0
  1049.           ord2_D(lsd,bitcount +=); # dessen Nullbits abzΣhlen
  1050.           return bitcount;
  1051.         }}
  1052.     }
  1053.  
  1054. # I_power2p(x) stellt fest, ob ein Integer x>0 eine Zweierpotenz ist.
  1055. # Ergebnis: n>0, wenn x=2^(n-1), 0 sonst.
  1056.   local uintL I_power2p (object x);
  1057. # Methode 1: Wenn ord2(x) = integer_length(x)-1.
  1058. # Methode 2: Wenn logand(x,x-1) = 0.
  1059. # Methode 3: Wenn das erste Digit /=0 eine Zweierpotenz ist und alle weiteren
  1060. #            Digits Null sind.
  1061.   local uintL I_power2p(x)
  1062.     var reg2 object x;
  1063.     { if (I_fixnump(x))
  1064.         { var reg1 uintL x_ = posfixnum_to_L(x);
  1065.           if (!((x_ & (x_-1)) == 0)) return 0; # keine Zweierpotenz
  1066.           integerlength32(x_,return); # Zweierpotenz: n = integer_length(x)
  1067.         }
  1068.         else
  1069.         { var reg1 uintD* MSDptr;
  1070.           var reg4 uintC len;
  1071.           BN_to_NDS_nocopy(x, MSDptr=,len=,); # normalisierte DS zu x bilden.
  1072.          {var reg3 uintD msd = MSDptr[0];
  1073.           if (msd==0) { MSDptr++; msd = MSDptr[0]; len--; }
  1074.           # len = Anzahl der Digits ab MSDptr, len>0, msd = erstes Digit (/=0)
  1075.           if (!((msd & (msd-1)) == 0)) return 0; # erstes Digit mu▀ Zweierpotenz sein
  1076.           if (test_loop_up(&MSDptr[1],len-1)) return 0; # danach alles Nullen
  1077.           {var reg5 uintL msdlen;
  1078.            integerlengthD(msd, msdlen=);
  1079.            return intDsize*(uintL)len + msdlen; # integer_length(x) als Ergebnis
  1080.         }}}
  1081.     }
  1082.  
  1083.