home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / intbyte.d < prev    next >
Encoding:
Text File  |  1993-12-12  |  16.5 KB  |  423 lines
  1. # BYTE-Operationen auf Integers
  2.  
  3. # Konstruktor: (I_I_Byte size position), wo size und position Integers sind.
  4. # kann GC ausl÷sen
  5.   local object I_I_Byte (object size, object position);
  6.   local object I_I_Byte(size,position)
  7.     var reg2 object size;
  8.     var reg3 object position;
  9.     { if (!(I_fixnump(size) && !R_minusp(size)))
  10.         { pushSTACK(size); # Wert fⁿr Slot DATUM von TYPE-ERROR
  11.           bad_args:
  12.           pushSTACK(O(type_posfixnum)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  13.           pushSTACK(position); pushSTACK(size);
  14.           fehler(type_error,
  15.                  DEUTSCH ? "Die Argumente zu BYTE mⁿssen Fixnums >=0 sein: ~, ~" :
  16.                  ENGLISH ? "The arguments to BYTE must be fixnums >=0: ~, ~" :
  17.                  FRANCAIS ? "Les arguments de BYTE doivent Ωtre des entiers FIXNUM >=0 : ~, ~" :
  18.                  ""
  19.                 );
  20.         }
  21.       elif (!(I_fixnump(position) && !R_minusp(position)))
  22.         { pushSTACK(position); # Wert fⁿr Slot DATUM von TYPE-ERROR
  23.           goto bad_args;
  24.         }
  25.       else
  26.         { # size, position sind Fixnums >=0, brauchen nicht gerettet zu werden
  27.           var reg1 object new_byte = allocate_byte(); # neues Byte allozieren
  28.           # und fⁿllen:
  29.           TheByte(new_byte)->byte_size = size;
  30.           TheByte(new_byte)->byte_position = position;
  31.           return new_byte;
  32.     }   }
  33.  
  34. # Fehler, wenn Argument kein Byte.
  35.   nonreturning_function(local, fehler_byte, (object bad));
  36.   local void fehler_byte(bad)
  37.     var reg1 object bad;
  38.     { pushSTACK(bad); # Wert fⁿr Slot DATUM von TYPE-ERROR
  39.       pushSTACK(S(byte)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  40.       pushSTACK(bad);
  41.       fehler(type_error,
  42.              DEUTSCH ? "~ ist kein BYTE-Specifier." :
  43.              ENGLISH ? "~ is not a BYTE specifier" :
  44.              FRANCAIS ? "~ n'est pas une spΘcification de BYTE." :
  45.              ""
  46.             );
  47.     }
  48.  
  49. # Zugriffsfunktionen:
  50.  
  51. # Liefert (BYTE-SIZE byte). Das Argument wird ⁿberprⁿft.
  52.   local object Byte_size (object obj);
  53.   local object Byte_size(obj)
  54.     var reg1 object obj;
  55.     { if (bytep(obj))
  56.         return TheByte(obj)->byte_size;
  57.         else
  58.         fehler_byte(obj);
  59.     }
  60.  
  61. # Liefert (BYTE-POSITION byte). Das Argument wird ⁿberprⁿft.
  62.   local object Byte_position (object obj);
  63.   local object Byte_position(obj)
  64.     var reg1 object obj;
  65.     { if (bytep(obj))
  66.         return TheByte(obj)->byte_position;
  67.         else
  68.         fehler_byte(obj);
  69.     }
  70.  
  71. # Byte_to_L_L(byte, size=,position=); wandelt das Byte byte (eine Variable)
  72. # um in size und position, beides uintL >=0, <2^oint_data_len.
  73.   #define Byte_to_L_L(byte, size_zuweisung,position_zuweisung)  \
  74.     { if bytep(byte)                                            \
  75.         { size_zuweisung posfixnum_to_L(TheByte(byte)->byte_size); \
  76.           position_zuweisung posfixnum_to_L(TheByte(byte)->byte_position); \
  77.         }                                                       \
  78.         else                                                    \
  79.         fehler_byte(byte);                                      \
  80.     }
  81.  
  82. # fullbyte_I(p,q) liefert zu p,q die Zahl 2^q-2^p als Integer,
  83. # wobei p und q uintL sind. Bei p<=q ist das Ergebnis also
  84. # ein Integer >=0, bei dem genau die Bits p,...,q-1 gesetzt sind.
  85. # kann GC ausl÷sen
  86.   local object fullbyte_I (uintL p, uintL q);
  87.   local object fullbyte_I(p,q)
  88.     var reg3 uintL p;
  89.     var reg4 uintL q;
  90.     { if (p==q)
  91.         return Fixnum_0; # p=q -> 0 als Ergebnis
  92.         else
  93.         { var reg1 object Iq = UL_to_I(q); # q als Integer >=0
  94.           var reg1 object I2q = I_I_ash_I(Fixnum_1,Iq); # 2^q als Integer
  95.           pushSTACK(I2q); # retten
  96.          {var reg2 object Ip = UL_to_I(p); # p als Integer >=0
  97.           var reg2 object I2p = I_I_ash_I(Fixnum_minus1,Ip); # - 2^p als Integer
  98.           I2q = popSTACK();
  99.           return I_I_plus_I(I2p,I2q); # 2^q und -2^p addieren
  100.     }   }}
  101.  
  102. # Extrahiere die Bits p,...,q-1 der Zahl x,
  103. # wobei 0 <= p <= q <= l = (integer-length x).
  104. # Ergebnis (wie bei LDB) ein Integer >=0.
  105. # kann GC ausl÷sen
  106.   local object ldb_extract (object x, uintL p, uintL q);
  107.   local object ldb_extract(x,p,q)
  108.     var reg6 object x;
  109.     var reg4 uintL p;
  110.     var reg4 uintL q;
  111.     { SAVE_NUM_STACK # num_stack retten
  112.       var reg3 uintD* MSDptr;
  113.       var reg2 uintC len;
  114.       var reg5 uintD* LSDptr;
  115.       I_to_NDS_nocopy(x, MSDptr=,len=,LSDptr=); # NDS zu x bilden
  116.       # MSDptr erh÷hen und len erniedrigen, so da▀ len = ceiling(q/intDsize) wird:
  117.       { var reg1 uintL qD = ceiling(q,intDsize); # ceiling(q/intDsize)
  118.         # wegen q<=l ist qD = ceiling(q/intDsize) <= ceiling((l+1)/intDsize) = len, also
  119.         # pa▀t qD ebenso wie len in ein uintC.
  120.         MSDptr += ((uintL)len - qD); # MSDptr um len-qD Digits erh÷hen
  121.         len = qD; # len um len-qD erniedrigen
  122.       }
  123.       # LSDptr und len um floor(p/intDsize) erniedrigen:
  124.       { var reg1 uintL pD = floor(p,intDsize); # floor(p/intDsize)
  125.         LSDptr -= pD;
  126.         len -= pD;
  127.       }
  128.       # Jetzt enthΣlt MSDptr/len/LSDptr genau die ma▀geblichen Digits.
  129.      {var reg7 uintD* newMSDptr;
  130.       { var reg1 uintL i = p%intDsize; # p mod intDsize
  131.         # Kopiere sie und schiebe sie dabei um i Bits nach rechts:
  132.         num_stack_need_1((uintL)len, newMSDptr=,); # neue UDS newMSDptr/len/..
  133.         if (i==0)
  134.           { copy_loop_up(MSDptr,newMSDptr,len); }
  135.           else
  136.           { shiftrightcopy_loop_up(MSDptr,newMSDptr,len,i,0); }
  137.       }
  138.       # newMSDptr/len/.. = geschobene Kopie der ma▀geblichen Digits
  139.       # Ausblenden der Bits mit Nummern >= q-p:
  140.       { var reg1 uintL bitcount = intDsize*(uintL)len - (q-p);
  141.         # Anzahl vorne auszublendender Bits ( >=0, <= intDsize-1 + intDsize-1 )
  142.         if (bitcount>=intDsize)
  143.           { bitcount -= intDsize; newMSDptr += 1; len -= 1; } # intDsize Bits ausblenden
  144.         # Noch 0 <= bitcount < intDsize Bits auszublenden:
  145.         newMSDptr[0] &= (uintD)(bitm(intDsize-bitcount)-1);
  146.       }
  147.       # Jetzt enthΣlt die UDS newMSDptr/len/.. die extrahierten Bits.
  148.       RESTORE_NUM_STACK # num_stack (vorzeitig) zurⁿck
  149.       return UDS_to_I(newMSDptr,len); # UDS in Integer umwandeln
  150.     }}
  151.  
  152. # (LDB byte n), wo n ein Integer ist.
  153. # kann GC ausl÷sen
  154.   local object I_Byte_ldb_I (object n, object b);
  155.   local object I_Byte_ldb_I(n,b)
  156.     var reg5 object n;
  157.     var reg6 object b;
  158.     { # Methode:
  159.       # (ldb (byte s p) n) extrahiere die Bits p,...,p+s-1 von n.
  160.       # l:=(integer-length n)
  161.       # Falls l <= p :
  162.       #   Falls n>=0: 0, falls n<0: 2^s - 1 (s Einsenbits).
  163.       # Falls p <= l :
  164.       #   q:=min(p+s,l).
  165.       #   Extrahiere die Bits p,...,q-1 von n.
  166.       #   Falls p+s>l und n<0, fⁿge p+s-l Einsenbits an (addiere 2^s-2^(l-p)).
  167.       var reg3 uintL s;
  168.       var reg2 uintL p;
  169.       var reg1 uintL l;
  170.       Byte_to_L_L(b, s=,p=); # size s und position p bestimmen
  171.       l = I_integer_length(n); # l = (integer-length n)
  172.       if (l<=p)
  173.         # l<=p
  174.         if (!(R_minusp(n)))
  175.           # n>=0
  176.           return Fixnum_0; # 0 als Ergebnis
  177.           else
  178.           # n<0
  179.           return fullbyte_I(0,s); # 2^s-2^0 als Ergebnis
  180.         else
  181.         # l>p
  182.         { var reg4 object erg;
  183.           pushSTACK(n); # n retten
  184.          {var reg1 uintL ps = p+s;
  185.           # Bits p,...,q-1 mit q = min(p+s,l) extrahieren:
  186.           erg = ldb_extract(n,p,(ps<l ? ps : l));
  187.           n = popSTACK(); # n zurⁿck
  188.          }
  189.          {var reg1 uintL lp = l-p;
  190.           if ((s>lp)&&(R_minusp(n))) # s>l-p und n<0 ?
  191.             { pushSTACK(erg); # erg retten
  192.              {var reg1 object erg2 = fullbyte_I(lp,s);
  193.               # erg2 = Integer-Zahl mit gesetzten Bits l-p,...,s-1
  194.               erg = popSTACK(); # erg zurⁿck
  195.               return I_I_logior_I(erg,erg2); # logisches Oder aus beiden
  196.               # (logisches Exklusiv-Oder oder Addition ginge auch)
  197.             }}
  198.             else
  199.             return erg;
  200.       } }}
  201.  
  202. # Teste, ob eines der Bits p,...,q-1 der Zahl x /=0 ist,
  203. # wobei 0 <= p <= q <= l = (integer-length x).
  204. # Ergebnis (wie bei LDB-TEST) FALSE wenn nein, TRUE wenn ja.
  205.   local boolean ldb_extract_test (object x, uintL p, uintL q);
  206.   local boolean ldb_extract_test(x,p,q)
  207.     var reg6 object x;
  208.     var reg4 uintL p;
  209.     var reg4 uintL q;
  210.     { var reg3 uintD* MSDptr;
  211.       var reg2 uintC len;
  212.       var reg5 uintD* LSDptr;
  213.       I_to_NDS_nocopy(x, MSDptr=,len=,LSDptr=); # NDS zu x bilden
  214.       # MSDptr erh÷hen und len erniedrigen, so da▀ len = ceiling(q/intDsize) wird:
  215.       { var reg1 uintL qD = ceiling(q,intDsize); # ceiling(q/intDsize)
  216.         # wegen q<=l ist qD = ceiling(q/intDsize) <= ceiling((l+1)/intDsize) = len, also
  217.         # pa▀t qD ebenso wie len in ein uintC.
  218.         MSDptr += ((uintL)len - qD); # MSDptr um len-qD Digits erh÷hen
  219.         len = qD; # len um len-qD erniedrigen
  220.       }
  221.       # LSDptr und len um floor(p/intDsize) erniedrigen:
  222.       { var reg1 uintL pD = p/intDsize; # floor(p/intDsize)
  223.         LSDptr -= pD;
  224.         len -= pD;
  225.       }
  226.       # Jetzt enthΣlt MSDptr/len/LSDptr genau die ma▀geblichen Digits.
  227.       if (len==0) return FALSE; # len=0 -> keine Bits abzutesten
  228.       q = ((q-1)%intDsize); # q := intDsize - (intDsize*ceiling(q/intDsize) - q) - 1
  229.       p = p%intDsize; # p := p - intDsize*floor(p/intDsize)
  230.       # Jetzt ist 0 <= q < intDsize, 0 <= p < intDsize.
  231.       # Vom ersten Digit mⁿssen die vorderen intDsize-1-q Bits unberⁿcksichtigt bleiben.
  232.       # Ein AND 2^(q+1)-1 erreicht dies.
  233.       # Vom letzten Digit mⁿssen die hinteren p Bits unberⁿcksichtigt bleiben.
  234.       # Ein AND -2^p erreicht dies.
  235.       if (--len==0)
  236.         # 1 Digit ma▀geblich, wird von beiden Seiten angeschnitten:
  237.         # Ein AND 2^(q+1)-2^p erreicht dies.
  238.         if (!(((uintD)(bitm(q+1)-bit(p)) & *MSDptr) == 0))
  239.           return TRUE;
  240.           else
  241.           return FALSE;
  242.       # mindestens 2 Digits. Teste erst die Randdigits, dann die inneren:
  243.       if (!(((*MSDptr++ & (uintD)(bitm(q+1)-1)) == 0) &&
  244.             ((*--LSDptr & (uintD)(minus_bit(p))) == 0)
  245.          ) )
  246.         return TRUE;
  247.       len--; # die beiden Randdigits sind jetzt abgezogen.
  248.       if (test_loop_up(MSDptr,len)) { return TRUE; } else { return FALSE; }
  249.     }
  250.  
  251. # I_Byte_ldb_test(n,byte) fⁿhrt (LDB-TEST byte n) aus, wobei n ein Integer ist.
  252. # Ergebnis: FALSE wenn nein (also alle fraglichen Bits =0), TRUE wenn ja.
  253.   local boolean I_Byte_ldb_test (object n, object b);
  254.   local boolean I_Byte_ldb_test(n,b)
  255.     var reg1 object n;
  256.     var reg1 object b;
  257.     { # Methode:
  258.       # (ldb-test (byte s p) n)
  259.       # Falls s=0: =0.
  260.       # Falls s>0:
  261.       #   l:=(integer-length n)
  262.       #   Falls l <= p : Falls n>=0, =0, denn Bits p+s-1..p sind =0.
  263.       #                  Falls n<0, /=0, denn Bits p+s-1..p sind =1.
  264.       #   Falls p < l :
  265.       #     Falls p+s>l, /=0, denn bei n>=0 ist Bit l-1 =1,
  266.       #                       und bei n<0 sind Bits p+s-1..l =1.
  267.       #     Falls p+s<=l,
  268.       #       extrahiere die Bits p,...,p+s-1 von n und teste sie.
  269.       var reg3 uintL s;
  270.       var reg2 uintL p;
  271.       var reg1 uintL l;
  272.       Byte_to_L_L(b, s=,p=); # size s und position p bestimmen
  273.       if (s==0) return FALSE;
  274.       l = I_integer_length(n); # l = (integer-length n)
  275.       if (l<=p)
  276.         # l<=p
  277.         if (!(R_minusp(n)))
  278.           return FALSE; # n>=0
  279.           else
  280.           return TRUE; # n<0
  281.         else
  282.         # l>p
  283.         { var reg1 uintL ps = p+s;
  284.           if (ps>l) # p+s>l ?
  285.             return TRUE;
  286.           # Bits p,...,q-1 mit q = min(p+s,l) = p+s extrahieren und testen:
  287.           return ldb_extract_test(n,p,ps);
  288.     }   }
  289.  
  290. # Extrahiere die Bits p,...,q-1 der Zahl x,
  291. # wobei 0 <= p <= q <= l = (integer-length x).
  292. # Ergebnis (wie bei MASK-FIELD) ein Integer >=0.
  293. # kann GC ausl÷sen
  294.   local object mkf_extract (object x, uintL p, uintL q);
  295.   local object mkf_extract(x,p,q)
  296.     var reg6 object x;
  297.     var reg4 uintL p;
  298.     var reg4 uintL q;
  299.     { SAVE_NUM_STACK # num_stack retten
  300.       var reg3 uintD* MSDptr;
  301.       var reg2 uintC len;
  302.       var reg5 uintD* LSDptr;
  303.       I_to_NDS_nocopy(x, MSDptr=,len=,LSDptr=); # NDS zu x bilden
  304.       # MSDptr erh÷hen und len erniedrigen, so da▀ len = ceiling(q/intDsize) wird:
  305.       { var reg1 uintL qD = ceiling(q,intDsize); # ceiling(q/intDsize)
  306.         # wegen q<=l ist qD = ceiling(q/intDsize) <= ceiling((l+1)/intDsize) = len, also
  307.         # pa▀t qD ebenso wie len in ein uintC.
  308.         MSDptr += ((uintL)len - qD); # MSDptr um len-qD Digits erh÷hen
  309.         len = qD; # len um len-qD erniedrigen
  310.       }
  311.      {# Platz (len Digits) fⁿr die neue UDS bereitstellen:
  312.       var reg1 uintD* newMSDptr;
  313.       num_stack_need_1((uintL)len, newMSDptr = ,); # Platz belegen
  314.       {var reg3 uintL pD = p/intDsize; # floor(p/intDsize), pa▀t in ein uintC
  315.        # Kopiere len-pD Digits aus der DS zu x heraus:
  316.        var reg2 uintD* midptr = copy_loop_up(MSDptr,newMSDptr,len-(uintC)pD);
  317.        # L÷sche p-intDsize*floor(p/intDsize) Bits im Digit unterhalb von midptr:
  318.        {var reg1 uintL p_D = p%intDsize;
  319.         if (!(p_D==0)) { midptr[-1] &= minus_bit(p_D); }
  320.        }
  321.        # L÷sche pD Digits darⁿber:
  322.        clear_loop_up(midptr,pD);
  323.       }
  324.       # L÷sche intDsize*ceiling(q/intDsize)-q Bits im ersten Digit:
  325.       {var reg1 uintL q_D = q%intDsize;
  326.        if (!(q_D==0))
  327.          { newMSDptr[0] &= (uintD)((1L<<q_D)-1); } # intDsize-q_D Bits l÷schen
  328.       }
  329.       # Jetzt enthΣlt die UDS newMSDptr/len/.. die extrahierten Bits.
  330.       RESTORE_NUM_STACK # num_stack (vorzeitig) zurⁿck
  331.       return UDS_to_I(newMSDptr,len);
  332.     }}
  333.  
  334. # (MASK-FIELD byte n), wo n ein Integer ist.
  335. # kann GC ausl÷sen
  336.   local object I_Byte_mask_field_I (object n, object b);
  337.   local object I_Byte_mask_field_I(n,b)
  338.     var reg5 object n;
  339.     var reg6 object b;
  340.     { # Methode:
  341.       # (mask-field (byte s p) n) extrahiere die Bits p,...,p+s-1 von n.
  342.       # l:=(integer-length n)
  343.       # Falls l <= p :
  344.       #   Falls n>=0: 0, falls n<0: 2^(p+s) - 2^p (s Einsenbits).
  345.       # Falls p <= l :
  346.       #   q:=min(p+s,l).
  347.       #   Extrahiere die Bits p,...,q-1 von n.
  348.       #   Falls p+s>l und n<0, fⁿge p+s-l Einsenbits an (addiere 2^(p+s)-2^l).
  349.       var reg3 uintL s;
  350.       var reg2 uintL p;
  351.       var reg1 uintL l;
  352.       Byte_to_L_L(b, s=,p=); # size s und position p bestimmen
  353.      {var reg2 uintL ps = p+s;
  354.       l = I_integer_length(n); # l = (integer-length n)
  355.       if (l<=p)
  356.         # l<=p
  357.         if (!(R_minusp(n)))
  358.           # n>=0
  359.           return Fixnum_0; # 0 als Ergebnis
  360.           else
  361.           # n<0
  362.           return fullbyte_I(p,ps); # 2^(p+s)-2^p als Ergebnis
  363.         else
  364.         # l>p
  365.         { var reg4 object erg;
  366.           pushSTACK(n); # n retten
  367.           # Bits p,...,q-1 mit q = min(p+s,l) extrahieren:
  368.           erg = mkf_extract(n,p,(ps<l ? ps : l));
  369.           n = popSTACK(); # n zurⁿck
  370.           if ((ps>l)&&(R_minusp(n))) # p+s>l und n<0 ?
  371.             { pushSTACK(erg); # erg retten
  372.              {var reg1 object erg2 = fullbyte_I(l,ps);
  373.               # erg2 = Integer-Zahl mit gesetzten Bits l,...,p+s-1
  374.               erg = popSTACK(); # erg zurⁿck
  375.               return I_I_logior_I(erg,erg2); # logisches Oder aus beiden
  376.               # (logisches Exklusiv-Oder oder Addition ginge auch)
  377.             }}
  378.             else
  379.             return erg;
  380.     }}  }
  381.  
  382. # (DEPOSIT-FIELD new byte n), wo n und new Integers sind.
  383. # kann GC ausl÷sen
  384.   local object I_I_Byte_deposit_field_I (object new, object n, object b);
  385.   local object I_I_Byte_deposit_field_I(new,n,b)
  386.     var reg5 object new;
  387.     var reg5 object n;
  388.     var reg6 object b;
  389.     { # Methode:
  390.       # (DEPOSIT-FIELD newbyte (byte s p) integer)
  391.       #  = (logxor integer
  392.       #            (ash (logxor (ldb (byte s p) newbyte) (ldb (byte s p) integer))
  393.       #                 p
  394.       #    )       )
  395.       pushSTACK(n); # integer in den Stack
  396.       pushSTACK(b); # (byte s p) in den Stack
  397.      {var reg2 object temp1 = I_Byte_ldb_I(new,b); # (ldb (byte s p) newbyte)
  398.       pushSTACK(temp1); # in den Stack
  399.       temp1 = I_Byte_ldb_I(STACK_2,STACK_1); # (ldb (byte s p) integer)
  400.       temp1 = I_I_logxor_I(popSTACK(),temp1); # beides mit LOGXOR verknⁿpfen
  401.       temp1 = I_I_ash_I(temp1,Byte_position(popSTACK())); # (ash ... p)
  402.       return I_I_logxor_I(popSTACK(),temp1); # mit integer LOGXORen
  403.     }}
  404.  
  405. # (DPB new byte n), wo n und new Integers sind.
  406. # kann GC ausl÷sen
  407.   local object I_I_Byte_dpb_I (object new, object n, object b);
  408.   local object I_I_Byte_dpb_I(new,n,b)
  409.     var reg5 object new;
  410.     var reg5 object n;
  411.     var reg6 object b;
  412.     { # Methode:
  413.       # (DPB newbyte (byte s p) integer)
  414.       # = (DEPOSIT-FIELD (ASH newbyte p) (byte s p) integer)
  415.       pushSTACK(n); # integer in den Stack
  416.       pushSTACK(b); # (byte s p) in den Stack
  417.      {var reg1 object temp1 = I_I_ash_I(new,Byte_position(b));
  418.       b = popSTACK();
  419.       n = popSTACK();
  420.       return I_I_Byte_deposit_field_I(temp1,n,b);
  421.     }}
  422.  
  423.