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