home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / array.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  135.4 KB  |  2,995 lines
  1. # Arrayfunktionen von CLISP
  2. # Bruno Haible 29.1.1995
  3.  
  4. #include "lispbibl.c"
  5. #include "arilev0.c" # für bit_op, definiert auch mulu24 und mulu32_unchecked
  6.  
  7. # UP: Kopiert einen Simple-Vector
  8. # copy_svector(vector)
  9. # > vector : Simple-Vector
  10. # < ergebnis : neuer Simple-Vector desselben Inhalts
  11. # kann GC auslösen
  12.   global object copy_svector (object vector);
  13.   global object copy_svector(vector)
  14.     var reg4 object vector;
  15.     { var reg3 uintL length = TheSvector(vector)->length;
  16.       pushSTACK(vector);
  17.      {var reg5 object newvector = allocate_vector(length); # gleichlanger Vektor
  18.       vector = popSTACK();
  19.       # Inhalt von vector in newvector kopieren:
  20.       if (!(length==0))
  21.         { var reg1 object* ptr1 = &TheSvector(vector)->data[0];
  22.           var reg2 object* ptr2 = &TheSvector(newvector)->data[0];
  23.           dotimespL(length,length, { *ptr2++ = *ptr1++; } );
  24.         }
  25.       return newvector;
  26.     }}
  27.  
  28. # UP: Bestimmt die aktive Länge eines Vektors (wie in LENGTH)
  29. # vector_length(vector)
  30. # > vector: ein Vektor
  31. # < ergebnis: seine Länge als uintL
  32.   global uintL vector_length (object vector);
  33.   global uintL vector_length(vector)
  34.     var reg1 object vector;
  35.     { if (array_simplep(vector))
  36.         return TheSarray(vector)->length;
  37.       # Nicht-simpler Array
  38.       { var reg2 Array addr = TheArray(vector);
  39.         var reg3 uintL offset = offsetofa(array_,dims);
  40.         if (addr->flags & bit(arrayflags_dispoffset_bit))
  41.           offset += sizeof(uintL);
  42.         # Bei addr+offset fangen die Dimensionen an.
  43.         if (addr->flags & bit(arrayflags_fillp_bit)) # evtl. Fillpointer
  44.           offset += sizeof(uintL);
  45.         return *(uintL*)pointerplus(addr,offset);
  46.     } }
  47.  
  48. # Wandelt element-type in einen der Standard-Typen um
  49. # und liefert seinen Elementtyp-Code.
  50. # eltype_code(element_type)
  51. # > element_type: Type-Specifier
  52. # < ergebnis: Elementtyp-Code Atype_xxx
  53. # Standard-Typen sind die möglichen Ergebnisse von ARRAY-ELEMENT-TYPE
  54. # (Symbole T, BIT, STRING-CHAR und Listen (UNSIGNED-BYTE n)).
  55. # Das Ergebnis ist ein Obertyp von element-type.
  56. # kann GC auslösen
  57.   global uintB eltype_code (object element_type);
  58.   global uintB eltype_code(obj)
  59.     var reg1 object obj;
  60.     # Bei jeder Modifikation auch upgraded-array-element-type in type.lsp anpassen!
  61.     {
  62.       #if 0
  63.       # Vorläufige Methode:
  64.       # obj mit den Symbolen BIT, STRING-CHAR vergleichen.
  65.       # Default ist T (garantiert ein Obertyp von allem).
  66.       # Besser wäre:
  67.       # (subtypep obj 'BIT) und (subtypep obj 'STRING-CHAR) abfragen.
  68.       if (eq(obj,S(bit))) { return Atype_Bit; } # Symbol BIT ?
  69.       elif (eq(obj,S(string_char))) { return Atype_String_Char; } # Symbol STRING-CHAR ?
  70.       else # alles andere wird als T interpretiert
  71.         { STACK_5 = S(t); return Atype_T; }
  72.       #else
  73.       # (cond ((eq obj 'BIT) Atype_Bit)
  74.       #       ((eq obj 'STRING-CHAR) Atype_String_Char)
  75.       #       ((eq obj 'T) Atype_T)
  76.       #       (t (multiple-value-bind (low high) (sys::subtype-integer obj))
  77.       #            ; Es gilt (or (null low) (subtypep obj `(INTEGER ,low ,high)))
  78.       #            (if (and (integerp low) (not (minusp low)) (integerp high))
  79.       #              (let ((l (integer-length high)))
  80.       #                ; Es gilt (subtypep obj `(UNSIGNED-BYTE ,l))
  81.       #                (cond ((<= l 1) Atype_Bit)
  82.       #                      ((<= l 2) Atype_2Bit)
  83.       #                      ((<= l 4) Atype_4Bit)
  84.       #                      ((<= l 8) Atype_8Bit)
  85.       #                      ((<= l 16) Atype_16Bit)
  86.       #                      ((<= l 32) Atype_32Bit)
  87.       #                      (t Atype_T)
  88.       #              ) )
  89.       #              Atype_T
  90.       # )     )  ) )
  91.       if (eq(obj,S(bit))) { return Atype_Bit; } # Symbol BIT ?
  92.       elif (eq(obj,S(string_char))) { return Atype_String_Char; } # Symbol STRING-CHAR ?
  93.       elif (eq(obj,S(t))) { return Atype_T; } # Symbol T ?
  94.       pushSTACK(subr_self); # subr_self retten
  95.       pushSTACK(obj); funcall(S(subtype_integer),1); # (SYS::SUBTYPE-INTEGER obj)
  96.       subr_self = popSTACK(); # subr_self zurück
  97.       if ((mv_count>1) && integerp(value1) && positivep(value1) && mintegerp(value2))
  98.         { var reg2 uintL l = I_integer_length(value2); # (INTEGER-LENGTH high)
  99.           if (l<=1) return Atype_Bit;
  100.           if (l<=2) return Atype_2Bit;
  101.           if (l<=4) return Atype_4Bit;
  102.           if (l<=8) return Atype_8Bit;
  103.           if (l<=16) return Atype_16Bit;
  104.           if (l<=32) return Atype_32Bit;
  105.         }
  106.       return Atype_T;
  107.       #endif
  108.     }
  109.  
  110. # UP: erzeugt einen Bytevektor
  111. # allocate_byte_vector(atype,len)
  112. # > uintB atype: Atype_nBit
  113. # > uintL len: Länge (in n-Bit-Blöcken)
  114. # < ergebnis: neuer Semi-Simple-Bytevektor dieser Länge
  115. # kann GC auslösen
  116.   local object allocate_byte_vector (uintB atype, uintL len);
  117.   local object allocate_byte_vector(atype,len)
  118.     var reg2 uintB atype;
  119.     var reg3 uintL len;
  120.     { {var reg1 object new_sbvector = allocate_bit_vector(len<<atype);
  121.        # neuer Simple-Bit-Vektor passender Länge
  122.        pushSTACK(new_sbvector); # retten
  123.       }
  124.       {var reg1 object new_array = allocate_array(atype,1,bvector_type);
  125.                                    # Flags: keine, Elementtyp Atype_nBit, Rang=1
  126.        TheArray(new_array)->totalsize =
  127.          TheArray(new_array)->dims[0] = len; # Länge und Total-Size eintragen
  128.        TheArray(new_array)->data = popSTACK(); # Datenvektor eintragen
  129.        return new_array;
  130.     } }
  131.  
  132. LISPFUN(vector,0,0,rest,nokey,0,NIL) # (VECTOR {object}), CLTL S. 290
  133.   { var reg4 object new_vector = allocate_vector((uintL)argcount);
  134.     var reg1 uintC count;
  135.     var reg3 object* argptr = rest_args_pointer;
  136.     var reg2 object* ptr = &TheSvector(new_vector)->data[0];
  137.     dotimesC(count,argcount, { *ptr++ = NEXT(argptr); } );
  138.     value1 = new_vector; mv_count=1;
  139.     set_args_end_pointer(rest_args_pointer);
  140.   }
  141.  
  142. # Vom Standpunkt der Speicherstruktur her ist "der Datenvektor" eines
  143. # nicht-simplen Arrays  TheArray(array)->data.
  144. # Vom Standpunkt der Arrayfunktionen her bekommt man "den Datenvektor" eines
  145. # Arrays, indem man so lange  TheArray(array)->data  nimmt, bis
  146. # (bei Elementtypen T, BIT, STRING-CHAR) array ein simpler Vektor oder
  147. # (bei Byte-Arrays) array ein nicht-simpler Vektor ohne arrayflags_..._bits,
  148. # aber TheArray(array)->data ein Simple-Bit-Vektor ist.
  149.  
  150. # UP: verfolgt Kette von displaced-Arrays und addiert displaced-Offsets
  151. #     für Zugriff auf ein einzelnes Array-Element
  152. # notsimple_displace(array,&index);
  153. # > array: Nicht-simpler Array
  154. # > index: Row-major-index
  155. # < ergebnis: Datenvektor
  156. # < index: absoluter Index in den Datenvektor
  157. # Es wird überprüft, ob das adressierte Array-Element in jedem der Arrays liegt.
  158. # Es wird nicht überprüft, ob die Kette in einen Zyklus läuft.
  159.   local object notsimple_displace (object array, uintL* index);
  160.   local object notsimple_displace(array,index)
  161.     var reg1 object array;
  162.     var reg2 uintL* index;
  163.     { loop
  164.         { if (*index >= TheArray(array)->totalsize) goto fehler_bad_index;
  165.           if (!(TheArray(array)->flags & bit(arrayflags_displaced_bit)))
  166.             goto notdisplaced;
  167.           # Array ist displaced
  168.           *index += TheArray(array)->dims[0]; # displaced-Offset addieren
  169.           array = TheArray(array)->data; # nächster Array
  170.           if (array_simplep(array)) goto simple; # nächster Array simple?
  171.         }
  172.       notdisplaced:
  173.         # Array ist nicht displaced, aber auch nicht simple
  174.         if (TheArray(array)->flags & bit(arrayflags_notbytep_bit))
  175.           { array = TheArray(array)->data; # Datenvektor ist garantiert simple
  176.             simple:
  177.             # Array ist simple
  178.             if (*index >= TheSarray(array)->length) goto fehler_bad_index;
  179.             return array;
  180.           }
  181.           else
  182.           # Byte-Array
  183.           { if (!m_simple_bit_vector_p(TheArray(array)->data))
  184.               array = TheArray(array)->data;
  185.             # letzter Datenvektor erreicht
  186.             if (*index >= TheArray(array)->totalsize) goto fehler_bad_index;
  187.             return array;
  188.           }
  189.       fehler_bad_index:
  190.         //: DEUTSCH "Index in Array zu groß."
  191.         //: ENGLISH "index too large"
  192.         //: FRANCAIS "Index dans matrice trop grand."
  193.         fehler(error,GETTEXT("index too large")); # ausführlicher??
  194.     }
  195.  
  196. # Fehler, wenn ein displaced Array nicht mehr in seinen Ziel-Array paßt
  197.   nonreturning_function(local, fehler_displaced_inconsistent, (void));
  198.   local void fehler_displaced_inconsistent()
  199.     { 
  200.       //: DEUTSCH "Der Ziel-Array eines Displaced-Array wurde durch Adjustieren verkleinert."
  201.       //: ENGLISH "An array has been shortened by adjusting it while another array was displaced to it."
  202.       //: FRANCAIS "La matrice cible d'un «displaced-array» a été rapetissée par ajustement."
  203.       fehler(error,GETTEXT("An array has been shortened by adjusting it while another array was displaced to it."));
  204.     }
  205.  
  206. # UP: Liefert zu einem Array gegebener Größe den Datenvektor und den Offset.
  207. # Überprüft auch, ob alle Elemente des Arrays physikalisch vorhanden sind.
  208. # array1_displace_check(array,size,&index)
  209. # > object array: (echter) Array
  210. # > uintL size: Größe
  211. # < ergebnis: Datenvektor
  212. # < index: wird um den Offset in den Datenvektor erhöht.
  213.   global object array1_displace_check (object array, uintL size, uintL* index);
  214.   global object array1_displace_check(array,size,index)
  215.     var reg1 object array;
  216.     var reg2 uintL size;
  217.     var reg2 uintL* index;
  218.     { loop
  219.         { if (*index+size > TheArray(array)->totalsize) goto fehler_bad_index;
  220.           if (!(TheArray(array)->flags & bit(arrayflags_displaced_bit)))
  221.             goto notdisplaced;
  222.           # Array ist displaced
  223.           *index += TheArray(array)->dims[0]; # displaced-Offset addieren
  224.           array = TheArray(array)->data; # nächster Array
  225.           if (array_simplep(array)) goto simple; # nächster Array simple?
  226.         }
  227.       notdisplaced:
  228.         # Array ist nicht displaced, aber auch nicht simple
  229.         if (TheArray(array)->flags & bit(arrayflags_notbytep_bit))
  230.           { array = TheArray(array)->data; # Datenvektor ist garantiert simple
  231.             simple:
  232.             # Array ist simple
  233.             if (*index+size > TheSarray(array)->length) goto fehler_bad_index;
  234.             return array;
  235.           }
  236.           else
  237.           # Byte-Array
  238.           { if (!m_simple_bit_vector_p(TheArray(array)->data))
  239.               array = TheArray(array)->data;
  240.             # letzter Datenvektor erreicht
  241.             if (*index+size > TheArray(array)->totalsize) goto fehler_bad_index;
  242.             return array;
  243.           }
  244.       fehler_bad_index:
  245.         fehler_displaced_inconsistent();
  246.     }
  247.  
  248. # UP: Liefert zu einem Array gegebener Größe den Datenvektor und den Offset.
  249. # Überprüft auch, ob alle Elemente des Arrays physikalisch vorhanden sind.
  250. # array_displace_check(array,size,&index)
  251. # > object array: Array
  252. # > uintL size: Größe
  253. # < ergebnis: Datenvektor
  254. # < index: wird um den Offset in den Datenvektor erhöht.
  255.   global object array_displace_check (object array, uintL size, uintL* index);
  256.   global object array_displace_check(array,size,index)
  257.     var reg1 object array;
  258.     var reg2 uintL size;
  259.     var reg2 uintL* index;
  260.     { if (array_simplep(array)) goto simple; # Array simple?
  261.       loop
  262.         { if (*index+size > TheArray(array)->totalsize) goto fehler_bad_index;
  263.           if (!(TheArray(array)->flags & bit(arrayflags_displaced_bit)))
  264.             goto notdisplaced;
  265.           # Array ist displaced
  266.           *index += TheArray(array)->dims[0]; # displaced-Offset addieren
  267.           array = TheArray(array)->data; # nächster Array
  268.           if (array_simplep(array)) goto simple; # nächster Array simple?
  269.         }
  270.       notdisplaced:
  271.         # Array ist nicht displaced, aber auch nicht simple
  272.         if (TheArray(array)->flags & bit(arrayflags_notbytep_bit))
  273.           { array = TheArray(array)->data; # Datenvektor ist garantiert simple
  274.             simple:
  275.             # Array ist simple
  276.             if (*index+size > TheSarray(array)->length) goto fehler_bad_index;
  277.             return array;
  278.           }
  279.           else
  280.           # Byte-Array
  281.           { if (!m_simple_bit_vector_p(TheArray(array)->data))
  282.               array = TheArray(array)->data;
  283.             # letzter Datenvektor erreicht
  284.             if (*index+size > TheArray(array)->totalsize) goto fehler_bad_index;
  285.             return array;
  286.           }
  287.       fehler_bad_index:
  288.         fehler_displaced_inconsistent();
  289.     }
  290.  
  291. # Fehlermeldung
  292. # > obj: Nicht-Array
  293. # > subr_self: Aufrufer (ein SUBR)
  294.   nonreturning_function(local, fehler_array, (object obj));
  295.   local void fehler_array(obj)
  296.     var reg1 object obj;
  297.     { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  298.       pushSTACK(S(array)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  299.       pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  300.       //: DEUTSCH "~: ~ ist kein Array."
  301.       //: ENGLISH "~: ~ is not an array"
  302.       //: FRANCAIS "~: n'est pas une matrice."
  303.       fehler(type_error,GETTEXT("~: ~ is not an array"));
  304.     }
  305.  
  306. # Fehlermeldung
  307. # > obj: Nicht-Array
  308. # > subr_self: Aufrufer (ein SUBR)
  309.   nonreturning_function(local, fehler_array_displaced_to, (object obj));
  310.   local void fehler_array_displaced_to(obj)
  311.     var reg1 object obj;
  312.     { 
  313.       pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  314.       pushSTACK(S(array)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  315.       pushSTACK(obj);
  316.       pushSTACK(S(Kdisplaced_to));
  317.       pushSTACK(TheSubr(subr_self)->name);
  318.       //: DEUTSCH "~: ~-Argument ~ ist kein Array."
  319.       //: ENGLISH "~: ~-argument ~ is not an array"
  320.       //: FRANCAIS "~: Le ~ argument ~ n'est pas une matrice."
  321.       fehler(type_error,GETTEXT("~: ~-argument ~ is not an array"));
  322.     }
  323.  
  324. # Überprüft Array-Argument.
  325. # > object: Argument
  326. # > subr_self: Aufrufer (ein SUBR)
  327. # test_array(object)
  328.   #define test_array(object_from_test_array)  \
  329.     if_arrayp (object_from_test_array, ; , { fehler_array(object_from_test_array); } )
  330.  
  331. # Liefert den Rang eines Arrays.
  332. # > array: ein Array
  333. # < ergebnis: Rang als Fixnum
  334. # arrayrank(array)
  335.   #define arrayrank(array)  \
  336.     (array1p(array)                                               \
  337.      ? fixnum((uintL)(TheArray(array)->rank)) # allgemeiner Array \
  338.      : Fixnum_1 # Vektor hat Rang 1                               \
  339.     )
  340.  
  341. # Fehlermeldung
  342. # > array : Array
  343. # > argcount : (fehlerhafte) Anzahl Subscripts
  344. # > subr_self: Aufrufer (ein SUBR)
  345.   nonreturning_function(local, fehler_subscript_anz, (object array, uintC argcount));
  346.   local void fehler_subscript_anz(array,argcount)
  347.     var reg1 object array;
  348.     var reg2 uintC argcount;
  349.     { pushSTACK(arrayrank(array));
  350.       pushSTACK(array);
  351.       pushSTACK(fixnum(argcount));
  352.       pushSTACK(TheSubr(subr_self)->name);
  353.       //: DEUTSCH "~: Es wurden ~ Subscripts angegeben, ~ hat aber den Rang ~."
  354.       //: ENGLISH "~: got ~ subscripts, but ~ has rank ~"
  355.       //: FRANCAIS "~: ~ indices donnés mais ~ est de rang ~."
  356.       fehler(error,GETTEXT("~: got ~ subscripts, but ~ has rank ~"));
  357.     }
  358.  
  359. # Fehlermeldung
  360. # > argcount : Anzahl der Subscripts, über ihnen der Array
  361. # > subr_self: Aufrufer (ein SUBR)
  362.   nonreturning_function(local, fehler_subscript_type, (uintC argcount));
  363.   local void fehler_subscript_type(argcount)
  364.     var reg2 uintC argcount;
  365.     { var reg1 object list = listof(argcount); # Subscript-Liste
  366.       # Nun ist STACK_0 der Array.
  367.       pushSTACK(list);
  368.       pushSTACK(TheSubr(subr_self)->name);
  369.       //: DEUTSCH "~: Subscripts ~ für ~ sind nicht vom Typ `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  370.       //: ENGLISH "~: subscripts ~ for ~ are not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"
  371.       //: FRANCAIS "~: Les indices ~ pour ~ ne sont pas de type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  372.       fehler(error,GETTEXT("~: subscripts ~ for ~ are not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
  373.     }
  374.  
  375. # Fehlermeldung
  376. # > argcount : Anzahl der Subscripts, über ihnen der Array
  377. # > subr_self: Aufrufer (ein SUBR)
  378.   nonreturning_function(local, fehler_subscript_range, (uintC argcount));
  379.   local void fehler_subscript_range(argcount)
  380.     var reg2 uintC argcount;
  381.     { var reg1 object list = listof(argcount); # Subscript-Liste
  382.       # Nun ist STACK_0 der Array.
  383.       pushSTACK(list);
  384.       pushSTACK(TheSubr(subr_self)->name);
  385.       //: DEUTSCH "~: Subscripts ~ für ~ liegen nicht im erlaubten Bereich."
  386.       //: ENGLISH "~: subscripts ~ for ~ are out of range"
  387.       //: FRANCAIS "~: Les indices ~ pour ~ ne sont pas dans l'intervalle permis."
  388.       fehler(error,GETTEXT("~: subscripts ~ for ~ are out of range"));
  389.     }
  390.  
  391. # Überprüft Subscripts für einen AREF/STORE-Zugriff, entfernt sie vom STACK
  392. # und liefert den Row-Major-Index (>=0, <arraysize_limit).
  393. # test_subscripts(array,argptr,argcount)
  394. # > array : nicht-simpler Array
  395. # > argptr : Pointer über die Subscripts
  396. # > argcount : Anzahl der Subscripts
  397. # < ergebnis : row-major-index
  398.   local uintL test_subscripts (object array, object* argptr, uintC argcount);
  399.   local uintL test_subscripts(array,argptr,argcount)
  400.     var reg1 object array;
  401.     var reg4 object* argptr;
  402.     var reg6 uintC argcount;
  403.     { var reg5 object* args_pointer = argptr; # argptr retten für später
  404.       # Anzahl der Subscripts überprüfen:
  405.       if (!(argcount == TheArray(array)->rank)) # sollte = Rang sein
  406.         fehler_subscript_anz(array,argcount);
  407.       # Subscripts selbst überprüfen:
  408.      {var reg5 uintL row_major_index = 0;
  409.       var reg2 uintL* dimptr = &TheArray(array)->dims[0]; # Zeiger auf Dimensionen
  410.       if (TheArray(array)->flags & bit(arrayflags_dispoffset_bit))
  411.         dimptr++; # evtl. Displaced-Offset überspringen
  412.       { var reg3 uintC count;
  413.         dotimesC(count,argcount,
  414.           { var reg1 object subscriptobj = NEXT(argptr); # Subscript als Objekt
  415.             if (!(posfixnump(subscriptobj))) # Subscript muß Fixnum>=0 sein.
  416.               fehler_subscript_type(argcount);
  417.            {var reg1 uintL subscript = posfixnum_to_L(subscriptobj); # als uintL
  418.             var reg2 uintL dim = *dimptr++; # entsprechende Dimension
  419.             if (!(subscript<dim)) # Subscript muß kleiner als Dimension sein
  420.               fehler_subscript_range(argcount);
  421.             # Bilde row_major_index := row_major_index*dim+subscript:
  422.             row_major_index =
  423.               mulu32_unchecked(row_major_index,dim)+subscript;
  424.             # Das gibt keinen Überlauf, weil dies
  425.             # < Produkt der bisherigen Dimensionen
  426.             # <= Produkt aller Dimensionen < arraysize_limit <= 2^32
  427.             # ist. (Ausnahme: Falls eine spätere Dimension =0 ist.
  428.             # Aber dann gibt's nachher sowieso eine Fehlermeldung.)
  429.           }});
  430.       }
  431.       set_args_end_pointer(args_pointer);
  432.       return row_major_index;
  433.     }}
  434.  
  435. # Fehlermeldung
  436. # > STACK_1: Array (meist Vektor)
  437. # > STACK_0: (fehlerhafter) Index
  438. # > subr_self: Aufrufer (ein SUBR)
  439.   nonreturning_function(local, fehler_index_type, (void));
  440.   local void fehler_index_type()
  441.     { pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  442.       pushSTACK(O(type_array_index)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  443.       pushSTACK(STACK_(1+2));
  444.       pushSTACK(STACK_(0+3));
  445.       pushSTACK(TheSubr(subr_self)->name);
  446.       //: DEUTSCH "~: Index ~ für ~ ist nicht vom Typ `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  447.       //: ENGLISH "~: index ~ for ~ is not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"
  448.       //: FRANCAIS "~: L'indice ~ pour ~ n'est pas de type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  449.       fehler(type_error,GETTEXT("~: index ~ for ~ is not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
  450.     }
  451.  
  452. # Fehlermeldung
  453. # > STACK_1: Array (meist Vektor)
  454. # > STACK_0: (fehlerhafter) Index
  455. # > subr_self: Aufrufer (ein SUBR)
  456.   nonreturning_function(local, fehler_index_range, (void));
  457.   local void fehler_index_range()
  458.     { pushSTACK(TheSubr(subr_self)->name);
  459.       //: DEUTSCH "~: Index ~ für ~ ist zu groß."
  460.       //: ENGLISH "~: index ~ for ~ is out of range"
  461.       //: FRANCAIS "~: L'index ~ pour ~ est trop grand."
  462.       fehler(error,GETTEXT("~: index ~ for ~ is out of range"));
  463.     }
  464.  
  465. # Überprüft einen Index für einen AREF/STORE-Zugriff in einen simplen Vektor.
  466. # test_index()
  467. # > STACK_1: simpler Vektor
  468. # > STACK_0: Index
  469. # < ergebnis: Index als uintL
  470.   local uintL test_index (void);
  471.   local uintL test_index()
  472.     { if (!mposfixnump(STACK_0)) # Index muß Fixnum>=0 sein.
  473.         fehler_index_type();
  474.      {var reg1 uintL index = posfixnum_to_L(STACK_0); # Index als uintL
  475.       if (!(index < TheSarray(STACK_1)->length)) # Index muß kleiner als Länge sein
  476.         fehler_index_range();
  477.       return index;
  478.     }}
  479.  
  480. # Überprüft Subscripts für einen AREF/STORE-Zugriff, entfernt sie vom STACK
  481. # und liefert den Row-Major-Index (>=0, <arraysize_limit) und den Datenvektor.
  482. # subscripts_to_index(array,argptr,argcount, &index)
  483. # > array : nicht-simpler Array
  484. # > argptr : Pointer über die Subscripts
  485. # > argcount : Anzahl der Subscripts
  486. # < index : Index in den Datenvektor
  487. # < ergebnis : der Datenvektor
  488.   local object subscripts_to_index (object array, object* argptr, uintC argcount, uintL* index_);
  489.   local object subscripts_to_index(array,argptr,argcount,index_)
  490.     var reg1 object array;
  491.     var reg4 object* argptr;
  492.     var reg2 uintC argcount;
  493.     var uintL* index_;
  494.     { test_array(array); # Array überprüfen
  495.       if (array_simplep(array))
  496.         # simpler Vektor, wird getrennt behandelt:
  497.         { # Anzahl der Subscripts überprüfen:
  498.           if (!(argcount == 1)) # sollte = 1 sein
  499.             fehler_subscript_anz(array,argcount);
  500.           # Subscript selbst überprüfen:
  501.           *index_ = test_index(); # Index = Row-Major-Index = Subscript
  502.           skipSTACK(1); return array;
  503.         }
  504.         else
  505.         # nicht-simpler Array
  506.         { # Subscripts überprüfen, Row-Major-Index errechnen, STACK aufräumen:
  507.           *index_ = test_subscripts(array,argptr,argcount);
  508.           # Datenvektor und absoluten Index holen:
  509.           return notsimple_displace(array,&(*index_));
  510.         }
  511.     }
  512.  
  513. # Führt einen AREF-Zugriff aus.
  514. # datenvektor_aref(datenvektor,index)
  515. # > datenvektor : ein Datenvektor (simpler Vektor oder semi-simpler Byte-Vektor)
  516. # > index : (geprüfter) Index in den Datenvektor
  517. # < ergebnis : (AREF datenvektor index)
  518. # kann GC auslösen (nur bei 32Bit-Byte-Vektoren)
  519.   global object datenvektor_aref (object datenvektor, uintL index);
  520.   global object datenvektor_aref(datenvektor,index)
  521.     var reg3 object datenvektor;
  522.     var reg1 uintL index;
  523.     { switch (typecode(datenvektor))
  524.         { case_svector: # Simple-Vector
  525.             return TheSvector(datenvektor)->data[index];
  526.           case_sbvector: # Simple-Bit-Vector
  527.             return ( sbvector_btst(datenvektor,index) ? Fixnum_1 : Fixnum_0 );
  528.           case_sstring: # Simple-String
  529.             return code_char(TheSstring(datenvektor)->data[index]);
  530.           case_obvector: # Byte-Vector
  531.             { var reg2 uintB* ptr = &TheSbvector(TheArray(datenvektor)->data)->data[0];
  532.               switch (TheArray(datenvektor)->flags /* & arrayflags_atype_mask */ )
  533.                 { case Atype_2Bit:
  534.                     return fixnum((ptr[index/4]>>(2*((~index)%4)))&(bit(2)-1));
  535.                   case Atype_4Bit:
  536.                     return fixnum((ptr[index/2]>>(4*((~index)%2)))&(bit(4)-1));
  537.                   case Atype_8Bit:
  538.                     return fixnum(ptr[index]);
  539.                   case Atype_16Bit:
  540.                     return fixnum(((uint16*)ptr)[index]);
  541.                   case Atype_32Bit:
  542.                     return UL_to_I(((uint32*)ptr)[index]);
  543.                   default: NOTREACHED
  544.             }   }
  545.           default: NOTREACHED
  546.     }   }
  547.  
  548. # Führt einen STORE-Zugriff aus.
  549. # datenvektor_store(datenvektor,index,element)
  550. # > datenvektor : ein Datenvektor (simpler Vektor oder semi-simpler Byte-Vektor)
  551. # > index : (geprüfter) Index in den Datenvektor
  552. # > element : (ungeprüftes) einzutragendes Objekt
  553. # > STACK_0 : array (für Fehlermeldung)
  554. # > subr_self: Aufrufer (ein SUBR)
  555.   local void datenvektor_store (object datenvektor, uintL index, object element);
  556.   local void datenvektor_store(datenvektor,index,element)
  557.     var reg4 object datenvektor;
  558.     var reg1 uintL index;
  559.     var reg3 object element;
  560.     { switch (typecode(datenvektor))
  561.         { case_svector: # Simple-Vector
  562.             { TheSvector(datenvektor)->data[index] = element; return; }
  563.           case_sbvector: # Simple-Bit-Vector
  564.             { var reg2 uintB* addr = &TheSbvector(datenvektor)->data[index/8];
  565.               var reg1 uintL bitnummer = (~index)%8; # 7 - (index mod 8)
  566.               if (eq(element,Fixnum_0)) { *addr &= ~bit(bitnummer); return; }
  567.               elif (eq(element,Fixnum_1)) { *addr |= bit(bitnummer); return; }
  568.               else break;
  569.             }
  570.           case_sstring: # Simple-String
  571.             if (string_char_p(element))
  572.               { TheSstring(datenvektor)->data[index] = char_code(element);
  573.                 return;
  574.               }
  575.             else break;
  576.           case_obvector: # Byte-Vector
  577.             { var reg2 uintB* ptr = &TheSbvector(TheArray(datenvektor)->data)->data[0];
  578.               var reg5 uintL wert;
  579.               switch (TheArray(datenvektor)->flags /* & arrayflags_atype_mask */ )
  580.                 { case Atype_2Bit:
  581.                     if (posfixnump(element) && ((wert = posfixnum_to_L(element)) < bit(2)))
  582.                       { ptr[index/4] ^= (ptr[index/4] ^ (wert<<(2*((~index)%4)))) & ((bit(2)-1)<<(2*((~index)%4)));
  583.                         return;
  584.                       }
  585.                       else break;
  586.                   case Atype_4Bit:
  587.                     if (posfixnump(element) && ((wert = posfixnum_to_L(element)) < bit(4)))
  588.                       { ptr[index/2] ^= (ptr[index/2] ^ (wert<<(4*((~index)%2)))) & ((bit(4)-1)<<(4*((~index)%2)));
  589.                         return;
  590.                       }
  591.                       else break;
  592.                   case Atype_8Bit:
  593.                     if (posfixnump(element) && ((wert = posfixnum_to_L(element)) < bit(8)))
  594.                       { ptr[index] = wert; return; }
  595.                       else break;
  596.                   case Atype_16Bit:
  597.                     if (posfixnump(element) && ((wert = posfixnum_to_L(element)) < bit(16)))
  598.                       { ((uint16*)ptr)[index] = wert; return; }
  599.                       else break;
  600.                   case Atype_32Bit:
  601.                     ((uint32*)ptr)[index] = I_to_UL(element); # evtl. Fehlermeldung macht I_to_UL
  602.                     return;
  603.                   default: NOTREACHED
  604.                 }
  605.               break;
  606.             }
  607.           default: NOTREACHED
  608.         }
  609.       # Objekt war vom falschen Typ.
  610.       { # array bereits in STACK_0
  611.         pushSTACK(element); # Wert für Slot DATUM von TYPE-ERROR
  612.         pushSTACK(array_element_type(STACK_(0+1))); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  613.         pushSTACK(STACK_(0+2)); # array
  614.         pushSTACK(STACK_2); # element
  615.         pushSTACK(TheSubr(subr_self)->name);
  616.         //: DEUTSCH "~: ~ hat nicht den richtigen Typ für ~"
  617.         //: ENGLISH "~: ~ does not fit into ~, bad type"
  618.         //: FRANCAIS "~: ~ n'est pas de type correct pour ~."
  619.         fehler(type_error,GETTEXT("~: ~ does not fit into ~, bad type"));
  620.     } }
  621.  
  622. LISPFUN(aref,1,0,rest,nokey,0,NIL) # (AREF array {subscript}), CLTL S. 290
  623.   { var reg1 object array = Before(rest_args_pointer); # Array holen
  624.     # Subscripts verarbeiten und Datenvektor und Index holen:
  625.     var uintL index;
  626.     var reg2 object datenvektor = subscripts_to_index(array,rest_args_pointer,argcount, &index);
  627.     # Element des Datenvektors holen:
  628.     value1 = datenvektor_aref(datenvektor,index); mv_count=1;
  629.     skipSTACK(1);
  630.   }
  631.  
  632. LISPFUN(store,2,0,rest,nokey,0,NIL) # (SYS::STORE array {subscript} object)
  633.                      # = (SETF (AREF array {subscript}) object), CLTL S. 291
  634.   { rest_args_pointer skipSTACKop 1; # Pointer über ersten Subscript
  635.    {var reg1 object element = popSTACK();
  636.     var reg2 object array = Before(rest_args_pointer); # Array holen
  637.     # Subscripts verarbeiten und Datenvektor und Index holen:
  638.     var uintL index;
  639.     var reg3 object datenvektor = subscripts_to_index(array,rest_args_pointer,argcount, &index);
  640.     # Element in den Datenvektor eintragen:
  641.     datenvektor_store(datenvektor,index,element);
  642.     value1 = element; mv_count=1;
  643.     skipSTACK(1);
  644.   }}
  645.  
  646. # Fehlermeldung
  647. # > STACK_1: Nicht-Simple-Vector
  648. # > subr_self: Aufrufer (ein SUBR)
  649.   nonreturning_function(local, fehler_svector, (void));
  650.   local void fehler_svector()
  651.     { fehler_kein_svector(TheSubr(subr_self)->name,STACK_1); }
  652.  
  653. LISPFUNN(svref,2) # (SVREF simple-vector index), CLTL S. 291
  654.   { # simple-vector überprüfen:
  655.     if (!m_simple_vector_p(STACK_1)) fehler_svector();
  656.    {# index überprüfen:
  657.     var reg1 uintL index = test_index();
  658.     # Element holen:
  659.     value1 = TheSvector(STACK_1)->data[index]; mv_count=1;
  660.     skipSTACK(2);
  661.   }}
  662.  
  663. LISPFUNN(svstore,3) # (SYS::SVSTORE simple-vector index element)
  664.                     # = (SETF (SVREF simple-vector index) element), CLTL S. 291
  665.   { var reg3 object element = popSTACK();
  666.     # simple-vector überprüfen:
  667.     if (!m_simple_vector_p(STACK_1)) fehler_svector();
  668.    {# index überprüfen:
  669.     var reg1 uintL index = test_index();
  670.     # Element ablegen:
  671.     TheSvector(STACK_1)->data[index] = element;
  672.     value1 = element; mv_count=1;
  673.     skipSTACK(2);
  674.   }}
  675.  
  676. LISPFUNN(psvstore,3) # (SYS::%SVSTORE element simple-vector index)
  677.                      # = (SETF (SVREF simple-vector index) element)
  678.   { # simple-vector überprüfen:
  679.     if (!m_simple_vector_p(STACK_1)) fehler_svector();
  680.    {# index überprüfen:
  681.     var reg1 uintL index = test_index();
  682.     # Element ablegen:
  683.     value1 = TheSvector(STACK_1)->data[index] = STACK_2; mv_count=1;
  684.     skipSTACK(3);
  685.   }}
  686.  
  687. LISPFUNN(row_major_aref,2)
  688. # (ROW-MAJOR-AREF array index), CLtL2 S. 450
  689.   { var reg1 object array = STACK_1;
  690.     # Array überprüfen:
  691.     test_array(array);
  692.     # index überprüfen:
  693.     if (!mposfixnump(STACK_0)) fehler_index_type();
  694.    {var uintL index = posfixnum_to_L(STACK_0);
  695.     if (!(index < array_total_size(array))) # Index muß kleiner als Größe sein
  696.       fehler_index_range();
  697.     if (!array_simplep(array))
  698.       { array = notsimple_displace(array,&index); }
  699.     value1 = datenvektor_aref(array,index); mv_count=1;
  700.     skipSTACK(2);
  701.   }}
  702.  
  703. LISPFUNN(row_major_store,3)
  704. # (SYS::ROW-MAJOR-STORE array index element)
  705. # = (SETF (ROW-MAJOR-AREF array index) element), CLtL2 S. 450
  706.   { var reg2 object element = popSTACK();
  707.     var reg1 object array = STACK_1;
  708.     # Array überprüfen:
  709.     test_array(array);
  710.     # index überprüfen:
  711.     if (!mposfixnump(STACK_0)) fehler_index_type();
  712.    {var uintL index = posfixnum_to_L(STACK_0);
  713.     if (!(index < array_total_size(array))) # Index muß kleiner als Größe sein
  714.       fehler_index_range();
  715.     if (!array_simplep(array))
  716.       { array = notsimple_displace(array,&index); }
  717.     datenvektor_store(array,index,element);
  718.     value1 = element; mv_count=1;
  719.     skipSTACK(2);
  720.   }}
  721.  
  722. # UP, liefert den Element-Typ eines Arrays
  723. # array_element_type(array)
  724. # > array : ein Array (simple oder nicht)
  725. # < ergebnis : Element-Typ, eines der Symbole T, BIT, STRING-CHAR, oder eine Liste
  726. # kann GC auslösen
  727.   global object array_element_type (object array);
  728.   global object array_element_type(array)
  729.     var reg2 object array;
  730.     { switch (typecode(array))
  731.         { case_string: # String -> STRING-CHAR
  732.             return S(string_char);
  733.           case_sbvector: # Simple-Bit-Vector -> BIT
  734.             return S(bit);
  735.           case_vector: # allg. Vector -> T
  736.             return S(t);
  737.           case_obvector: # Byte-Vector
  738.           case_array1: # allgemeiner Array
  739.             { var reg1 uintBWL atype = TheArray(array)->flags & arrayflags_atype_mask;
  740.               switch (atype)
  741.                 { case Atype_T:           return S(t);           # T
  742.                   case Atype_Bit:         return S(bit);         # BIT
  743.                   case Atype_String_Char: return S(string_char); # STRING-CHAR
  744.                   case Atype_2Bit:        # (UNSIGNED-BYTE 2)
  745.                   case Atype_4Bit:        # (UNSIGNED-BYTE 4)
  746.                   case Atype_8Bit:        # (UNSIGNED-BYTE 8)
  747.                   case Atype_16Bit:       # (UNSIGNED-BYTE 16)
  748.                   case Atype_32Bit:       # (UNSIGNED-BYTE 32)
  749.                     pushSTACK(S(unsigned_byte));
  750.                     pushSTACK(fixnum(bit(atype)));
  751.                     return listof(2);
  752.                   default: NOTREACHED
  753.             }   }
  754.           default: NOTREACHED
  755.     }   }
  756.  
  757. LISPFUNN(array_element_type,1) # (ARRAY-ELEMENT-TYPE array), CLTL S. 291
  758.   { var reg1 object array = popSTACK();
  759.     test_array(array);
  760.     value1 = array_element_type(array); mv_count=1;
  761.   }
  762.  
  763. LISPFUNN(array_rank,1) # (ARRAY-RANK array), CLTL S. 292
  764.   { var reg1 object array = popSTACK();
  765.     test_array(array);
  766.     value1 = arrayrank(array); mv_count=1;
  767.   }
  768.  
  769. LISPFUNN(array_dimension,2) # (ARRAY-DIMENSION array axis-number), CLTL S. 292
  770.   { var reg1 object axis_number = popSTACK();
  771.     var reg2 object array = popSTACK();
  772.     test_array(array);
  773.     if (array_simplep(array))
  774.       # simpler Vektor: axis-number muß =0 sein, Wert ist dann die Länge.
  775.       { if (eq(axis_number,Fixnum_0))
  776.           { value1 = fixnum(TheSarray(array)->length);
  777.             mv_count=1; return;
  778.           }
  779.           else goto fehler_axis;
  780.       }
  781.       else
  782.       # nicht-simpler Array
  783.       { if (posfixnump(axis_number)) # axis-number muß ein Fixnum >=0,
  784.           { var reg1 uintL axis = posfixnum_to_L(axis_number);
  785.             if (axis < (uintL)(TheArray(array)->rank)) # und <rank sein
  786.               { var reg2 uintL* dimptr = &TheArray(array)->dims[0]; # Zeiger auf Dimensionen
  787.                 if (TheArray(array)->flags & bit(arrayflags_dispoffset_bit))
  788.                   dimptr++; # evtl. Displaced-Offset überspringen
  789.                 value1 = fixnum(dimptr[axis]);
  790.                 mv_count=1; return;
  791.               }
  792.               else goto fehler_axis;
  793.           }
  794.           else goto fehler_axis;
  795.       }
  796.     fehler_axis:
  797.       pushSTACK(array);
  798.       pushSTACK(axis_number);
  799.       pushSTACK(TheSubr(subr_self)->name);
  800.       //: DEUTSCH "~: ~ ist nicht >= 0 und < dem Rang von ~"
  801.       //: ENGLISH "~: ~ is not an nonnegative integer less than the rank of ~"
  802.       //: FRANCAIS "~: ~ n'est pas un entier >= 0 et strictement inférieur au rang de ~."
  803.       fehler(error,GETTEXT("~: ~ is not an nonnegative integer less than the rank of ~"));
  804.   }
  805.  
  806. # UP, bildet Liste der Dimensionen eines Arrays
  807. # array_dimensions(array)
  808. # > array: ein Array (simple oder nicht)
  809. # < ergebnis: Liste seiner Dimensionen
  810. # kann GC auslösen
  811.   global object array_dimensions (object array);
  812.   global object array_dimensions(array)
  813.     var reg1 object array;
  814.     { if (array_simplep(array))
  815.         # simpler Vektor, bilde (LIST length)
  816.         { var reg3 object len # Länge als Fixnum (nicht GC-gefährdet)
  817.             = fixnum(TheSarray(array)->length);
  818.           var reg2 object new_cons = allocate_cons();
  819.           Car(new_cons) = len; Cdr(new_cons) = NIL;
  820.           return new_cons;
  821.         }
  822.         else
  823.         # nicht-simpler Array: alle Dimensionen als Fixnums auf den STACK,
  824.         # dann eine Liste daraus machen.
  825.         { var reg3 uintC rank = TheArray(array)->rank;
  826.           var reg2 uintL* dimptr = &TheArray(array)->dims[0]; # Zeiger auf Dimensionen
  827.           if (TheArray(array)->flags & bit(arrayflags_dispoffset_bit))
  828.             dimptr++; # evtl. Displaced-Offset überspringen
  829.           get_space_on_STACK(sizeof(object)*(uintL)rank); # STACK überprüfen
  830.           { var reg1 uintC count;
  831.             dotimesC(count,rank,
  832.               { # nächste Dimension als Fixnum in den Stack:
  833.                 pushSTACK(fixnum(*dimptr++));
  834.               });
  835.           }
  836.           return listof(rank); # Liste bilden
  837.         }
  838.     }
  839.  
  840. LISPFUNN(array_dimensions,1) # (ARRAY-DIMENSIONS array), CLTL S. 292
  841.   { var reg1 object array = popSTACK();
  842.     test_array(array);
  843.     value1 = array_dimensions(array); mv_count=1;
  844.   }
  845.  
  846. # UP, liefert Dimensionen eines Arrays und ihre Teilprodukte
  847. # array_dims_sizes(array,&dims_sizes);
  848. # > array: (echter) Array vom Rang r
  849. # > struct { uintL dim; uintL dimprod; } dims_sizes[r]: Platz fürs Ergebnis
  850. # < für i=1,...r:  dims_sizes[r-i] = { Dim_i, Dim_i * ... * Dim_r }
  851.   global void array_dims_sizes (object array, array_dim_size* dims_sizes);
  852.   global void array_dims_sizes(array,dims_sizes)
  853.     var reg5 object array;
  854.     var reg1 array_dim_size* dims_sizes;
  855.     { var reg4 uintC r = TheArray(array)->rank; # Rang
  856.       var reg2 uintL* dimptr = &TheArray(array)->dims[0]; # Zeiger auf Dimensionen
  857.       if (TheArray(array)->flags & bit(arrayflags_dispoffset_bit))
  858.         dimptr++; # evtl. Displaced-Offset überspringen
  859.       dimptr = &dimptr[(uintL)r]; # Zeiger hinter die Dimensionen
  860.      {var reg3 uintL produkt = 1;
  861.       dotimesC(r,r, # Schleife über die r Dimensionen von hinten
  862.         { var reg2 uintL dim = *--dimptr; # nächste Dimension
  863.           produkt = mulu32_unchecked(produkt,dim); # aufs Produkt multiplizieren
  864.           # Das gibt keinen Überlauf, weil dies
  865.           # < Produkt der bisherigen Dimensionen
  866.           # <= Produkt aller Dimensionen < arraysize_limit <= 2^32 ist.
  867.           # (Ausnahme: Falls eine Dimension kleinerer Nummer =0 ist.
  868.           # Aber dann ist das jetzige Produkt sowieso irrelevant, da
  869.           # jede Schleife über diese Dimension eine Leerschleife ist.)
  870.           dims_sizes->dim = dim; dims_sizes->dimprod = produkt;
  871.           dims_sizes++;
  872.         });
  873.     }}
  874.  
  875. LISPFUNN(array_total_size,1) # (ARRAY-TOTAL-SIZE array), CLTL S. 292
  876.   { var reg1 object array = popSTACK();
  877.     test_array(array);
  878.     value1 = fixnum(array_total_size(array));
  879.     mv_count=1;
  880.   }
  881.  
  882. LISPFUN(array_in_bounds_p,1,0,rest,nokey,0,NIL)
  883. # (ARRAY-IN-BOUNDS-P array {subscript}), CLTL S. 292
  884.   { var reg4 object* argptr = rest_args_pointer;
  885.     var reg1 object array = BEFORE(rest_args_pointer); # Array holen
  886.     test_array(array); # Array überprüfen
  887.     if (array_simplep(array))
  888.       # simpler Vektor, wird getrennt behandelt:
  889.       { # Anzahl der Subscripts überprüfen:
  890.         if (!(argcount == 1)) # sollte = 1 sein
  891.           fehler_subscript_anz(array,argcount);
  892.         # Subscript selbst überprüfen:
  893.         { var reg2 object subscriptobj = STACK_0; # Subscript als Objekt
  894.           if (!integerp(subscriptobj)) { fehler_index_type(); } # muß Integer sein
  895.           # Subscript muß Fixnum>=0 sein,
  896.           # Subscript als uintL muß kleiner als Länge sein:
  897.           if (!( (posfixnump(subscriptobj))
  898.                  && (posfixnum_to_L(subscriptobj) < TheSarray(array)->length) ))
  899.             goto no;
  900.           goto yes;
  901.       } }
  902.       else
  903.       # nicht-simpler Array
  904.       { # Anzahl der Subscripts überprüfen:
  905.         if (!(argcount == TheArray(array)->rank)) # sollte = Rang sein
  906.           fehler_subscript_anz(array,argcount);
  907.         # Subscripts selbst überprüfen:
  908.         {var reg2 uintL* dimptr = &TheArray(array)->dims[0]; # Zeiger auf Dimensionen
  909.          if (TheArray(array)->flags & bit(arrayflags_dispoffset_bit))
  910.            dimptr++; # evtl. Displaced-Offset überspringen
  911.          { var reg3 uintC count;
  912.            dotimesC(count,argcount,
  913.              { var reg1 object subscriptobj = NEXT(argptr); # Subscript als Objekt
  914.                if (!integerp(subscriptobj)) { fehler_subscript_type(argcount); } # muß Integer sein
  915.                # Subscript muß Fixnum>=0 sein,
  916.                # Subscript als uintL muß kleiner als die entsprechende Dimension sein:
  917.                if (!( (posfixnump(subscriptobj))
  918.                       && (posfixnum_to_L(subscriptobj) < *dimptr++) ))
  919.                  goto no;
  920.              });
  921.         }}
  922.         goto yes;
  923.       }
  924.     yes: value1 = T; mv_count=1; set_args_end_pointer(rest_args_pointer); return;
  925.     no: value1 = NIL; mv_count=1; set_args_end_pointer(rest_args_pointer); return;
  926.   }
  927.  
  928. LISPFUN(array_row_major_index,1,0,rest,nokey,0,NIL)
  929. # (ARRAY-ROW-MAJOR-INDEX array {subscript}), CLTL S. 293
  930.   { var reg1 object array = Before(rest_args_pointer); # Array holen
  931.     var reg2 uintL index;
  932.     test_array(array); # Array überprüfen
  933.     if (array_simplep(array))
  934.       # simpler Vektor, wird getrennt behandelt:
  935.       { # Anzahl der Subscripts überprüfen:
  936.         if (!(argcount == 1)) # sollte = 1 sein
  937.           fehler_subscript_anz(array,argcount);
  938.         # Subscript selbst überprüfen:
  939.         test_index();
  940.         value1 = popSTACK(); mv_count=1; # Index = Row-Major-Index = Subscript
  941.         skipSTACK(1);
  942.       }
  943.       else
  944.       # nicht-simpler Array
  945.       { # Subscripts überprüfen, Row-Major-Index errechnen, STACK aufräumen:
  946.         index = test_subscripts(array,rest_args_pointer,argcount);
  947.         # Index als Fixnum zurück:
  948.         value1 = fixnum(index); mv_count=1;
  949.         skipSTACK(1);
  950.       }
  951.   }
  952.  
  953. LISPFUNN(adjustable_array_p,1) # (ADJUSTABLE-ARRAY-P array), CLTL S. 293
  954.   { var reg1 object array = popSTACK(); # Argument holen
  955.     test_array(array); # Array überprüfen
  956.     if (array_simplep(array))
  957.       goto no; # simpler Vektor, ist nicht adjustable
  958.       else
  959.       if (TheArray(array)->flags & bit(arrayflags_adjustable_bit))
  960.         goto yes;
  961.         else
  962.         goto no;
  963.     yes: value1 = T; mv_count=1; return;
  964.     no:  value1 = NIL; mv_count=1; return;
  965.   }
  966.  
  967. # Fehlermeldung
  968. # fehler_bit_array()
  969. # > STACK_0: Array, der kein Bit-Array ist
  970.   nonreturning_function(local, fehler_bit_array, (void));
  971.   local void fehler_bit_array()
  972.     { pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  973.       pushSTACK(O(type_array_bit)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  974.       pushSTACK(STACK_(0+2));
  975.       pushSTACK(TheSubr(subr_self)->name);
  976.       //: DEUTSCH "~: ~ ist kein Bit-Array."
  977.       //: ENGLISH "~: ~ is not an array of bits"
  978.       //: FRANCAIS "~: ~ n'est pas une matrice de bits."
  979.       fehler(type_error,GETTEXT("~: ~ is not an array of bits"));
  980.     }
  981.  
  982. LISPFUN(bit,1,0,rest,nokey,0,NIL) # (BIT bit-array {subscript}), CLTL S. 293
  983.   { var reg1 object array = Before(rest_args_pointer); # Array holen
  984.     # Subscripts verarbeiten und Datenvektor und Index holen:
  985.     var uintL index;
  986.     var reg2 object datenvektor = subscripts_to_index(array,rest_args_pointer,argcount, &index);
  987.     if (!(simple_bit_vector_p(datenvektor)))
  988.       fehler_bit_array();
  989.     # Datenvektor ist ein Simple-Bit-Vector. Element des Datenvektors holen:
  990.     value1 = ( sbvector_btst(datenvektor,index) ? Fixnum_1 : Fixnum_0 ); mv_count=1;
  991.     skipSTACK(1);
  992.   }
  993.  
  994. LISPFUN(sbit,1,0,rest,nokey,0,NIL) # (SBIT bit-array {subscript}), CLTL S. 293
  995.   { var reg1 object array = Before(rest_args_pointer); # Array holen
  996.     # Subscripts verarbeiten und Datenvektor und Index holen:
  997.     var uintL index;
  998.     var reg2 object datenvektor = subscripts_to_index(array,rest_args_pointer,argcount, &index);
  999.     if (!(simple_bit_vector_p(datenvektor)))
  1000.       fehler_bit_array();
  1001.     # Datenvektor ist ein Simple-Bit-Vector. Element des Datenvektors holen:
  1002.     value1 = ( sbvector_btst(datenvektor,index) ? Fixnum_1 : Fixnum_0 ); mv_count=1;
  1003.     skipSTACK(1);
  1004.   }
  1005.  
  1006. # Für Unterprogramme für Bitvektoren:
  1007.   # Man arbeitet mit Bit-Blöcken à bitpack Bits.
  1008.   # uint_bitpack ist ein unsigned Integer mit bitpack Bits.
  1009.   # uint_2bitpack ist ein unsigned Integer mit 2*bitpack Bits.
  1010.   # R_bitpack(x) liefert die rechte (untere) Hälfte eines uint_2bitpack.
  1011.   # L_bitpack(x) liefert die linke (obere) Hälfte eines uint_2bitpack.
  1012.   # LR_2bitpack(x,y) liefert zu x,y das aus der linken Hälfte x und der
  1013.   #                  rechten Hälfte y zusammengesetzte uint_2bitpack.
  1014.   # Verwende LR_0_bitpack(y) falls x=0, LR_bitpack_0(x) falls y=0.
  1015.   #if BIG_ENDIAN_P && (varobject_alignment%2 == 0)
  1016.     # Bei Big-Endian-Maschinen kann man gleich mit 16 Bit auf einmal arbeiten
  1017.     # (sofern varobject_alignment durch 2 Byte teilbar ist):
  1018.     #define bitpack  16
  1019.     #define uint_bitpack  uint16
  1020.     #define uint_2bitpack  uint32
  1021.     #define R_bitpack(x)  low16(x)
  1022.     #define L_bitpack(x)  high16(x)
  1023.     #define LR_2bitpack(x,y)  highlow32(x,y)
  1024.     #define LR_0_bitpack(y)  ((uint32)(uint16)(y))
  1025.     #define LR_bitpack_0(x)  highlow32_0(x)
  1026.   #else
  1027.     # Sonst kann man nur 8 Bit auf einmal nehmen:
  1028.     #define bitpack  8
  1029.     #define uint_bitpack  uint8
  1030.     #define uint_2bitpack  uint16
  1031.     #define R_bitpack(x)  ((uint_bitpack)(uint_2bitpack)(x))
  1032.     #define L_bitpack(x)  ((uint_bitpack)((uint_2bitpack)(x) >> bitpack))
  1033.     #define LR_2bitpack(x,y)  \
  1034.       (((uint_2bitpack)(uint_bitpack)(x) << bitpack)  \
  1035.        | (uint_2bitpack)(uint_bitpack)(y)             \
  1036.       )
  1037.     #define LR_0_bitpack(y)  LR_2bitpack(0,y)
  1038.     #define LR_bitpack_0(x)  LR_2bitpack(x,0)
  1039.   #endif
  1040.  
  1041. # Unterprogramm für Bitvektor-Vergleich:
  1042. # bit_compare(array1,index1,array2,index2,count)
  1043. # > array1: erster Bit-Array,
  1044. # > index1: absoluter Index in array1
  1045. # > array2: zweiter Bit-Array,
  1046. # > index2: absoluter Index in array2
  1047. # > count: Anzahl der zu vergleichenden Bits
  1048. # < ergebnis: TRUE, wenn die Ausschnitte bitweise gleich sind, FALSE sonst.
  1049.   global boolean bit_compare (object array1, uintL index1,
  1050.                               object array2, uintL index2,
  1051.                               uintL bitcount);
  1052.   global boolean bit_compare(array1,index1,array2,index2,bitcount)
  1053.     var reg9 object array1;
  1054.     var reg5 uintL index1;
  1055.     var reg9 object array2;
  1056.     var reg6 uintL index2;
  1057.     var reg8 uintL bitcount;
  1058.     { var reg3 uint_bitpack* ptr1 = &((uint_bitpack*)(&TheSbvector(array1)->data[0]))[index1/bitpack];
  1059.       var reg4 uint_bitpack* ptr2 = &((uint_bitpack*)(&TheSbvector(array2)->data[0]))[index2/bitpack];
  1060.       # ptr1 zeigt auf das erste teilnehmende Word des 1. Bit-Arrays.
  1061.       # ptr2 zeigt auf das erste teilnehmende Word des 2. Bit-Arrays.
  1062.       var reg7 uintL bitpackcount = bitcount / bitpack;
  1063.       # bitpackcount = Anzahl der ganzen Words
  1064.       var uintL bitcount_rest = bitcount % bitpack;
  1065.       # bitcount_rest = Anzahl der übrigbleibenden Bits
  1066.       index1 = index1 % bitpack; # Bit-Offset im 1. Bit-Array
  1067.       index2 = index2 % bitpack; # Bit-Offset im 2. Bit-Array
  1068.       if ((index1==0) && (index2==0))
  1069.         # einfache Schleife, da alle Bit-Offsets im Word =0 sind:
  1070.         { dotimesL(bitpackcount,bitpackcount,
  1071.             { if (!(*ptr1++ == *ptr2++)) { return FALSE; } }
  1072.             );
  1073.           # bitcount_rest = Anzahl der noch vergleichenden Bits
  1074.           if (!(bitcount_rest==0))
  1075.             # letztes Word vergleichen:
  1076.             { if (!(( (*ptr1 ^ *ptr2)
  1077.                       & # Bitmaske mit Bits bitpack-1..bitpack-bitcount_rest gesetzt
  1078.                         ~( (uint_bitpack)(bitm(bitpack)-1) >> bitcount_rest)
  1079.                     ) ==0
  1080.                  ) )
  1081.                 { return FALSE; }
  1082.             }
  1083.           return TRUE;
  1084.         }
  1085.         else
  1086.         # kompliziertere Schleife:
  1087.         { var reg1 uint_2bitpack carry1 = LR_bitpack_0((*ptr1++) << index1);
  1088.           # carry1 hat in seinen oberen bitpack-index1 Bits (Bits 2*bitpack-1..bitpack+index1)
  1089.           # die betroffenen Bits des 1. Words des 1. Arrays, sonst Nullen.
  1090.           var reg2 uint_2bitpack carry2 = LR_bitpack_0((*ptr2++) << index2);
  1091.           # carry2 hat in seinen oberen bitpack-index2 Bits (Bits 2*bitpack-1..bitpack+index2)
  1092.           # die betroffenen Bits des 1. Words des 2. Arrays, sonst Nullen.
  1093.           dotimesL(bitpackcount,bitpackcount,
  1094.             { # Vergleichsschleife (jeweils wortweise):
  1095.               # Nach n>=0 Schleifendurchläufen ist
  1096.               # ptr1 und ptr2 um n+1 Words weitergerückt, also Pointer aufs
  1097.               # nächste zu lesende Word des 1. bzw. 2. Arrays,
  1098.               # bitpackcount = Zahl zu verknüpfender ganzer Words - n,
  1099.               # carry1 = Übertrag vom 1. Array
  1100.               #          (in den bitpack-index1 oberen Bits, sonst Null),
  1101.               # carry2 = Übertrag vom 2. Array
  1102.               #          (in den bitpack-index2 oberen Bits, sonst Null).
  1103.               if (!(
  1104.                     ( carry1 |=
  1105.                         LR_0_bitpack(*ptr1++) # nächstes Word des 1. Arrays lesen
  1106.                         << index1, # zum carry1 dazunehmen
  1107.                       L_bitpack(carry1) # und davon das linke Word verwenden
  1108.                     )
  1109.                     ==
  1110.                     ( carry2 |=
  1111.                         LR_0_bitpack(*ptr2++) # nächstes Word des 2. Arrays lesen
  1112.                         << index2, # zum carry2 dazunehmen
  1113.                       L_bitpack(carry2) # und davon das linke Word verwenden
  1114.                     )
  1115.                  ) )
  1116.                 { return FALSE; }
  1117.               carry1 = LR_bitpack_0(R_bitpack(carry1)); # carry1 := rechtes Word von carry1
  1118.               carry2 = LR_bitpack_0(R_bitpack(carry2)); # carry2 := rechtes Word von carry2
  1119.             });
  1120.           # Noch bitcount_rest Bits zu vergleichen:
  1121.           if (!(bitcount_rest==0))
  1122.             # letztes Word vergleichen:
  1123.             { if (!(( (
  1124.                        ( carry1 |=
  1125.                            LR_0_bitpack(*ptr1++) # nächstes Word des 1. Arrays lesen
  1126.                            << index1, # zum carry1 dazunehmen
  1127.                          L_bitpack(carry1) # und davon das linke Word verwenden
  1128.                        )
  1129.                        ^
  1130.                        ( carry2 |=
  1131.                            LR_0_bitpack(*ptr2++) # nächstes Word des 2. Arrays lesen
  1132.                            << index2, # zum carry2 dazunehmen
  1133.                          L_bitpack(carry2) # und davon das linke Word verwenden
  1134.                        )
  1135.                       )
  1136.                       & # Bitmaske mit Bits bitpack-1..bitpack-bitcount_rest gesetzt
  1137.                         ~( (uint_bitpack)(bitm(bitpack)-1) >> bitcount_rest)
  1138.                     ) ==0
  1139.                  ) )
  1140.                 { return FALSE; }
  1141.             }
  1142.           return TRUE;
  1143.         }
  1144.     }
  1145.  
  1146. # Unterprogramm für Bitvektor-Operationen:
  1147. # bit_op(array1,index1,array2,index2,array3,index3,op,count);
  1148. # > array1: erster Bit-Array,
  1149. # > index1: absoluter Index in array1
  1150. # > array2: zweiter Bit-Array,
  1151. # > index2: absoluter Index in array2
  1152. # > array3: dritter Bit-Array,
  1153. # > index3: absoluter Index in array3
  1154. # > op: Adresse der Operationsroutine
  1155. # > count: Anzahl der zu verknüpfenden Bits
  1156.   # bit_op_fun ist eine Funktion, die zwei bitpack-Bit-Wörter verknüpft:
  1157.   typedef uint_bitpack bit_op_fun (uint_bitpack x, uint_bitpack y);
  1158.   local void bit_op (object array1, uintL index1,
  1159.                      object array2, uintL index2,
  1160.                      object array3, uintL index3,
  1161.                      bit_op_fun* op, uintL bitcount);
  1162.   local void bit_op(array1,index1,array2,index2,array3,index3,op,bitcount)
  1163.     var object array1;
  1164.     var reg2 uintL index1;
  1165.     var object array2;
  1166.     var reg2 uintL index2;
  1167.     var object array3;
  1168.     var reg2 uintL index3;
  1169.     var reg3 bit_op_fun* op;
  1170.     var uintL bitcount;
  1171.     { var reg1 uint_bitpack* ptr1 = &((uint_bitpack*)(&TheSbvector(array1)->data[0]))[index1/bitpack];
  1172.       var reg1 uint_bitpack* ptr2 = &((uint_bitpack*)(&TheSbvector(array2)->data[0]))[index2/bitpack];
  1173.       var reg1 uint_bitpack* ptr3 = &((uint_bitpack*)(&TheSbvector(array3)->data[0]))[index3/bitpack];
  1174.       # ptr1 zeigt auf das erste teilnehmende Word des 1. Bit-Arrays.
  1175.       # ptr2 zeigt auf das erste teilnehmende Word des 2. Bit-Arrays.
  1176.       # ptr3 zeigt auf das erste teilnehmende Word des 3. Bit-Arrays.
  1177.       var reg3 uintL bitpackcount = bitcount / bitpack;
  1178.       # bitpackcount = Anzahl der ganzen Words
  1179.       var uintL bitcount_rest = bitcount % bitpack;
  1180.       # bitcount_rest = Anzahl der übrigbleibenden Bits
  1181.       index1 = index1 % bitpack; # Bit-Offset im 1. Bit-Array
  1182.       index2 = index2 % bitpack; # Bit-Offset im 2. Bit-Array
  1183.       index3 = index3 % bitpack; # Bit-Offset im 3. Bit-Array
  1184.       if ((index1==0) && (index2==0) && (index3==0))
  1185.         # einfache Schleife, da alle Bit-Offsets im Word =0 sind:
  1186.         { dotimesL(bitpackcount,bitpackcount,
  1187.             { *ptr3++ = (*op)(*ptr1++,*ptr2++); }
  1188.             );
  1189.           # bitcount_rest = Anzahl der noch abzulegenden Bits
  1190.           if (!(bitcount_rest==0))
  1191.             # letztes Word ablegen:
  1192.             { var reg1 uint_bitpack temp = (*op)(*ptr1,*ptr2);
  1193.               *ptr3 =
  1194.                 ( ~
  1195.                     ( (uint_bitpack)(bitm(bitpack)-1) >> bitcount_rest)
  1196.                     # Bitmaske mit Bits bitpack-bitcount_rest-1..0 gesetzt
  1197.                   # Bitmaske mit Bits bitpack-1..bitpack-bitcount_rest gesetzt
  1198.                  &
  1199.                  (*ptr3 ^ temp)
  1200.                 ) # zu ändernde Bits
  1201.                 ^ *ptr3
  1202.                 ;
  1203.         }   }
  1204.         else
  1205.         # kompliziertere Schleife:
  1206.         { var reg1 uint_2bitpack carry1 = LR_bitpack_0((*ptr1++) << index1);
  1207.           # carry1 hat in seinen oberen bitpack-index1 Bits (Bits 2*bitpack-1..bitpack+index1)
  1208.           # die betroffenen Bits des 1. Words des 1. Arrays, sonst Nullen.
  1209.           var reg1 uint_2bitpack carry2 = LR_bitpack_0((*ptr2++) << index2);
  1210.           # carry2 hat in seinen oberen bitpack-index2 Bits (Bits 2*bitpack-1..bitpack+index2)
  1211.           # die betroffenen Bits des 1. Words des 2. Arrays, sonst Nullen.
  1212.           var reg1 uint_2bitpack carry3 =
  1213.             LR_bitpack_0(
  1214.                          (~
  1215.                             ( (uint_bitpack)(bitm(bitpack)-1) >> index3)
  1216.                             # Bitmaske mit Bits bitpack-index3-1..0 gesetzt
  1217.                          ) # Bitmaske mit Bits bitpack-1..bitpack-index3 gesetzt
  1218.                          & (*ptr3)
  1219.                         );
  1220.           # carry3 hat in seinen obersten index3 Bits (Bits 2*bitpack-1..2*bitpack-index3)
  1221.           # genau die Bits von *ptr3, die nicht verändert werden dürfen.
  1222.           loop
  1223.             { # Verknüpfungsschleife (jeweils wortweise):
  1224.               # Nach n>=0 Schleifendurchläufen ist
  1225.               # ptr1 und ptr2 um n+1 Words weitergerückt, also Pointer aufs
  1226.               # nächste zu lesende Word des 1. bzw. 2. Arrays,
  1227.               # ptr3 um n Words weitergerückt, also Pointer aufs
  1228.               # nächste zu schreibende Word des 3. Arrays,
  1229.               # bitpackcount = Zahl zu verknüpfender ganzer Words - n,
  1230.               # carry1 = Übertrag vom 1. Array
  1231.               #          (in den bitpack-index1 oberen Bits, sonst Null),
  1232.               # carry2 = Übertrag vom 2. Array
  1233.               #          (in den bitpack-index2 oberen Bits, sonst Null),
  1234.               # carry3 = Übertrag noch abzuspeichernder Bits
  1235.               #          (in den index3 oberen Bits, sonst Null).
  1236.               var reg1 uint_bitpack temp =
  1237.                 (*op)(
  1238.                       ( carry1 |=
  1239.                           LR_0_bitpack(*ptr1++) # nächstes Word des 1. Arrays lesen
  1240.                           << index1, # zum carry1 dazunehmen
  1241.                         L_bitpack(carry1) # und davon das linke Word verwenden
  1242.                       ),
  1243.                       ( carry2 |=
  1244.                           LR_0_bitpack(*ptr2++) # nächstes Word des 2. Arrays lesen
  1245.                           << index2, # zum carry2 dazunehmen
  1246.                         L_bitpack(carry2) # und davon das linke Word verwenden
  1247.                       )
  1248.                      ) ; # beide durch *op verknüpfen
  1249.               carry1 = LR_bitpack_0(R_bitpack(carry1)); # carry1 := rechtes Word von carry1
  1250.               carry2 = LR_bitpack_0(R_bitpack(carry2)); # carry2 := rechtes Word von carry2
  1251.               carry3 |= LR_bitpack_0(temp) >> index3;
  1252.               # Die oberen bitpack+index3 Bits von carry3 sind abzulegen.
  1253.               if (bitpackcount==0) break;
  1254.               *ptr3++ = L_bitpack(carry3); # bitpack Bits davon ablegen
  1255.               carry3 = LR_bitpack_0(R_bitpack(carry3)); # und index3 Bits für später behalten.
  1256.               bitpackcount--;
  1257.             }
  1258.           # letztes (halbes) Datenword speziell behandeln:
  1259.           # Vom letzten Word (nun in den Bits
  1260.           # 2*bitpack-index3-1..bitpack-index3 von carry3)
  1261.           # dürfen nur bitcount_rest Bits im 3. Array abgelegt werden.
  1262.           { var reg4 uint_bitpack last_carry;
  1263.             bitcount_rest = index3+bitcount_rest;
  1264.             # Die oberen bitcount_rest Bits ablegen:
  1265.             if (bitcount_rest>=bitpack)
  1266.               { *ptr3++ = L_bitpack(carry3);
  1267.                 last_carry = R_bitpack(carry3);
  1268.                 bitcount_rest -= bitpack;
  1269.               }
  1270.               else
  1271.               { last_carry = L_bitpack(carry3); }
  1272.             # Die noch übrigen bitcount_rest Bits von last_carry ablegen:
  1273.             if (!(bitcount_rest==0))
  1274.               *ptr3 ^=
  1275.                 (*ptr3 ^ last_carry)
  1276.                 & (~( (uint_bitpack)(bitm(bitpack)-1) >> bitcount_rest ));
  1277.                   # Bitmaske, in der die oberen bitcount_rest Bits gesetzt sind
  1278.         } }
  1279.     }
  1280.  
  1281. # Unterprogramm für Bit-Verknüpfung mit 2 Operanden
  1282. # bit_up(op)
  1283. # > STACK_2: bit-array1
  1284. # > STACK_1: bit-array2
  1285. # > STACK_0: result-bit-array oder #<UNBOUND>
  1286. # > op: Adresse der Verknüpfungsroutine
  1287. # < value1/mv_count: Funktionswert
  1288. # Testet Argumente, räumt STACK auf.
  1289.   local Values bit_up (bit_op_fun* op);
  1290.   local Values bit_up(op)
  1291.     var reg4 bit_op_fun* op;
  1292.     { # Hauptunterscheidung: Vektor / mehrdimensionaler Array
  1293.       var reg2 uintL len; # Länge (des 1. Arrays), falls Vektoren
  1294.       var reg2 uintC rank; # Rang und
  1295.       var reg2 uintL* dimptr; # Pointer auf Dimensionen, falls mehrdimensional
  1296.       # Typ von bit-array1 untersuchen und danach verzweigen:
  1297.       switch (mtypecode(STACK_2))
  1298.         { case_sbvector:
  1299.             len = TheSbvector(STACK_2)->length; goto vector;
  1300.           case_obvector:
  1301.             { var reg1 Array array1 = TheArray(STACK_2);
  1302.               # bit-array1 muß den Elementtyp BIT haben:
  1303.               if (!((array1->flags & arrayflags_atype_mask) == Atype_Bit))
  1304.                 goto fehler2;
  1305.               len = array1->totalsize;
  1306.               goto vector;
  1307.             }
  1308.           case_array1:
  1309.             { var reg1 Array array1 = TheArray(STACK_2);
  1310.               # bit-array1 muß den Elementtyp BIT haben:
  1311.               if (!((array1->flags & arrayflags_atype_mask) == Atype_Bit))
  1312.                 goto fehler2;
  1313.               # Rang merken:
  1314.               rank = array1->rank;
  1315.               # Dimensionen merken:
  1316.               dimptr = &array1->dims[0];
  1317.               if (array1->flags & bit(arrayflags_dispoffset_bit))
  1318.                 dimptr++;
  1319.               # die Anzahl der zu verknüpfenden Bits ist die Totalsize:
  1320.               len = array1->totalsize;
  1321.               goto array;
  1322.             }
  1323.           default:
  1324.             goto fehler2;
  1325.         }
  1326.       vector: # Das erste Argument ist ein Bit-Vektor, mit Länge len.
  1327.         # Teste, ob dies auch auf den/die anderen zutrifft:
  1328.         # bit-array2 überprüfen:
  1329.         switch (mtypecode(STACK_1))
  1330.           { case_sbvector:
  1331.               if (!(len == TheSbvector(STACK_1)->length)) goto fehler2;
  1332.               break;
  1333.             case_obvector:
  1334.               { var reg1 Array array2 = TheArray(STACK_1);
  1335.                 # bit-array2 muß den Elementtyp BIT haben:
  1336.                 if (!((array2->flags & arrayflags_atype_mask) == Atype_Bit))
  1337.                   goto fehler2;
  1338.                 if (!(len == array2->totalsize)) goto fehler2;
  1339.               }
  1340.               break;
  1341.             default:
  1342.               goto fehler2;
  1343.           }
  1344.         # bit-array3 überprüfen:
  1345.         {var reg1 object array3 = STACK_0;
  1346.          if (eq(array3,unbound) || eq(array3,NIL)) # nicht angegeben oder NIL?
  1347.            # ja -> neuen Vektor erzeugen:
  1348.            { STACK_0 = allocate_bit_vector(len); }
  1349.            else
  1350.            if (eq(array3,T))
  1351.              { STACK_0 = STACK_2; } # statt T verwende bit-array1
  1352.              else
  1353.              switch (mtypecode(STACK_0))
  1354.                { case_sbvector:
  1355.                    if (!(len == TheSbvector(array3)->length)) goto fehler3;
  1356.                    break;
  1357.                  case_obvector:
  1358.                    # bit-array3 muß den Elementtyp BIT haben:
  1359.                    if (!((TheArray(array3)->flags & arrayflags_atype_mask) == Atype_Bit))
  1360.                      goto fehler3;
  1361.                    if (!(len == TheArray(array3)->totalsize)) goto fehler3;
  1362.                    break;
  1363.                  default:
  1364.                    goto fehler3;
  1365.                }
  1366.         }
  1367.         goto weiter;
  1368.       array: # erstes Argument war ein mehrdimensionaler Bit-Array
  1369.         # mit Rang rank, Dimensionen ab dimptr und Totalsize len.
  1370.         # bit-array2 überprüfen:
  1371.         switch (mtypecode(STACK_1))
  1372.           { case_array1:
  1373.               { var reg1 Array array2 = TheArray(STACK_1);
  1374.                 # bit-array2 muß den Elementtyp BIT haben:
  1375.                 if (!((array2->flags & arrayflags_atype_mask) == Atype_Bit))
  1376.                   goto fehler2;
  1377.                 # Rang vergleichen:
  1378.                 if (!(rank == array2->rank)) goto fehler2;
  1379.                 # Dimensionen vergleichen:
  1380.                 { var reg3 uintC count;
  1381.                   var reg1 uintL* dimptr1 = dimptr;
  1382.                   var reg2 uintL* dimptr2;
  1383.                   dimptr2 = &array2->dims[0];
  1384.                   if (array2->flags & bit(arrayflags_dispoffset_bit))
  1385.                     dimptr2++;
  1386.                   dotimesC(count,rank, { if (!(*dimptr1++==*dimptr2++)) goto fehler2; });
  1387.                 }
  1388.                 break;
  1389.               }
  1390.             default:
  1391.               goto fehler2;
  1392.           }
  1393.         # bit-array3 überprüfen:
  1394.         {var reg1 object array3 = STACK_0;
  1395.          if (eq(array3,unbound) || eq(array3,NIL)) # nicht angegeben oder NIL?
  1396.            # ja -> neuen Array erzeugen:
  1397.            { STACK_0 = allocate_bit_vector(len); # Bitvektor erzeugen
  1398.              array3 = allocate_array(bit(arrayflags_notbytep_bit)|Atype_Bit,rank,array_type); # Array erzeugen
  1399.              TheArray(array3)->data = STACK_0; # Datenvektor eintragen
  1400.              # Dimensionen eintragen:
  1401.              { var reg3 uintC count;
  1402.                var reg1 uintL* dimptr1 = dimptr;
  1403.                var reg2 uintL* dimptr2 = &TheArray(array3)->dims[0];
  1404.                dotimesC(count,rank, { *dimptr1++ = *dimptr2++; });
  1405.              }
  1406.              STACK_0 = array3; # neuen Array ablegen
  1407.            }
  1408.            else
  1409.            if (eq(array3,T))
  1410.              { STACK_0 = STACK_2; } # statt T verwende bit-array1
  1411.              else
  1412.              switch (mtypecode(STACK_0))
  1413.                { case_array1:
  1414.                    { var reg1 Array array3 = TheArray(STACK_0);
  1415.                      # bit-array3 muß den Elementtyp BIT haben:
  1416.                      if (!((array3->flags & arrayflags_atype_mask) == Atype_Bit))
  1417.                        goto fehler3;
  1418.                      # Rang vergleichen:
  1419.                      if (!(rank == array3->rank)) goto fehler3;
  1420.                      # Dimensionen vergleichen:
  1421.                      { var reg3 uintC count;
  1422.                        var reg1 uintL* dimptr1 = dimptr;
  1423.                        var reg2 uintL* dimptr2;
  1424.                        dimptr2 = &array3->dims[0];
  1425.                        if (array3->flags & bit(arrayflags_dispoffset_bit))
  1426.                          dimptr2++;
  1427.                        dotimesC(count,rank, { if (!(*dimptr1++==*dimptr2++)) goto fehler3; });
  1428.                      }
  1429.                      break;
  1430.                    }
  1431.                  default:
  1432.                    goto fehler3;
  1433.                }
  1434.         }
  1435.       weiter: # Vorbereitungen sind abgeschlossen:
  1436.         # STACK_2 = bit-array1, STACK_1 = bit-array2, STACK_0 = bit-array3,
  1437.         # alle von denselben Dimensionen, mit je len Bits.
  1438.         { var uintL index1 = 0; # Index in Datenvektor von bit-array1
  1439.           var object array1 = # Datenvektor von bit-array1
  1440.                               (m_simple_bit_vector_p(STACK_2)
  1441.                                 ? STACK_2
  1442.                                 : array1_displace_check(STACK_2,len,&index1)
  1443.                               );
  1444.           var uintL index2 = 0; # Index in Datenvektor von bit-array2
  1445.           var object array2 = # Datenvektor von bit-array2
  1446.                               (m_simple_bit_vector_p(STACK_1)
  1447.                                 ? STACK_1
  1448.                                 : array1_displace_check(STACK_1,len,&index2)
  1449.                               );
  1450.           var uintL index3 = 0; # Index in Datenvektor von bit-array3
  1451.           var object array3 = # Datenvektor von bit-array3
  1452.                               (m_simple_bit_vector_p(STACK_0)
  1453.                                 ? STACK_0
  1454.                                 : array1_displace_check(STACK_0,len,&index3)
  1455.                               );
  1456.           # Los geht's:
  1457.           bit_op(array1,index1,array2,index2,array3,index3,op,len);
  1458.         }
  1459.         # Fertig:
  1460.         value1 = popSTACK(); mv_count=1; # bit-array3 ist das Ergebnis
  1461.         skipSTACK(2);
  1462.         return;
  1463.       fehler2: # Fehlermeldung bei (mindestens) 2 Argumenten
  1464.         { var reg1 object array1 = STACK_2;
  1465.           var reg2 object array2 = STACK_1;
  1466.           pushSTACK(array2); pushSTACK(array1);
  1467.           pushSTACK(TheSubr(subr_self)->name);
  1468.           //: DEUTSCH "~: Die Argumente ~ und ~ müssen Bit-Arrays gleicher Dimensionierung sein."
  1469.           //: ENGLISH "~: The arguments ~ and ~ should be arrays of bits with the same dimensions"
  1470.           //: FRANCAIS "~: Les arguments ~ et ~ doivent être des matrices de mêmes dimensions."
  1471.           fehler(error,GETTEXT("~: The arguments ~ and ~ should be arrays of bits with the same dimensions"));
  1472.         }
  1473.       fehler3: # Fehlermeldung bei 3 Argumenten
  1474.         { var reg1 object array1 = STACK_2;
  1475.           var reg2 object array2 = STACK_1;
  1476.           # array3 bereits in STACK_0
  1477.           pushSTACK(array2); pushSTACK(array1);
  1478.           pushSTACK(TheSubr(subr_self)->name);
  1479.           //: DEUTSCH "~: Die Argumente ~, ~ und ~ müssen Bit-Arrays gleicher Dimensionierung sein."
  1480.           //: ENGLISH "~: The arguments ~, ~ and ~ should be arrays of bits with the same dimensions"
  1481.           //: FRANCAIS "~: Les arguments ~, ~ et ~ doivent être des matrices de mêmes dimensions."
  1482.           fehler(error,GETTEXT("~: The arguments ~, ~ and ~ should be arrays of bits with the same dimensions"));
  1483.         }
  1484.     }
  1485.  
  1486. # Die einzelnen Operatoren für BIT-AND usw.:
  1487.   local uint_bitpack bitpack_and (uint_bitpack x, uint_bitpack y);
  1488.   local uint_bitpack bitpack_and(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1489.     { return x&y; }
  1490.   local uint_bitpack bitpack_ior (uint_bitpack x, uint_bitpack y);
  1491.   local uint_bitpack bitpack_ior(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1492.     { return x|y; }
  1493.   local uint_bitpack bitpack_xor (uint_bitpack x, uint_bitpack y);
  1494.   local uint_bitpack bitpack_xor(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1495.     { return x^y; }
  1496.   local uint_bitpack bitpack_eqv (uint_bitpack x, uint_bitpack y);
  1497.   local uint_bitpack bitpack_eqv(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1498.     { return ~(x^y); }
  1499.   local uint_bitpack bitpack_nand (uint_bitpack x, uint_bitpack y);
  1500.   local uint_bitpack bitpack_nand(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1501.     { return ~(x&y); }
  1502.   local uint_bitpack bitpack_nor (uint_bitpack x, uint_bitpack y);
  1503.   local uint_bitpack bitpack_nor(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1504.     { return ~(x|y); }
  1505.   local uint_bitpack bitpack_andc1 (uint_bitpack x, uint_bitpack y);
  1506.   local uint_bitpack bitpack_andc1(x,y) var reg2 uint_bitpack x; var reg1 uint_bitpack y;
  1507.     { return (~x)&y; }
  1508.   local uint_bitpack bitpack_andc2 (uint_bitpack x, uint_bitpack y);
  1509.   local uint_bitpack bitpack_andc2(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1510.     { return x&(~y); }
  1511.   local uint_bitpack bitpack_orc1 (uint_bitpack x, uint_bitpack y);
  1512.   local uint_bitpack bitpack_orc1(x,y) var reg2 uint_bitpack x; var reg1 uint_bitpack y;
  1513.     { return (~x)|y; }
  1514.   local uint_bitpack bitpack_orc2 (uint_bitpack x, uint_bitpack y);
  1515.   local uint_bitpack bitpack_orc2(x,y) var reg1 uint_bitpack x; var reg2 uint_bitpack y;
  1516.     { return x|(~y); }
  1517.   local uint_bitpack bitpack_not (uint_bitpack x, uint_bitpack y);
  1518.   local uint_bitpack bitpack_not(x,y) var reg1 uint_bitpack x; var uint_bitpack y;
  1519.     { return ~x; }
  1520.  
  1521. LISPFUN(bit_and,2,1,norest,nokey,0,NIL)
  1522. # (BIT-AND bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1523.   { return_Values bit_up(&bitpack_and); }
  1524.  
  1525. LISPFUN(bit_ior,2,1,norest,nokey,0,NIL)
  1526. # (BIT-IOR bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1527.   { return_Values bit_up(&bitpack_ior); }
  1528.  
  1529. LISPFUN(bit_xor,2,1,norest,nokey,0,NIL)
  1530. # (BIT-XOR bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1531.   { return_Values bit_up(&bitpack_xor); }
  1532.  
  1533. LISPFUN(bit_eqv,2,1,norest,nokey,0,NIL)
  1534. # (BIT-EQV bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1535.   { return_Values bit_up(&bitpack_eqv); }
  1536.  
  1537. LISPFUN(bit_nand,2,1,norest,nokey,0,NIL)
  1538. # (BIT-NAND bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1539.   { return_Values bit_up(&bitpack_nand); }
  1540.  
  1541. LISPFUN(bit_nor,2,1,norest,nokey,0,NIL)
  1542. # (BIT-NOR bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1543.   { return_Values bit_up(&bitpack_nor); }
  1544.  
  1545. LISPFUN(bit_andc1,2,1,norest,nokey,0,NIL)
  1546. # (BIT-ANDC1 bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1547.   { return_Values bit_up(&bitpack_andc1); }
  1548.  
  1549. LISPFUN(bit_andc2,2,1,norest,nokey,0,NIL)
  1550. # (BIT-ANDC2 bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1551.   { return_Values bit_up(&bitpack_andc2); }
  1552.  
  1553. LISPFUN(bit_orc1,2,1,norest,nokey,0,NIL)
  1554. # (BIT-ORC1 bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1555.   { return_Values bit_up(&bitpack_orc1); }
  1556.  
  1557. LISPFUN(bit_orc2,2,1,norest,nokey,0,NIL)
  1558. # (BIT-ORC2 bit-array1 bit-array2 [result-bit-array]), CLTL S. 294
  1559.   { return_Values bit_up(&bitpack_orc2); }
  1560.  
  1561. LISPFUN(bit_not,1,1,norest,nokey,0,NIL)
  1562. # (BIT-NOT bit-array [result-bit-array]), CLTL S. 295
  1563.   { # erstes Argument verdoppeln (wird bei der Operation ignoriert):
  1564.     {var reg1 object array3 = STACK_0; pushSTACK(array3); }
  1565.     STACK_1 = STACK_2;
  1566.     return_Values bit_up(&bitpack_not);
  1567.   }
  1568.  
  1569. # UP: Testet, ob ein Array einen Fill-Pointer hat.
  1570. # array_has_fill_pointer_p(array)
  1571. # > array: ein Array
  1572. # < TRUE, falls ja; FALSE falls nein.
  1573.   global boolean array_has_fill_pointer_p (object array);
  1574.   global boolean array_has_fill_pointer_p(array)
  1575.     var reg1 object array;
  1576.     { if_simplep(array,
  1577.         { return FALSE; },
  1578.         { if (TheArray(array)->flags & bit(arrayflags_fillp_bit))
  1579.             return TRUE;
  1580.             else
  1581.             return FALSE;
  1582.         });
  1583.     }
  1584.  
  1585. LISPFUNN(array_has_fill_pointer_p,1) # (ARRAY-HAS-FILL-POINTER-P array), CLTL S. 296
  1586.   { var reg1 object array = popSTACK();
  1587.     test_array(array);
  1588.     value1 = (array_has_fill_pointer_p(array) ? T : NIL); mv_count=1;
  1589.   }
  1590.  
  1591. # Überprüft, ob ein Objekt ein Vektor mit Fill-Pointer ist, und liefert
  1592. # die Adresse des Fill-Pointers.
  1593. # *get_fill_pointer(obj) ist dann der Fill-Pointer selbst.
  1594. # get_fill_pointer(obj)[-1] ist dann die Länge (Dimension 0) des Vektors.
  1595. # > subr_self: Aufrufer (ein SUBR)
  1596.   local uintL* get_fill_pointer (object obj);
  1597.   local uintL* get_fill_pointer(obj)
  1598.     var reg2 object obj;
  1599.     { # obj muß ein Vektor sein:
  1600.       if_vectorp(obj, ; , { fehler_vector(obj); });
  1601.       # darf nicht simple sein:
  1602.       if_simplep(obj, { goto fehler_fillp; } , ; );
  1603.       # muß einen Fill-Pointer enthalten:
  1604.       if (!(TheArray(obj)->flags & bit(arrayflags_fillp_bit))) { goto fehler_fillp; }
  1605.       # Wo steht der Fill-Pointer?
  1606.       return ((TheArray(obj)->flags & bit(arrayflags_dispoffset_bit))
  1607.               ? &TheArray(obj)->dims[2] # nach Displaced-Offset und Dimension 0
  1608.               : &TheArray(obj)->dims[1] # nach der Dimension 0
  1609.              );
  1610.       # Fehlermeldung:
  1611.       fehler_fillp:
  1612.         pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  1613.         //: DEUTSCH "~: Vektor ~ hat keinen Fill-Pointer."
  1614.         //: ENGLISH "~: vector ~ has no fill pointer"
  1615.         //: FRANCAIS "~: Le vecteur ~ n'a pas de pointeur de remplissage."
  1616.         fehler(error,GETTEXT("~: vector ~ has no fill pointer"));
  1617.     }
  1618.  
  1619. LISPFUNN(fill_pointer,1) # (FILL-POINTER vector), CLTL S. 296
  1620.   { var reg1 object obj = popSTACK();
  1621.     value1 = fixnum(* get_fill_pointer(obj)); # Fill-Pointer holen, als Fixnum
  1622.     mv_count=1;
  1623.   }
  1624.  
  1625. LISPFUNN(set_fill_pointer,2) # (SYS::SET-FILL-POINTER vector index)
  1626.                              # = (SETF (FILL-POINTER vector) index), CLTL S. 296
  1627.   { var reg1 uintL* fillp = get_fill_pointer(STACK_1); # Fillpointer-Adresse
  1628.     if (!mposfixnump(STACK_0)) # neuer Fill-Pointer muß Fixnum>=0 sein.
  1629.       fehler_index_type();
  1630.    {var reg1 uintL newfillp = posfixnum_to_L(STACK_0); # als uintL
  1631.     if (!(newfillp <= fillp[-1])) # muß kleinergleich der Länge sein
  1632.       fehler_index_range();
  1633.     *fillp = newfillp; # neuen Fill-Pointer eintragen
  1634.     value1 = STACK_0; mv_count=1; # neuen Fillpointer zurück
  1635.     skipSTACK(2);
  1636.   }}
  1637.  
  1638. LISPFUNN(vector_push,2) # (VECTOR-PUSH new-element vector), CLTL S. 296
  1639.   { var reg1 uintL* fillp = get_fill_pointer(STACK_0); # Fillpointer-Adresse
  1640.     var reg2 uintL oldfillp = *fillp; # alter Wert des Fillpointers
  1641.     if (oldfillp >= fillp[-1]) # Fill-Pointer am Ende?
  1642.       { value1 = NIL; mv_count=1; } # NIL zurück
  1643.       else
  1644.       { var uintL index = oldfillp;
  1645.         var reg4 object datenvektor = notsimple_displace(STACK_0,&index);
  1646.         datenvektor_store(datenvektor,index,STACK_1); # new-element eintragen
  1647.         (*fillp)++; # Fill-Pointer erhöhen
  1648.         value1 = fixnum(oldfillp); mv_count=1;
  1649.         # alter Fill-Pointer als Wert
  1650.       }
  1651.     skipSTACK(2);
  1652.   }
  1653.  
  1654. LISPFUNN(vector_pop,1) # (VECTOR-POP vector), CLTL S. 296
  1655.   { var reg2 object array = popSTACK();
  1656.     var reg1 uintL* fillp = get_fill_pointer(array);
  1657.     if (*fillp==0)
  1658.       { # Fill-Pointer war =0 -> Fehlermeldung
  1659.         pushSTACK(array); pushSTACK(TheSubr(subr_self)->name);
  1660.         //: DEUTSCH "~: ~ hat keine aktiven Elemente."
  1661.         //: ENGLISH "~: ~ has length zero"
  1662.         //: FRANCAIS "~: ~ ne contient pas d'éléments actifs (la longueur est nulle)."
  1663.         fehler(error,GETTEXT("~: ~ has length zero"));
  1664.       }
  1665.       else
  1666.       { var uintL index = --(*fillp); # Fill-Pointer erniedrigen
  1667.         var reg4 object datenvektor = notsimple_displace(array,&index);
  1668.         value1 = datenvektor_aref(datenvektor,index); mv_count=1; # Element zurück
  1669.       }
  1670.   }
  1671.  
  1672. LISPFUN(vector_push_extend,2,1,norest,nokey,0,NIL)
  1673. # (VECTOR-PUSH-EXTEND new-element vector [extension]), CLTL S. 296
  1674.   { var reg3 object extension = popSTACK(); # Extension (ungeprüft)
  1675.     var reg1 uintL* fillp = get_fill_pointer(STACK_0); # Fillpointer-Adresse
  1676.     var reg2 uintL oldfillp = *fillp; # alter Wert des Fillpointers
  1677.     if (oldfillp < fillp[-1]) # Fill-Pointer noch nicht am Ende?
  1678.       { var uintL index = oldfillp;
  1679.         var reg4 object datenvektor = notsimple_displace(STACK_0,&index);
  1680.         datenvektor_store(datenvektor,index,STACK_1); # new-element eintragen
  1681.         (*fillp)++; # Fill-Pointer erhöhen
  1682.       }
  1683.       else
  1684.       { # Fill-Pointer am Ende -> Versuche, den Vektor zu verlängern:
  1685.         var reg3 object array = STACK_0;
  1686.         if (!(TheArray(array)->flags & bit(arrayflags_adjustable_bit)))
  1687.           { # Vektor nicht adjustable -> Fehlermeldung:
  1688.             # array noch in STACK_0
  1689.             pushSTACK(TheSubr(subr_self)->name);
  1690.             //: DEUTSCH "~ funktioniert nur auf adjustierbaren Arrays, nicht auf ~"
  1691.             //: ENGLISH "~ works only on adjustable arrays, not on ~"
  1692.             //: FRANCAIS "~ ne fonctionne qu'avec des matrices ajustables et non avec ~."
  1693.             fehler(error,GETTEXT("~ works only on adjustable arrays, not on ~"));
  1694.           }
  1695.         { var reg3 uintB atype = TheArray(array)->flags & arrayflags_atype_mask;
  1696.           var uintL len = fillp[-1]; # bisherige Länge (Dimension 0)
  1697.           var reg5 uintL inc; # gewünschter Increment der Länge
  1698.           if (!eq(extension,unbound))
  1699.             { # extension sollte ein Fixnum >0, <arraysize_limit sein:
  1700.               if ( (!(posfixnump(extension)))
  1701.                    || ((inc = posfixnum_to_L(extension)) == 0)
  1702.                    #ifndef UNIX_DEC_ULTRIX_GCCBUG
  1703.                    || (inc > arraysize_limit_1)
  1704.                    #endif
  1705.                  )
  1706.                 { pushSTACK(extension); # Wert für Slot DATUM von TYPE-ERROR
  1707.                   pushSTACK(O(type_posfixnum1)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1708.                   pushSTACK(extension); pushSTACK(TheSubr(subr_self)->name);
  1709.                   //: DEUTSCH "~: Extension ~ sollte ein Fixnum > 0 sein."
  1710.                   //: ENGLISH "~: extension ~ should be a positive fixnum"
  1711.                   //: FRANCAIS "~: L'extension ~ doit être de type FIXNUM strictement positif."
  1712.                   fehler(type_error,GETTEXT("~: extension ~ should be a positive fixnum"));
  1713.             }   }
  1714.             else
  1715.             { # Default-Verlängerung:
  1716.               switch (atype)
  1717.                 { case Atype_T:           inc =  16; break; # bei general-Vektoren: 16 Objekte
  1718.                   case Atype_String_Char: inc =  64; break; # bei Strings: 64 Zeichen
  1719.                   case Atype_Bit:         inc = 128; break; # bei Bit-Vektoren: 128 Bits
  1720.                   case Atype_2Bit: case Atype_4Bit: case Atype_8Bit:
  1721.                   case Atype_16Bit: case Atype_32Bit: # bei Byte-Vektoren: entsprechend
  1722.                                           inc = bit(floor(14-atype,2)); break;
  1723.                   default: NOTREACHED
  1724.                 }
  1725.               # mindestens jedoch die bisherige Länge:
  1726.               if (inc<len) { inc = len; }
  1727.             }
  1728.           { var reg4 uintL newlen = len + inc; # neue Länge
  1729.             #ifndef UNIX_DEC_ULTRIX_GCCBUG
  1730.             if (newlen > arraysize_limit_1)
  1731.               { # Vektor würde zu lang -> Fehlermeldung
  1732.                 pushSTACK(extension); pushSTACK(TheSubr(subr_self)->name);
  1733.                 //: DEUTSCH "~: Durch die angegebene Extension von ~ wird der Vektor zu lang."
  1734.                 //: ENGLISH "~: extending the vector by ~ elements makes it too long"
  1735.                 //: FRANCAIS "~: Étendre le vecteur de ~ le rend trop long."
  1736.                 fehler(error,GETTEXT("~: extending the vector by ~ elements makes it too long"));
  1737.               }
  1738.             #endif
  1739.             { # Neuen Datenvektor holen. Dazu Fallunterscheidung je nach Typ:
  1740.               var reg2 object neuer_datenvektor;
  1741.               switch (atype)
  1742.                 { case Atype_T: # array ist ein General-Vector
  1743.                     neuer_datenvektor = allocate_vector(newlen);
  1744.                     array = STACK_0; # array wieder holen
  1745.                     { var reg1 object* ptr2 = &TheSvector(neuer_datenvektor)->data[0];
  1746.                       # alten in neuen Datenvektor kopieren:
  1747.                       if (len>0)
  1748.                         { var uintL index = 0;
  1749.                           var reg4 object datenvektor = array1_displace_check(array,len,&index);
  1750.                           var reg2 object* ptr1 = &TheSvector(datenvektor)->data[index];
  1751.                           var reg3 uintL count;
  1752.                           dotimespL(count,len, { *ptr2++ = *ptr1++; } );
  1753.                         }
  1754.                       # dann new_element anfügen:
  1755.                       *ptr2 = STACK_1;
  1756.                     }
  1757.                     break;
  1758.                   case Atype_String_Char: # array ist ein String
  1759.                     neuer_datenvektor = allocate_string(newlen);
  1760.                     array = STACK_0; # array wieder holen
  1761.                     { var reg1 uintB* ptr2 = &TheSstring(neuer_datenvektor)->data[0];
  1762.                       # alten in neuen Datenvektor kopieren:
  1763.                       if (len>0)
  1764.                         { var uintL index = 0;
  1765.                           var reg4 object datenvektor = array1_displace_check(array,len,&index);
  1766.                           var reg2 uintB* ptr1 = &TheSstring(datenvektor)->data[index];
  1767.                           var reg3 uintL count;
  1768.                           dotimespL(count,len, { *ptr2++ = *ptr1++; } );
  1769.                         }
  1770.                       # dann new_element anfügen:
  1771.                       if (!(string_char_p(STACK_1))) goto fehler_type;
  1772.                       *ptr2 = char_code(STACK_1);
  1773.                     }
  1774.                     break;
  1775.                   case Atype_Bit: # array ist ein Bit-Vektor
  1776.                   case Atype_2Bit: case Atype_4Bit: case Atype_8Bit:
  1777.                   case Atype_16Bit: case Atype_32Bit: # array ist ein Byte-Vektor
  1778.                     neuer_datenvektor = (atype==Atype_Bit
  1779.                                          ? allocate_bit_vector(newlen)
  1780.                                          : allocate_byte_vector(atype,newlen)
  1781.                                         );
  1782.                     array = STACK_0; # array wieder holen
  1783.                     # alten in neuen Datenvektor kopieren:
  1784.                     if (len>0)
  1785.                       { var uintL index = 0;
  1786.                         var reg4 object datenvektor = array1_displace_check(array,len,&index);
  1787.                         index = index << atype;
  1788.                        {var reg1 uint_bitpack* ptr1 = &((uint_bitpack*)(&TheSbvector(atype==Atype_Bit ? datenvektor : TheArray(datenvektor)->data)->data[0]))[index/bitpack];
  1789.                         var reg2 uint_bitpack* ptr2 = (uint_bitpack*)(&TheSbvector(atype==Atype_Bit ? neuer_datenvektor : TheArray(neuer_datenvektor)->data)->data[0]);
  1790.                         var reg5 uintL bitpackcount = ceiling(len<<atype,bitpack); # Anzahl der zu schreibenden Worte
  1791.                         # kopiere bitpackcount Words, von ptr1 ab (dabei um
  1792.                         # (index mod bitpack) Bits nach links schieben), mit
  1793.                         # Ziel ab ptr2. (Eventuell schießt man über den Source-
  1794.                         # Datenvektor hinweg, aber das macht nichts.)
  1795.                         var reg3 uintL shift = index % bitpack;
  1796.                         if (shift==0)
  1797.                           { # keine Verschiebung nötig
  1798.                             var reg3 uintL count;
  1799.                             dotimespL(count,bitpackcount, { *ptr2++ = *ptr1++; } );
  1800.                           }
  1801.                           else
  1802.                           { # beim Kopieren um shift Bits links schieben.
  1803.                             ptr1 += bitpackcount; ptr2 += bitpackcount; # von hinten anfangen
  1804.                            {var reg1 uint_2bitpack carry = L_bitpack(LR_0_bitpack(*ptr1)<<shift);
  1805.                             var reg3 uintL count;
  1806.                             dotimespL(count,bitpackcount,
  1807.                                       # Hier enthalten die rechten shift Bits von carry
  1808.                                       # den Übertrag von rechts, sonst Null.
  1809.                                       { carry |= LR_0_bitpack(*--ptr1)<<shift;
  1810.                                         *--ptr2 = R_bitpack(carry);
  1811.                                         carry = L_bitpack(carry);
  1812.                                       });
  1813.                       }}  }}
  1814.                     # new-element eintragen:
  1815.                     datenvektor_store(neuer_datenvektor,len,STACK_1);
  1816.                     break;
  1817.                   default: NOTREACHED
  1818.                   fehler_type:
  1819.                     { # Stackaufbau: new-element, vector.
  1820.                       pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  1821.                       pushSTACK(array_element_type(STACK_(0+1))); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1822.                       pushSTACK(STACK_(0+2)); pushSTACK(STACK_(1+3));
  1823.                       pushSTACK(TheSubr(subr_self)->name);
  1824.                       //: DEUTSCH "~: Das Objekt ~ kann nicht in den Array ~ geschoben werden, weil vom falschen Typ."
  1825.                       //: ENGLISH "~: cannot push ~ into array ~ (bad type)"
  1826.                       //: FRANCAIS "~: L'objet ~ ne peut pas être poussé dans la matrice ~ car il est de mauvais type."
  1827.                       fehler(type_error,GETTEXT("~: cannot push ~ into array ~ (bad type)"));
  1828.                     }
  1829.                 }
  1830.               set_break_sem_1(); # Unterbrechungen verbieten
  1831.               TheArray(array)->data = neuer_datenvektor; # neuen Vektor als Datenvektor eintragen
  1832.               TheArray(array)->flags &= ~bit(arrayflags_displaced_bit); # Displaced-Bit löschen
  1833.               TheArray(array)->dims[2] += 1; # Fillpointer um 1 erhöhen
  1834.               TheArray(array)->dims[1] = newlen; # neue Länge eintragen
  1835.               TheArray(array)->totalsize = newlen; # ist auch neue totalsize
  1836.               clr_break_sem_1(); # Unterbrechungen wieder zulassen
  1837.           } }
  1838.       } }
  1839.     value1 = fixnum(oldfillp); mv_count=1;
  1840.     # alter Fill-Pointer als Wert
  1841.     skipSTACK(2);
  1842.   }
  1843.  
  1844. # UP: erzeugt einen mit Nullen gefüllten Bitvektor
  1845. # allocate_bit_vector_0(len)
  1846. # > uintL len: Länge des Bitvektors (in Bits)
  1847. # < ergebnis: neuer Bitvektor, mit Nullen gefüllt
  1848. # kann GC auslösen
  1849.   global object allocate_bit_vector_0 (uintL len);
  1850.   global object allocate_bit_vector_0(len)
  1851.     var reg4 uintL len;
  1852.     { var reg3 object new = allocate_bit_vector(len); # neuer Bit-Vektor
  1853.       var reg2 uintL count = ceiling(len,bitpack); # ceiling(len/bitpack) Worte mit Nullen füllen
  1854.       if (!(count==0))
  1855.         { var reg1 uint_bitpack* ptr = (uint_bitpack*)(&TheSbvector(new)->data[0]);
  1856.           dotimespL(count,count, { *ptr++ = 0; } );
  1857.         }
  1858.       return new;
  1859.     }
  1860.  
  1861. #if 0 # nur als Reserve, für den Fall, daß wir wieder auf ein GCC-Bug stoßen
  1862.  
  1863. # UP: löscht ein Bit in einem Simple-Bit-Vector
  1864. # sbvector_bclr(sbvector,index);
  1865. # > sbvector: ein Simple-Bit-Vector
  1866. # > index: Index (Variable, sollte < (length sbvector) sein)
  1867.   global void sbvector_bclr (object sbvector, uintL index);
  1868.   global void sbvector_bclr(sbvector,index)
  1869.     var reg1 object sbvector;
  1870.     var reg2 uintL index;
  1871.     { # im Byte (index div 8) das Bit 7 - (index mod 8) löschen:
  1872.       TheSbvector(sbvector)->data[index/8] &= ~bit((~index) % 8);
  1873.     }
  1874.  
  1875. # UP: setzt ein Bit in einem Simple-Bit-Vector
  1876. # sbvector_bset(sbvector,index);
  1877. # > sbvector: ein Simple-Bit-Vector
  1878. # > index: Index (Variable, sollte < (length sbvector) sein)
  1879.   global void sbvector_bset (object sbvector, uintL index);
  1880.   global void sbvector_bset(sbvector,index)
  1881.     var reg1 object sbvector;
  1882.     var reg2 uintL index;
  1883.     { # im Byte (index div 8) das Bit 7 - (index mod 8) setzen:
  1884.       TheSbvector(sbvector)->data[index/8] |= bit((~index) % 8);
  1885.     }
  1886.  
  1887. #endif
  1888.  
  1889. # Folgende beide Funktionen arbeiten auf "Semi-Simple String"s.
  1890. # Das sind STRING-CHAR-Arrays mit FILL-POINTER, die aber nicht adjustierbar
  1891. # und nicht displaced sind und deren Datenvektor ein Simple-String ist.
  1892. # Beim Überschreiten der Länge wird ihre Länge verdoppelt
  1893. # (so daß der Aufwand fürs Erweitern nicht sehr ins Gewicht fällt).
  1894.  
  1895. # UP: Liefert einen Semi-Simple String gegebener Länge, Fill-Pointer =0.
  1896. # make_ssstring(len)
  1897. # > uintL len: Länge >0
  1898. # < ergebnis: neuer Semi-Simple String dieser Länge
  1899. # kann GC auslösen
  1900.   global object make_ssstring (uintL len);
  1901.   global object make_ssstring(len)
  1902.     var reg2 uintL len;
  1903.     { {var reg1 object new_string = allocate_string(len);
  1904.        # neuer Simple-String dieser Länge
  1905.        pushSTACK(new_string); # retten
  1906.       }
  1907.       {var reg1 object new_array =
  1908.          allocate_array(bit(arrayflags_fillp_bit)|bit(arrayflags_notbytep_bit)|Atype_String_Char,1,string_type);
  1909.          # Flags: nur FILL_POINTER_BIT, Elementtyp STRING-CHAR, Rang=1
  1910.        TheArray(new_array)->dims[1] = 0; # Fill-Pointer := 0
  1911.        TheArray(new_array)->totalsize =
  1912.          TheArray(new_array)->dims[0] = len; # Länge und Total-Size eintragen
  1913.        TheArray(new_array)->data = popSTACK(); # Datenvektor eintragen
  1914.        return new_array;
  1915.     } }
  1916.  
  1917. # UP: Schiebt ein String-Char in einen Semi-Simple String und erweitert ihn
  1918. # dabei eventuell.
  1919. # ssstring_push_extend(ssstring,ch)
  1920. # > ssstring: Semi-Simple String
  1921. # > ch: Character
  1922. # < ergebnis: derselbe Semi-Simple String
  1923. # kann GC auslösen
  1924.   global object ssstring_push_extend (object ssstring, uintB ch);
  1925.   global object ssstring_push_extend(ssstring,ch)
  1926.     var reg2 object ssstring;
  1927.     var reg3 uintB ch;
  1928.     { var reg1 object sstring = TheArray(ssstring)->data; # Datenvektor (ein Simple-String)
  1929.       if (TheArray(ssstring)->dims[1] # Fill-Pointer
  1930.           >= TheSstring(sstring)->length ) # >= Länge ?
  1931.         { # ja -> String wird um den Faktor 2 länger gemacht
  1932.           pushSTACK(ssstring); # ssstring retten
  1933.           pushSTACK(sstring); # Datenvektor ebenfalls retten
  1934.          {var reg4 object neuer_sstring = allocate_string(2 * TheSstring(sstring)->length);
  1935.           # neuer Simple-String der doppelten Länge
  1936.           sstring = popSTACK(); # sstring zurück
  1937.           # Stringinhalt von String sstring nach String neuer_sstring kopieren:
  1938.           { var reg1 uintB* ptr1 = &TheSstring(sstring)->data[0];
  1939.             var reg2 uintB* ptr2 = &TheSstring(neuer_sstring)->data[0];
  1940.             var reg3 uintL count;
  1941.             dotimespL(count,TheSstring(sstring)->length, { *ptr2++ = *ptr1++; } );
  1942.           }
  1943.           ssstring = popSTACK(); # ssstring zurück
  1944.           set_break_sem_1(); # Unterbrechungen verbieten
  1945.           TheArray(ssstring)->data = neuer_sstring; # neuen String als Datenvektor abspeichern
  1946.           TheArray(ssstring)->totalsize =
  1947.             TheArray(ssstring)->dims[0] = TheSstring(neuer_sstring)->length; # neue Länge eintragen
  1948.           clr_break_sem_1(); # Unterbrechungen wieder zulassen
  1949.           sstring = neuer_sstring;
  1950.         }}
  1951.       # Nun ist wieder sstring der Datenvektor, und es gilt
  1952.       # Fill-Pointer < Länge(Datenvektor).
  1953.       # Character hineinschieben und Fill-Pointer erhöhen:
  1954.       TheSstring(sstring)->data[ TheArray(ssstring)->dims[1]++ ] = ch;
  1955.       return ssstring;
  1956.     }
  1957.  
  1958. #ifdef STRM_WR_SS
  1959. # UP: Stellt sicher, daß ein Semi-Simple String eine bestimmte Länge hat
  1960. # und erweitert ihn dazu eventuell.
  1961. # ssstring_extend(ssstring,size)
  1962. # > ssstring: Semi-Simple String
  1963. # > size: gewünschte Mindestgröße
  1964. # < ergebnis: derselbe Semi-Simple String
  1965. # kann GC auslösen
  1966.   global object ssstring_extend (object ssstring, uintL needed_len);
  1967.   global object ssstring_extend(ssstring,needed_len)
  1968.     var reg4 object ssstring;
  1969.     var reg8 uintL needed_len;
  1970.     { var reg5 object sstring = TheArray(ssstring)->data; # Datenvektor (ein Simple-String)
  1971.       var reg7 uintL now_len = TheSstring(sstring)->length; # jetzige Maximal-Länge
  1972.       if (needed_len > now_len)
  1973.         { # ja -> String wird länger gemacht, mindestens um den Faktor 2:
  1974.           pushSTACK(ssstring); # ssstring retten
  1975.           pushSTACK(sstring); # Datenvektor ebenfalls retten
  1976.           now_len = now_len * 2;
  1977.           if (needed_len > now_len) { now_len = needed_len; } # now_len vergrößern
  1978.          {var reg6 object neuer_sstring = allocate_string(now_len);
  1979.           # neuer Simple-String mindestens der gewünschten und der doppelten Länge
  1980.           sstring = popSTACK(); # sstring zurück
  1981.           # Stringinhalt von String sstring nach String neuer_sstring kopieren:
  1982.           { var reg1 uintB* ptr1 = &TheSstring(sstring)->data[0];
  1983.             var reg2 uintB* ptr2 = &TheSstring(neuer_sstring)->data[0];
  1984.             var reg3 uintL count;
  1985.             dotimespL(count,TheSstring(sstring)->length, { *ptr2++ = *ptr1++; } );
  1986.           }
  1987.           ssstring = popSTACK(); # ssstring zurück
  1988.           set_break_sem_1(); # Unterbrechungen verbieten
  1989.           TheArray(ssstring)->data = neuer_sstring; # neuen String als Datenvektor abspeichern
  1990.           TheArray(ssstring)->totalsize =
  1991.             TheArray(ssstring)->dims[0] = now_len; # neue Länge eintragen
  1992.           clr_break_sem_1(); # Unterbrechungen wieder zulassen
  1993.         }}
  1994.       return ssstring;
  1995.     }
  1996. #endif
  1997.  
  1998.  
  1999. # Stackaufbau bei MAKE-ARRAY :
  2000. #   dims, adjustable, element-type, initial-element, initial-contents,
  2001. #   fill-pointer, displaced-to, displaced-index-offset.
  2002. # Stackaufbau bei ADJUST-ARRAY :
  2003. #   dims, array, element-type, initial-element, initial-contents,
  2004. #   fill-pointer, displaced-to, displaced-index-offset.
  2005.  
  2006. # Fehlermeldung
  2007. # > dim: fehlerhafte Dimension
  2008. # > subr_self: Aufrufer (ein SUBR)
  2009.   nonreturning_function(local, fehler_dim_type, (object dim));
  2010.   local void fehler_dim_type(dim)
  2011.     var reg1 object dim;
  2012.     { pushSTACK(dim); # Wert für Slot DATUM von TYPE-ERROR
  2013.       pushSTACK(O(type_array_index)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2014.       pushSTACK(dim);
  2015.       pushSTACK(TheSubr(subr_self)->name);
  2016.       //: DEUTSCH "~: Dimension ~ ist nicht vom Typ `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  2017.       //: ENGLISH "~: dimension ~ is not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"
  2018.       //: FRANCAIS "~: La dimension ~ n'est pas de type  `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))."
  2019.       fehler(type_error,GETTEXT("~: dimension ~ is not of type `(INTEGER 0 (,ARRAY-DIMENSION-LIMIT))"));
  2020.     }
  2021.  
  2022. # Hilfsroutine für MAKE-ARRAY und ADJUST-ARRAY:
  2023. # Überprüft die Dimensionen und liefert den Rang und die Gesamtgröße.
  2024. # test_dims(&totalsize)
  2025. # > STACK_7: Dimension oder Dimensionenliste
  2026. # > subr_self: Aufrufer (ein SUBR)
  2027. # < totalsize: Gesamtgröße = Produkt der Dimensionen
  2028. # < ergebnis: Rang = Anzahl der Dimensionen
  2029.   local uintL test_dims (uintL* totalsize_);
  2030.   local uintL test_dims(totalsize_)
  2031.     var reg5 uintL* totalsize_;
  2032.     { var reg2 object dims = STACK_7;
  2033.       if (listp(dims))
  2034.         { var reg4 uintL rank = 0; # bisherige Anzahl der Dimensionen
  2035.           var reg3 uintL totalsize = 1; # bisheriges Produkt der Dimensionen,
  2036.                                         # bleibt < arraysize_limit
  2037.           while (consp(dims))
  2038.             { var reg1 object dim = Car(dims); # nächste Dimension
  2039.               # if (!integerp(dim)) { fehler_dim_type(dim); } # muß Integer sein
  2040.               if (!posfixnump(dim)) { fehler_dim_type(dim); } # muß Fixnum >=0 sein
  2041.               # totalsize * dim bilden:
  2042.              {var reg7 uintL produkt_hi;
  2043.               var reg6 uintL produkt_lo;
  2044.               #if (oint_data_len<=24)
  2045.               mulu24(totalsize,posfixnum_to_L(dim), produkt_hi=,produkt_lo=);
  2046.               #else
  2047.               mulu32(totalsize,posfixnum_to_L(dim), produkt_hi=,produkt_lo=);
  2048.               #endif
  2049.               #ifndef UNIX_DEC_ULTRIX_GCCBUG
  2050.               if (!((produkt_hi==0) && (produkt_lo<=arraysize_limit_1))) # Produkt < 2^24 ?
  2051.               #else
  2052.               if (!(produkt_hi==0))
  2053.               #endif
  2054.                 { # nein -> (sofern nicht noch eine Dimension=0 kommt)
  2055.                   # Total-Size zu groß
  2056.                   pushSTACK(STACK_7); # dims
  2057.                   pushSTACK(TheSubr(subr_self)->name);
  2058.                   //: DEUTSCH "~: Dimensionen ~ ergeben zu große Gesamtgröße."
  2059.                   //: ENGLISH "~: dimensions ~ produce too large total-size"
  2060.                   //: FRANCAIS "~: Les dimensions ~ donnent une taille totale trop grande."
  2061.                   fehler(error,GETTEXT("~: dimensions ~ produce too large total-size"));
  2062.                 }
  2063.               totalsize = produkt_lo;
  2064.               rank++;
  2065.               dims = Cdr(dims);
  2066.             }}
  2067.           *totalsize_ = totalsize;
  2068.           return rank;
  2069.         }
  2070.       # dims ist keine Liste. Sollte eine einzelne Dimension sein:
  2071.       # if (!integerp(dims)) { fehler_dim_type(dims); } # muß Integer sein
  2072.       if (!posfixnump(dims)) { fehler_dim_type(dims); } # muß Fixnum >=0 sein
  2073.       *totalsize_ = posfixnum_to_L(dims); # Totalsize = einzige Dimension
  2074.       return 1; # Rang = 1
  2075.     }
  2076.  
  2077. # Hilfsroutine für MAKE-ARRAY und ADJUST-ARRAY:
  2078. # Überprüft einige der Keywords.
  2079.   local void test_otherkeys (void);
  2080.   local void test_otherkeys()
  2081.     { # fill-pointer hat Defaultwert NIL:
  2082.       if (eq(STACK_2,unbound)) { STACK_2 = NIL; }
  2083.       # displaced-to hat Defaultwert NIL:
  2084.       if (eq(STACK_1,unbound)) { STACK_1 = NIL; }
  2085.       # Testen, ob mehr als eine Initialisierung
  2086.       # (:initial-element, :initial-contents, :displaced-to) angegeben wurde:
  2087.       { var reg1 uintB initcount = 0; # Zähler
  2088.         if (!(eq(STACK_4,unbound))) { initcount++; } # initial-element angegeben?
  2089.         if (!(eq(STACK_3,unbound))) { initcount++; } # initial-contents angegeben?
  2090.         if (!nullp(STACK_1)) { initcount++; } # displaced-to angegeben?
  2091.         if (initcount > 1) # Mehr als eine Initialisierung?
  2092.           { pushSTACK(TheSubr(subr_self)->name);
  2093.             //: DEUTSCH "~: Mehr als eine Initialisierung angegeben."
  2094.             //: ENGLISH "~: ambiguous, more than one initialisation specified"
  2095.             //: FRANCAIS "~: Il fut indiqué plus d'une initialisation, c'est ambigu."
  2096.             fehler(error,GETTEXT("~: ambiguous, more than one initialisation specified"));
  2097.       }   }
  2098.       # Testen, ob :displaced-index-offset ohne :displaced-to verwendet wurde:
  2099.       if ((!eq(STACK_0,unbound)) # displaced-index-offset angegeben?
  2100.           && (nullp(STACK_1)) # und displaced-to nicht angegeben?
  2101.          )
  2102.         { pushSTACK(S(Kdisplaced_to));
  2103.           pushSTACK(S(Kdisplaced_index_offset));
  2104.           pushSTACK(TheSubr(subr_self)->name);
  2105.           //: DEUTSCH "~: ~ darf nur zusammen mit ~ verwendet werden."
  2106.           //: ENGLISH "~: ~ must not be specified without ~"
  2107.           //: FRANCAIS "~: ~ ne peut être utilisé qu'avec ~."
  2108.           fehler(error,GETTEXT("~: ~ must not be specified without ~"));
  2109.         }
  2110.     }
  2111.  
  2112. # Hilfsroutine für MAKE-ARRAY und ADJUST-ARRAY:
  2113. # erzeugt einen Datenvektor gegebener Länge
  2114. # und füllt ihn mit initial-element, falls angegeben.
  2115. # make_datenvektor(len,eltype)
  2116. # > len: Länge
  2117. # > eltype: Elementtyp-Code
  2118. # > subr_self: Aufrufer (ein SUBR)
  2119. # < ergebnis: einfacher Vektor des gegebenen Typs, evtl. gefüllt.
  2120. # kann GC auslösen
  2121.   local object make_datenvektor (uintL len, uintB eltype);
  2122.   local object make_datenvektor(len,eltype)
  2123.     var reg2 uintL len;
  2124.     var reg4 uintB eltype;
  2125.     { switch (eltype)
  2126.         { case Atype_T: # Simple-Vector erzeugen
  2127.             { var reg5 object vektor = allocate_vector(len);
  2128.               if (!(eq(STACK_4,unbound))) # initial-element angegeben?
  2129.                 if (!(len==0)) # und Länge > 0 ?
  2130.                   { # ja -> Vektor mit initial-element füllen:
  2131.                     var reg1 object* ptr = &TheSvector(vektor)->data[0];
  2132.                     var reg3 object initial_element = STACK_4;
  2133.                     dotimespL(len,len, { *ptr++ = initial_element; });
  2134.                   }
  2135.               return vektor;
  2136.             }
  2137.           case Atype_Bit: # Simple-Bit-Vector erzeugen
  2138.             { var reg5 object vektor = allocate_bit_vector(len);
  2139.               if (!(eq(STACK_4,unbound))) # initial-element angegeben?
  2140.                 { # ja -> überprüfen:
  2141.                   var reg3 uint_bitpack initial_bitpack;
  2142.                   if (eq(STACK_4,Fixnum_0)) { initial_bitpack = (uint_bitpack)0UL; } # 0 -> mit Nullword füllen
  2143.                   elif (eq(STACK_4,Fixnum_1)) { initial_bitpack = (uint_bitpack)~0UL; } # 1 -> mit Einsenword füllen
  2144.                   else goto fehler_init;
  2145.                   if (!(len==0)) # und Länge > 0 ?
  2146.                     { # ja -> Vektor mit initial-element füllen:
  2147.                       var reg1 uint_bitpack* ptr = (uint_bitpack*)(&TheSbvector(vektor)->data[0]);
  2148.                       dotimespL(len,ceiling(len,bitpack), { *ptr++ = initial_bitpack; });
  2149.                 }   }
  2150.               return vektor;
  2151.             }
  2152.           case Atype_String_Char: # Simple-String erzeugen
  2153.             { var reg5 object vektor = allocate_string(len);
  2154.               if (!(eq(STACK_4,unbound))) # initial-element angegeben?
  2155.                 { # ja -> überprüfen, muß String-Char sein:
  2156.                   if (!(string_char_p(STACK_4))) goto fehler_init;
  2157.                  {var reg3 uintB initial_char = char_code(STACK_4);
  2158.                   if (!(len==0)) # und Länge > 0 ?
  2159.                     { # ja -> Vektor mit initial-element füllen:
  2160.                       var reg1 uintB* ptr = &TheSstring(vektor)->data[0];
  2161.                       dotimespL(len,len, { *ptr++ = initial_char; });
  2162.                 }}  }
  2163.               return vektor;
  2164.             }
  2165.           case Atype_2Bit:
  2166.           case Atype_4Bit:
  2167.           case Atype_8Bit:
  2168.           case Atype_16Bit:
  2169.           case Atype_32Bit: # semi-simplen Byte-Vektor erzeugen
  2170.             { var reg5 object vektor = allocate_byte_vector(eltype,len);
  2171.               if (!(eq(STACK_4,unbound))) # initial-element angegeben?
  2172.                 { # ja -> überprüfen, muß passender Integer sein:
  2173.                   var reg6 uintL wert;
  2174.                   if (eltype==Atype_32Bit)
  2175.                     { wert = I_to_UL(STACK_4); }
  2176.                     else
  2177.                     { if (!(mposfixnump(STACK_4) && ((wert = posfixnum_to_L(STACK_4)) < bit(bit(eltype)))))
  2178.                         goto fehler_init;
  2179.                     }
  2180.                   if (!(len==0))
  2181.                     switch (eltype)
  2182.                       { case Atype_2Bit:
  2183.                           len = ceiling(len,2); wert |= wert<<2;
  2184.                         case Atype_4Bit:
  2185.                           len = ceiling(len,2); wert |= wert<<4;
  2186.                         case Atype_8Bit:
  2187.                           #if !(varobject_alignment%2 == 0)
  2188.                           { var reg1 uintB* ptr = &TheSbvector(TheArray(vektor)->data)->data[0];
  2189.                             dotimespL(len,len, { *ptr++ = wert; });
  2190.                           }
  2191.                           break;
  2192.                           #else
  2193.                           # Kann mit 16-Bit-Blöcken arbeiten
  2194.                           len = ceiling(len,2); wert |= wert<<8;
  2195.                           #endif
  2196.                         case Atype_16Bit:
  2197.                           #if !(varobject_alignment%4 == 0)
  2198.                           { var reg1 uint16* ptr = (uint16*)(&TheSbvector(TheArray(vektor)->data)->data[0]);
  2199.                             dotimespL(len,len, { *ptr++ = wert; });
  2200.                           }
  2201.                           break;
  2202.                           #else
  2203.                           # Kann mit 32-Bit-Blöcken arbeiten
  2204.                           len = ceiling(len,2); wert |= wert<<16;
  2205.                           #endif
  2206.                         case Atype_32Bit:
  2207.                           { var reg1 uint32* ptr = (uint32*)(&TheSbvector(TheArray(vektor)->data)->data[0]);
  2208.                             dotimespL(len,len, { *ptr++ = wert; });
  2209.                           }
  2210.                           break;
  2211.                 }     }
  2212.               return vektor;
  2213.             }
  2214.           default: NOTREACHED
  2215.           fehler_init:
  2216.             pushSTACK(STACK_4); # Wert für Slot DATUM von TYPE-ERROR
  2217.             pushSTACK(STACK_(5+1)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2218.             pushSTACK(STACK_(5+2)); # element-type
  2219.             pushSTACK(STACK_(4+3)); # initial-element
  2220.             pushSTACK(TheSubr(subr_self)->name);
  2221.             //: DEUTSCH "~: Das Initialisierungselement ~ ist nicht vom Typ ~."
  2222.             //: ENGLISH "~: the initial-element ~ is not of type ~"
  2223.             //: FRANCAIS "~: L'élément initial ~ n'est pas de type ~."
  2224.             fehler(type_error,GETTEXT("~: the initial-element ~ is not of type ~"));
  2225.     }   }
  2226.  
  2227. # Hilfsroutine für MAKE-ARRAY und ADJUST-ARRAY:
  2228. # Füllt einen Vektor lexikographisch mit dem Inhalt einer verschachtelten
  2229. # Sequence-Struktur, wie sie als Argument zum Keyword :initial-contents
  2230. # bei MAKE-ARRAY und ADJUST-ARRAY anzugeben ist.
  2231. # initial_contents(datenvektor,dims,rank,contents)
  2232. # > datenvektor: ein simpler Vektor
  2233. # > dims: Dimension oder Dimensionenliste, alle Dimensionen Fixnums,
  2234. #         Länge(datenvektor) = Produkt der Dimensionen
  2235. # > rank: Anzahl der Dimensionen
  2236. # > contents: verschachtelte Sequence-Struktur
  2237. # < ergebnis: derselbe Datenvektor
  2238. # Nicht reentrant!
  2239. # kann GC auslösen
  2240.   local object initial_contents (object datenvektor, object dims, uintL rank, object contents);
  2241.   local object* initial_contents_local; # Pointer auf Datenvektor und Dimensionen
  2242.   local uintL initial_contents_index; # Index in den Datenvektor
  2243.   local uintL initial_contents_depth; # Rekursionstiefe
  2244.   local object initial_contents(datenvektor,dims,rank,contents)
  2245.     var reg3 object datenvektor;
  2246.     var reg1 object dims;
  2247.     var reg2 uintL rank;
  2248.     var reg4 object contents;
  2249.     { # alle Dimensionen auf den Stack:
  2250.       get_space_on_STACK(rank*sizeof(object));
  2251.       if (listp(dims))
  2252.         { while (consp(dims)) { pushSTACK(Car(dims)); dims = Cdr(dims); } }
  2253.         else
  2254.         { pushSTACK(dims); }
  2255.       initial_contents_local = &STACK_0; # aktuellen STACK-Wert merken
  2256.       initial_contents_index = 0; # Index := 0
  2257.       initial_contents_depth = rank; # depth := rank
  2258.       pushSTACK(datenvektor); # Datenvektor in den Stack
  2259.       pushSTACK(subr_self); # aktuelles SUBR retten
  2260.       # initial_contents_aux aufrufen:
  2261.       pushSTACK(contents); funcall(L(initial_contents_aux),1);
  2262.       subr_self = popSTACK(); # aktuelles SUBR zurück
  2263.       datenvektor = popSTACK(); # Datenvektor zurück
  2264.       skipSTACK(rank); # STACK aufräumen
  2265.       return datenvektor;
  2266.     }
  2267.  
  2268. # Hilfsfunktion für initial_contents:
  2269. # Arbeitet die Sequence-Struktur rekursiv ab.
  2270. LISPFUNN(initial_contents_aux,1)
  2271.   { # Übergeben wird:
  2272.     # initial_contents_depth = Rekursionstiefe,
  2273.     # initial_contents_index = Index in den Datenvektor,
  2274.     # initial_contents_local = Pointer auf die Dimensionen,
  2275.     #   bei Tiefe depth>0 ist maßgeblich
  2276.     #   Dimension (rank-depth) = *(local+depth-1),
  2277.     #   Datenvektor = *(local-1), Aufrufer = *(local-2).
  2278.     var reg1 object* localptr = initial_contents_local;
  2279.     if (initial_contents_depth==0)
  2280.       # Tiefe 0 -> Element STACK_0 in den Datenvektor eintragen:
  2281.       { var reg2 object datenvektor = *(localptr STACKop -1);
  2282.         subr_self = *(localptr STACKop -2);
  2283.         pushSTACK(datenvektor);
  2284.         datenvektor_store(datenvektor,initial_contents_index,STACK_(0+1));
  2285.         initial_contents_index++;
  2286.         skipSTACK(2); # Stack aufräumen
  2287.       }
  2288.       else
  2289.       # Tiefe >0 -> rekursiv aufrufen:
  2290.       { initial_contents_depth--;
  2291.         # seq = STACK_0 muß eine Sequence korrekter Länge sein:
  2292.         pushSTACK(STACK_0); funcall(L(length),1); # Länge bestimmen
  2293.         # muß EQL (also EQ) zur Dimension *(local+depth) sein:
  2294.         if (!(eq(value1,*(localptr STACKop initial_contents_depth))))
  2295.           { # fehlerhafte Sequence seq noch in STACK_0.
  2296.             pushSTACK(TheSubr(*(localptr STACKop -2))->name);
  2297.             //: DEUTSCH "~: ~ hat nicht die richtige Länge."
  2298.             //: ENGLISH "~: ~ has not the correct length"
  2299.             //: FRANCAIS "~: ~ n'est pas de longueur convenable."
  2300.             fehler(error,GETTEXT("~: ~ has not the correct length"));
  2301.           }
  2302.         # Länge stimmt, nun (MAP NIL #'INITIAL-CONTENTS-AUX seq) ausführen:
  2303.         pushSTACK(NIL); pushSTACK(L(initial_contents_aux)); pushSTACK(STACK_(0+2));
  2304.         funcall(L(map),3);
  2305.         initial_contents_depth++;
  2306.         skipSTACK(1); # Stack aufräumen
  2307.       }
  2308.     value1=NIL; mv_count=0; # keine Werte
  2309.   }
  2310.  
  2311. # Hilfsroutine für MAKE-ARRAY und ADJUST-ARRAY:
  2312. # Überprüfe ein displaced-to-Argument und den dazugehörigen Offset.
  2313. # test_displaced(eltype,totalsize)
  2314. # > eltype: Elementtyp-Code des zu erzeugenden Arrays
  2315. # > totalsize: Gesamtgröße des zu erzeugenden Arrays
  2316. # > subr_self: Aufrufer (ein SUBR)
  2317. # < ergebnis: Wert des displaced-index-offset
  2318.   local uintL test_displaced (uintB eltype, uintL totalsize);
  2319.   local uintL test_displaced(eltype,totalsize)
  2320.     var reg4 uintB eltype;
  2321.     var reg5 uintL totalsize;
  2322.     { # displaced-to überprüfen, muß ein Array sein:
  2323.       var reg1 object displaced_to = STACK_1;
  2324.       if_arrayp(displaced_to, ; ,
  2325.         { fehler_array_displaced_to(displaced_to);
  2326.         });
  2327.       {# Elementtyp von displaced_to bestimmen:
  2328.        var reg2 uintB displaced_eltype;
  2329.        switch (mtypecode(STACK_1))
  2330.          { case_array1: case_obvector: # allgemeiner Array -> Arrayflags anschauen
  2331.              displaced_eltype = TheArray(displaced_to)->flags & arrayflags_atype_mask;
  2332.              break;
  2333.            # Zuordnung  Vektor-Typinfo -> ATYPE-Byte :
  2334.            case_sbvector: displaced_eltype = Atype_Bit; break;
  2335.            case_string: displaced_eltype = Atype_String_Char; break;
  2336.            case_vector: displaced_eltype = Atype_T; break;
  2337.            default: NOTREACHED
  2338.          }
  2339.        # displaced_eltype ist der ATYPE des :displaced-to-Arguments.
  2340.        # Gegebenen Elementtyp damit vergleichen:
  2341.        if (!(eltype == displaced_eltype))
  2342.          { pushSTACK(displaced_to); # Wert für Slot DATUM von TYPE-ERROR
  2343.            pushSTACK(S(array)); pushSTACK(STACK_(5+2)); pushSTACK(listof(2)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2344.            pushSTACK(STACK_(5+2)); # element-type
  2345.            pushSTACK(STACK_2); # displaced_to
  2346.            pushSTACK(S(Kdisplaced_to));
  2347.            pushSTACK(TheSubr(subr_self)->name);
  2348.            //: DEUTSCH "~: ~-Argument ~ hat nicht den Elementtyp ~."
  2349.            //: ENGLISH "~: ~-argument ~ has not element type ~"
  2350.            //: FRANCAIS "~: Le ~ argument ~ n'a pas ~ comme type d'élément."
  2351.            fehler(type_error,GETTEXT("~: ~-argument ~ has not element type ~"));
  2352.          }
  2353.       }
  2354.       {# Displaced-Index-Offset überprüfen:
  2355.        var reg2 uintL displaced_index_offset;
  2356.        if (eq(STACK_0,unbound)) { displaced_index_offset = 0; } # Default ist 0
  2357.        elif (mposfixnump(STACK_0)) { displaced_index_offset = posfixnum_to_L(STACK_0); }
  2358.        else
  2359.          { pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  2360.            pushSTACK(O(type_array_index)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2361.            pushSTACK(STACK_(0+2));
  2362.            pushSTACK(S(Kdisplaced_index_offset));
  2363.            pushSTACK(TheSubr(subr_self)->name);
  2364.            //: DEUTSCH "~: ~-Argument ~ ist nicht vom Typ `(INTEGER 0 (,ARRAY-TOTAL-SIZE-LIMIT))."
  2365.            //: ENGLISH "~: ~-argument ~ is not of type `(INTEGER 0 (,ARRAY-TOTAL-SIZE-LIMIT))"
  2366.            //: FRANCAIS "~: Le ~ argument ~ n'est pas de type `(INTEGER 0 (,ARRAY-TOTAL-SIZE-LIMIT))."
  2367.            fehler(type_error,GETTEXT("~: ~-argument ~ is not of type `(INTEGER 0 (,ARRAY-TOTAL-SIZE-LIMIT))"));
  2368.          }
  2369.        {# Überprüfen, ob angesprochenes Teilstück ganz in displaced-to paßt:
  2370.         var reg3 uintL displaced_totalsize = array_total_size(displaced_to);
  2371.         if (!(displaced_index_offset+totalsize <= displaced_totalsize))
  2372.           { pushSTACK(S(Kdisplaced_to));
  2373.             pushSTACK(fixnum(displaced_totalsize));
  2374.             pushSTACK(fixnum(displaced_index_offset));
  2375.             pushSTACK(TheSubr(subr_self)->name);
  2376.             //: DEUTSCH "~: Array-Gesamtgröße mit Displaced-Offset (~) > Gesamtgröße ~ des ~-Arguments"
  2377.             //: ENGLISH "~: array-total-size + displaced-offset (= ~) exceeds total size ~ of ~-argument"
  2378.             //: FRANCAIS "~: La taille totale de la matrice avec «displaced-offset» (~) est supérieure à la taille totale ~ du ~ argument."
  2379.             fehler(error,GETTEXT("~: array-total-size + displaced-offset (= ~) exceeds total size ~ of ~-argument"));
  2380.        }  }
  2381.        return displaced_index_offset;
  2382.     } }
  2383.  
  2384. # Hilfsroutine für MAKE-ARRAY und ADJUST-ARRAY:
  2385. # Überprüfe ein fill-pointer-Argument /=NIL.
  2386. # test_fillpointer(len)
  2387. # > totalsize: Maximalwert von fill-pointer
  2388. # > subr_self: Aufrufer (ein SUBR)
  2389. # < ergebnis: Wert des fill-pointer
  2390.   local uintL test_fillpointer (uintL totalsize);
  2391.   local uintL test_fillpointer(totalsize)
  2392.     var reg1 uintL totalsize;
  2393.     { # fill-pointer war angegeben und /=NIL
  2394.       if (eq(STACK_2,S(t))) # T angegeben ->
  2395.         { return totalsize; } # Fill-Pointer := Länge = Gesamtgröße
  2396.       elif (!mposfixnump(STACK_2)) # kein Fixnum >=0 -> Fehler
  2397.         { pushSTACK(STACK_2); # Wert für Slot DATUM von TYPE-ERROR
  2398.           pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2399.           pushSTACK(STACK_(2+2));
  2400.           pushSTACK(TheSubr(subr_self)->name);
  2401.           //: DEUTSCH "~: Gewünschter Fill-Pointer ~ sollte ein Fixnum >=0 sein."
  2402.           //: ENGLISH "~: fill-pointer ~ should be a nonnegative fixnum"
  2403.           //: FRANCAIS "~: Le pointeur de remplissage ~ devrait être de type FIXNUM positif ou zéro."
  2404.           fehler(type_error,GETTEXT("~: fill-pointer ~ should be a nonnegative fixnum"));
  2405.         }
  2406.       else
  2407.         { var reg2 uintL fillpointer = posfixnum_to_L(STACK_2);
  2408.           if (!(fillpointer <= totalsize)) # mit Länge vergleichen
  2409.             { pushSTACK(fixnum(totalsize));
  2410.               pushSTACK(STACK_(2+1));
  2411.               pushSTACK(TheSubr(subr_self)->name);
  2412.               //: DEUTSCH "~: Gewünschter Fill-Pointer ~ ist größer als die Länge ~"
  2413.               //: ENGLISH "~: fill-pointer argument ~ is larger than the length ~"
  2414.               //: FRANCAIS "~: L'argument ~ pour le pointeur de remplissage est plus grand que la longueur ~."
  2415.               fehler(error,GETTEXT("~: fill-pointer argument ~ is larger than the length ~"));
  2416.             }
  2417.           return fillpointer;
  2418.     }   }
  2419.  
  2420. LISPFUN(make_array,1,0,norest,key,7,\
  2421.         (kw(adjustable),kw(element_type),kw(initial_element),\
  2422.          kw(initial_contents),kw(fill_pointer),\
  2423.          kw(displaced_to),kw(displaced_index_offset)) )
  2424. # (MAKE-ARRAY dimensions :adjustable :element-type :initial-element
  2425. #   :initial-contents :fill-pointer :displaced-to :displaced-index-offset),
  2426. #   CLTL S. 286
  2427.   # Stackaufbau:
  2428.   #   dims, adjustable, element-type, initial-element, initial-contents,
  2429.   #   fill-pointer, displaced-to, displaced-index-offset.
  2430.   { # Dimensionen überprüfen und Rang und Total-Size berechnen:
  2431.     var uintL totalsize;
  2432.     var reg4 uintL rank = test_dims(&totalsize);
  2433.     # adjustable hat Defaultwert NIL:
  2434.     if (eq(STACK_6,unbound)) { STACK_6 = NIL; }
  2435.    {# element-type in einen Code umwandeln:
  2436.     var reg6 uintB eltype;
  2437.     if (!(eq(STACK_5,unbound)))
  2438.       { eltype = eltype_code(STACK_5); }
  2439.       else
  2440.       { # Defaultwert ist T.
  2441.         STACK_5 = S(t); eltype = Atype_T;
  2442.       }
  2443.     test_otherkeys(); # einiges überprüfen
  2444.     { var reg5 uintB flags = eltype;
  2445.       var reg7 uintL displaced_index_offset;
  2446.       var reg9 uintL fillpointer;
  2447.       if (!((eltype<=Atype_32Bit) && !(eltype==Atype_Bit))) # außer bei Byte-Vektoren
  2448.         flags |= bit(arrayflags_notbytep_bit); # notbytep-Bit setzen
  2449.       # Falls nicht displaced, Datenvektor bilden und evtl. füllen:
  2450.       if (nullp(STACK_1)) # displaced-to nicht angegeben?
  2451.         { # Datenvektor bilden:
  2452.           var reg1 object datenvektor = make_datenvektor(totalsize,eltype);
  2453.           if (!eq(STACK_3,unbound)) # und falls initial-contents angegeben:
  2454.             { datenvektor = initial_contents(datenvektor,STACK_7,rank,STACK_3); } # füllen
  2455.           # Falls displaced-to nicht angegeben ist
  2456.           # und fill-pointer nicht angegeben ist
  2457.           # und adjustable nicht angegeben ist
  2458.           # und rank=1 ist,
  2459.           # ist ein (semi-)simpler Vektor zu liefern:
  2460.           if ((rank==1) && (nullp(STACK_6)) && (nullp(STACK_2)))
  2461.             { value1 = datenvektor; mv_count=1; # Datenvektor als Ergebnis
  2462.               skipSTACK(8); return;
  2463.             }
  2464.           # Es ist ein allgemeiner Array zu liefern.
  2465.           STACK_1 = datenvektor; # datenvektor als "displaced-to" ablegen
  2466.           displaced_index_offset = 0; # mit Displacement 0
  2467.           # und ohne Displacement-Bit in den Flags
  2468.         }
  2469.         else
  2470.         { # displaced-to angegeben -> Es ist ein allgemeiner Array zu liefern.
  2471.           displaced_index_offset = test_displaced(eltype,totalsize);
  2472.           # Flags enthalten das Displacement-Bit:
  2473.           flags |= bit(arrayflags_displaced_bit)|bit(arrayflags_dispoffset_bit);
  2474.         }
  2475.       # Erzeuge einen allgemeinen Array.
  2476.       # Rang überprüfen:
  2477.       #ifndef UNIX_DEC_ULTRIX_GCCBUG
  2478.       if (rank > arrayrank_limit_1)
  2479.         { pushSTACK(fixnum(rank)); # Wert für Slot DATUM von TYPE-ERROR
  2480.           pushSTACK(O(type_array_rank)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2481.           pushSTACK(fixnum(rank));
  2482.           pushSTACK(TheSubr(subr_self)->name);
  2483.           //: DEUTSCH "~: Der gewünschte Rang ~ ist zu groß."
  2484.           //: ENGLISH "~: attempted rank ~ is too large"
  2485.           //: FRANCAIS "~: Le rang souhaité est trop grand."
  2486.           fehler(type_error,GETTEXT("~: attempted rank ~ is too large"));
  2487.         }
  2488.       #endif
  2489.       # Flags für allocate_array zusammensetzen:
  2490.       # flags enthält schon eltype und evtl. Displacement-Bit.
  2491.       if (!nullp(STACK_6)) # adjustable angegeben?
  2492.         { flags |= bit(arrayflags_adjustable_bit)|bit(arrayflags_dispoffset_bit); }
  2493.       if (!nullp(STACK_2)) # fill-pointer angegeben?
  2494.         { if (!(rank==1)) # Rang muß 1 sein
  2495.             { pushSTACK(fixnum(rank));
  2496.               pushSTACK(S(Kfill_pointer));
  2497.               pushSTACK(TheSubr(subr_self)->name);
  2498.               //: DEUTSCH "~: ~ darf bei einem Array vom Rang ~ nicht angegeben werden."
  2499.               //: ENGLISH "~: ~ may not be specified for an array of rank ~"
  2500.               //: FRANCAIS "~: ~ ne peut pas être spécifié avec une matrice de rang ~."
  2501.               fehler(error,GETTEXT("~: ~ may not be specified for an array of rank ~"));
  2502.             }
  2503.           flags |= bit(arrayflags_fillp_bit);
  2504.           fillpointer = test_fillpointer(totalsize); # Fill-Pointer-Wert
  2505.         }
  2506.       # Typinfo für das zu erzeugende Objekt bestimmen:
  2507.      {var reg8 tint type;
  2508.       if (rank==1)
  2509.         { # Vektor: Typinfo aus Tabelle bestimmen
  2510.           local tint type_table[8] =
  2511.                # Tabelle für Zuordnung  ATYPE-Byte -> Vektor-Typinfo
  2512.                {      bvector_type,  # Atype_Bit         -> bvector_type
  2513.                       bvector_type,  # Atype_2Bit        -> bvector_type
  2514.                       bvector_type,  # Atype_4Bit        -> bvector_type
  2515.                       bvector_type,  # Atype_8Bit        -> bvector_type
  2516.                       bvector_type,  # Atype_16Bit       -> bvector_type
  2517.                       bvector_type,  # Atype_32Bit       -> bvector_type
  2518.                       vector_type,   # Atype_T           -> vector_type
  2519.                       string_type,   # Atype_String_Char -> string_type
  2520.                                      # restliche ATYPEs unbenutzt
  2521.                };
  2522.           type = type_table[eltype];
  2523.         }
  2524.         else
  2525.         { # allgemeiner Array
  2526.           type = array_type;
  2527.         }
  2528.       # Array allozieren:
  2529.       { var reg3 object array = allocate_array(flags,rank,type);
  2530.         TheArray(array)->totalsize = totalsize; # Total-Size eintragen
  2531.         {var reg1 uintL* dimptr = &TheArray(array)->dims[0];
  2532.          if (flags & bit(arrayflags_dispoffset_bit))
  2533.            { *dimptr++ = displaced_index_offset; } # Displaced-Index-Offset eintragen
  2534.          # Dimensionen eintragen:
  2535.          { var reg2 object dims = STACK_7;
  2536.            if (listp(dims))
  2537.              { while (consp(dims))
  2538.                  { *dimptr++ = posfixnum_to_L(Car(dims)); dims = Cdr(dims); }
  2539.              }
  2540.              else
  2541.              { *dimptr++ = posfixnum_to_L(dims); }
  2542.          }
  2543.          # evtl. Fill-Pointer eintragen:
  2544.          if (flags & bit(arrayflags_fillp_bit))
  2545.            { # fill-pointer war angegeben und /=NIL
  2546.              *dimptr++ = fillpointer;
  2547.            }
  2548.         }
  2549.         # Datenvektor eintragen:
  2550.         TheArray(array)->data = STACK_1; # displaced-to-Argument oder neuer Datenvektor
  2551.         # array als Wert:
  2552.         value1 = array; mv_count=1; skipSTACK(8);
  2553.   }}}}}
  2554.  
  2555. # Hilfsfunktion für die Umfüllaufgabe bei ADJUST-ARRAY:
  2556. # Füllt den Datenvektor eines Arrays teilweise mit dem Inhalt eines anderen
  2557. # Datenvektors, und zwar so, daß die Elemente zu Indextupeln, die für beide
  2558. # Arrays gültig sind, übereinstimmen.
  2559. # reshape(newvec,newdims,oldvec,olddims,offset,rank,eltype);
  2560. # > newvec: (semi-)simpler Vektor, in den zu füllen ist.
  2561. # > newdims: Dimension(en) des Arrays,
  2562. #            in dem newvec Datenvektor ist (mit Offset 0).
  2563. # > oldvec: (semi-)simpler Vektor, aus dem zu füllen ist.
  2564. # > olddims: Pointer auf die Dimensionen des Arrays,
  2565. #            in dem oldvec Datenvektor ist (mit Offset offset).
  2566. # > rank: Dimensionszahl von newdims = Dimensionenzahl von olddims.
  2567. # > eltype: Elementtyp von newvec = Elementtyp von oldvec.
  2568.   local void reshape (object newvec, object newdims, object oldvec, uintL* olddims, uintL offset, uintL rank, uintB eltype);
  2569.   # Methode: pseudo-rekursiv, mit Pseudo-Stack, der unterhalb von STACK liegt.
  2570.   typedef struct { uintL olddim; # Dimension aus olddims
  2571.                    uintL newdim; # Dimension aus newdims
  2572.                    uintL mindim; # minimale dieser Dimensionen
  2573.                    uintL subscript; # Subscript, läuft von 0 bis mindim-1
  2574.                    uintL oldindex; # Row-Major-Index in oldvec
  2575.                    uintL newindex; # Row-Major-Index in newvec
  2576.                    uintL olddelta; # Increment von oldindex bei subscript++
  2577.                    uintL newdelta; # Increment von newindex bei subscript++
  2578.                  }
  2579.           reshape_data;
  2580.   local void reshape(newvec,newdims,oldvec,olddims,offset,rank,eltype)
  2581.     var reg6 object newvec;
  2582.     var reg9 object newdims;
  2583.     var reg7 object oldvec;
  2584.     var reg8 uintL* olddims;
  2585.     var uintL offset;
  2586.     var reg5 uintL rank;
  2587.     var reg10 uintB eltype;
  2588.     { # Platz für den Pseudo-Stack reservieren:
  2589.       get_space_on_STACK(rank*sizeof(reshape_data));
  2590.       # Startpunkt:
  2591.      {var reg9 reshape_data* reshape_stack = &STACKblock_(reshape_data,-1);
  2592.       # Pseudo-Stack füllen:
  2593.       if (!(rank==0))
  2594.         { var reg1 reshape_data* ptr;
  2595.           var reg4 uintC count;
  2596.           # jeweils newdim einfüllen:
  2597.           ptr = reshape_stack;
  2598.           if (consp(newdims))
  2599.             { dotimespC(count,rank,
  2600.                 { ptr->newdim = posfixnum_to_L(Car(newdims)); newdims = Cdr(newdims);
  2601.                   ptr = ptr STACKop -1;
  2602.                 });
  2603.             }
  2604.             else
  2605.             { ptr->newdim = posfixnum_to_L(newdims); }
  2606.           # jeweils olddim und mindim einfüllen:
  2607.           ptr = reshape_stack;
  2608.           dotimespC(count,rank,
  2609.             { var reg2 uintL olddim;
  2610.               var reg3 uintL newdim;
  2611.               olddim = ptr->olddim = *olddims++;
  2612.               newdim = ptr->newdim;
  2613.               ptr->mindim = (olddim<newdim ? olddim : newdim);
  2614.               ptr = ptr STACKop -1;
  2615.             });
  2616.           # jeweils olddelta und newdelta einfüllen:
  2617.           { var reg2 uintL olddelta = 1;
  2618.             var reg3 uintL newdelta = 1;
  2619.             dotimespC(count,rank,
  2620.               { ptr = ptr STACKop 1;
  2621.                 ptr->olddelta = olddelta;
  2622.                 olddelta = mulu32_unchecked(olddelta,ptr->olddim);
  2623.                 ptr->newdelta = newdelta;
  2624.                 newdelta = mulu32_unchecked(newdelta,ptr->newdim);
  2625.               });
  2626.           }
  2627.         }
  2628.       # Los geht's mit der Pseudo-Rekursion:
  2629.       { var reg1 reshape_data* ptr = reshape_stack;
  2630.         var reg2 uintL oldindex = offset; # Row-Major-Index in oldvec
  2631.         var reg3 uintL newindex = 0; # Row-Major-Index in newvec
  2632.         var reg4 uintL depth = rank;
  2633.         entry: # Rekursionseinstieg
  2634.           if (depth==0)
  2635.             { # Element kopieren:
  2636.               # (setf (aref newvec newindex) (aref oldvec oldindex))
  2637.               # so kopieren, daß keine GC ausgelöst werden kann:
  2638.               if (eltype == Atype_32Bit)
  2639.                 { ((uint32*)&TheSbvector(TheArray(newvec)->data)->data[0])[newindex]
  2640.                     = ((uint32*)&TheSbvector(TheArray(oldvec)->data)->data[0])[oldindex];
  2641.                 }
  2642.                 else
  2643.                 { datenvektor_store(newvec,newindex,datenvektor_aref(oldvec,oldindex)); }
  2644.             }
  2645.             else
  2646.             { # Schleife über alle gemeinsamen Indizes:
  2647.               ptr->oldindex = oldindex; ptr->newindex = newindex;
  2648.               depth--;
  2649.               dotimesL(ptr->subscript,ptr->mindim,
  2650.                 { oldindex = ptr->oldindex; newindex = ptr->newindex;
  2651.                   ptr = ptr STACKop -1;
  2652.                   goto entry;
  2653.                   reentry:
  2654.                   ptr = ptr STACKop 1;
  2655.                   ptr->oldindex += ptr->olddelta;
  2656.                   ptr->newindex += ptr->newdelta;
  2657.                 });
  2658.               depth++;
  2659.             }
  2660.           # Rekursionsaustritt:
  2661.           if (depth<rank) goto reentry;
  2662.     }}}
  2663.  
  2664. LISPFUN(adjust_array,2,0,norest,key,6,\
  2665.         (kw(element_type),kw(initial_element),\
  2666.          kw(initial_contents),kw(fill_pointer),\
  2667.          kw(displaced_to),kw(displaced_index_offset)) )
  2668. # (ADJUST-ARRAY array dimensions :element-type :initial-element
  2669. #   :initial-contents :fill-pointer :displaced-to :displaced-index-offset),
  2670. #   CLTL S. 297
  2671.   { # array überprüfen:
  2672.     { var reg1 object array = STACK_7;
  2673.       switch (typecode(array))
  2674.         { case_array1:
  2675.           case_ostring: case_obvector: case_ovector:
  2676.             if (TheArray(array)->flags & bit(arrayflags_adjustable_bit))
  2677.               break; # adjustierbar -> OK
  2678.           case_sstring: case_sbvector: case_svector:
  2679.             # nicht adjustierbarer Array
  2680.             #ifndef X3J13_003
  2681.             pushSTACK(array);
  2682.             pushSTACK(TheSubr(subr_self)->name);
  2683.             //: DEUTSCH "~: Array ~ ist nicht adjustierbar."
  2684.             //: ENGLISH "~: array ~ is not adjustable"
  2685.             //: FRANCAIS "~: La matrice ~ n'est pas ajustable."
  2686.             fehler(error,GETTEXT("~: array ~ is not adjustable"));
  2687.             #else
  2688.             ??
  2689.             #endif
  2690.           default:
  2691.             # kein Array
  2692.             fehler_array(array);
  2693.         }
  2694.       STACK_7 = STACK_6; STACK_6 = array; # Stack etwas umordnen
  2695.     }
  2696.    # Stackaufbau:
  2697.    #   dims, array, element-type, initial-element, initial-contents,
  2698.    #   fill-pointer, displaced-to, displaced-index-offset.
  2699.    {# Dimensionen überprüfen und Rang und Total-Size berechnen:
  2700.     var uintL totalsize;
  2701.     var reg4 uintL rank = test_dims(&totalsize);
  2702.     # Rang überprüfen, muß = (array-rank array) sein:
  2703.     {var reg1 uintL oldrank = (uintL)(TheArray(STACK_6)->rank);
  2704.      if (!(rank==oldrank))
  2705.        { pushSTACK(STACK_7); # dims
  2706.          pushSTACK(STACK_(6+1)); # array
  2707.          pushSTACK(fixnum(oldrank));
  2708.          pushSTACK(TheSubr(subr_self)->name);
  2709.          //: DEUTSCH "~: Dimensionszahl ~ des Arrays ~ kann nicht geändert werden: ~"
  2710.          //: ENGLISH "~: rank ~ of array ~ cannot be altered: ~"
  2711.          //: FRANCAIS "~: Le rang ~ de la matrice ~ ne peut pas être modifié."
  2712.          fehler(error,GETTEXT("~: rank ~ of array ~ cannot be altered: ~"));
  2713.     }  }
  2714.     {# element-type in einen Code umwandeln und überprüfen:
  2715.      var reg6 uintB eltype;
  2716.      if (!(eq(STACK_5,unbound)))
  2717.        { eltype = eltype_code(STACK_5);
  2718.          # mit dem Elementtyp des Array-Arguments vergleichen:
  2719.          if (!(eltype == (TheArray(STACK_6)->flags & arrayflags_atype_mask)))
  2720.            { pushSTACK(STACK_6); # Wert für Slot DATUM von TYPE-ERROR
  2721.              pushSTACK(S(array)); pushSTACK(STACK_(5+2)); pushSTACK(listof(2)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2722.              pushSTACK(STACK_(5+2)); # element-type
  2723.              pushSTACK(STACK_(6+3)); # array
  2724.              pushSTACK(TheSubr(subr_self)->name);
  2725.              //: DEUTSCH "~: Array ~ hat nicht Elementtyp ~"
  2726.              //: ENGLISH "~: array ~ has not element-type ~"
  2727.              //: FRANCAIS "~: La matrice ~ n'as pas ~ comme type d'élément."
  2728.              fehler(type_error,GETTEXT("~: array ~ has not element-type ~"));
  2729.        }   }
  2730.        else
  2731.        { # Defaultwert ist der Elementtyp des Array-Arguments.
  2732.          eltype = (TheArray(STACK_6)->flags & arrayflags_atype_mask);
  2733.          STACK_5 = array_element_type(STACK_6);
  2734.        }
  2735.      test_otherkeys(); # einiges überprüfen
  2736.      { var reg5 uintB flags = TheArray(STACK_6)->flags;
  2737.        # Die Flags enthalten genau eltype als Atype (mit evtl.
  2738.        # arrayflags_notbytep_bit) und arrayflags_adjustable_bit und daher auch
  2739.        # arrayflags_dispoffset_bit und vielleicht auch arrayflags_fillp_bit
  2740.        # (diese werden nicht verändert) und vielleicht auch
  2741.        # arrayflags_displaced_bit (dieses kann geändert werden).
  2742.        var reg7 uintL displaced_index_offset;
  2743.        var reg9 uintL fillpointer;
  2744.        # Falls nicht displaced, Datenvektor bilden und evtl. füllen:
  2745.        if (nullp(STACK_1)) # displaced-to nicht angegeben?
  2746.          { # Datenvektor bilden:
  2747.            var reg3 object datenvektor = make_datenvektor(totalsize,eltype);
  2748.            if (!eq(STACK_3,unbound)) # und falls initial-contents angegeben:
  2749.              { # mit dem initial-contents-Argument füllen:
  2750.                datenvektor = initial_contents(datenvektor,STACK_7,rank,STACK_3);
  2751.              }
  2752.              else
  2753.              { # mit dem ursprünglichen Inhalt von array füllen:
  2754.                var reg1 object oldarray = STACK_6; # array
  2755.                var uintL oldoffset = 0;
  2756.                var reg2 object oldvec = array1_displace_check(oldarray,TheArray(oldarray)->totalsize,&oldoffset);
  2757.                # oldvec ist der Datenvektor, mit Displaced-Offset oldoffset.
  2758.                var reg2 uintL* olddimptr = &TheArray(oldarray)->dims[1];
  2759.                # Ab olddimptr kommen die alten Dimensionen von array
  2760.                # (beachte: Da arrayflags_adjustable_bit gesetzt ist, ist auch
  2761.                # arrayflags_dispoffset_bit gesetzt, also ist
  2762.                # TheArray(array)->data[0] für den Displaced-Offset reserviert.)
  2763.                reshape(datenvektor,STACK_7,oldvec,olddimptr,oldoffset,rank,eltype);
  2764.              }
  2765.            STACK_1 = datenvektor; # datenvektor als "displaced-to" ablegen
  2766.            displaced_index_offset = 0; # mit Displacement 0
  2767.            flags &= ~bit(arrayflags_displaced_bit); # und ohne Displacement-Bit in den Flags
  2768.          }
  2769.          else
  2770.          { # displaced-to angegeben.
  2771.            displaced_index_offset = test_displaced(eltype,totalsize);
  2772.            # Test auf entstehenden Zyklus:
  2773.            { var reg2 object array = STACK_6; # Array, der displaced werden soll
  2774.              var reg1 object to_array = STACK_1; # Array, auf den displaced werden soll
  2775.              # Teste, ob array in der Datenvektorenkette von to_array vorkommt:
  2776.              loop
  2777.                { # Falls array = to_array, ist ein Zyklus da.
  2778.                  if (eq(array,to_array))
  2779.                    { pushSTACK(array);
  2780.                      pushSTACK(TheSubr(subr_self)->name);
  2781.                      //: DEUTSCH "~: Array ~ kann nicht auf sich selbst displaced werden."
  2782.                      //: ENGLISH "~: cannot displace array ~ to itself"
  2783.                      //: FRANCAIS "~: La matrice ~ ne peut pas être déplacée («displaced») vers elle-même."
  2784.                      fehler(error,GETTEXT("~: cannot displace array ~ to itself"));
  2785.                    }
  2786.                  # Falls to_array simple ist (also nicht displaced),
  2787.                  # liegt kein Zyklus vor.
  2788.                  if_simplep(to_array, break; , ; );
  2789.                  # Displaced-Kette von to_array weiterverfolgen:
  2790.                  to_array = TheArray(to_array)->data;
  2791.            }   }
  2792.            # Flags enthalten das Displacement-Bit:
  2793.            flags |= bit(arrayflags_displaced_bit);
  2794.          }
  2795.        # Flags sind nun korrekt.
  2796.        # Modifiziere den gegebenen Array.
  2797.        if (!nullp(STACK_2)) # fill-pointer angegeben?
  2798.          { # array muß Fill-Pointer haben:
  2799.            if (!(TheArray(STACK_6)->flags & bit(arrayflags_fillp_bit)))
  2800.              { pushSTACK(STACK_6);
  2801.                pushSTACK(TheSubr(subr_self)->name);
  2802.                //: DEUTSCH "~: Array ~ hat keinen Fill-Pointer."
  2803.                //: ENGLISH "~: array ~ has no fill-pointer"
  2804.                //: FRANCAIS "~: La matrice ~ n'a pas de pointeur de remplissage."
  2805.                fehler(error,GETTEXT("~: array ~ has no fill-pointer"));
  2806.              }
  2807.            fillpointer = test_fillpointer(totalsize); # Fill-Pointer-Wert
  2808.          }
  2809.          else
  2810.          { # Hat array einen Fill-Pointer, so muß er <= neue Total-Size sein:
  2811.            var reg1 object array = STACK_6;
  2812.            if (TheArray(array)->flags & bit(arrayflags_fillp_bit))
  2813.              if (!(TheArray(array)->dims[2] <= totalsize))
  2814.                # dims[0] = displaced-offset, dims[1] = Länge, dims[2] = Fill-Pointer
  2815.                { pushSTACK(fixnum(totalsize));
  2816.                  pushSTACK(fixnum(TheArray(array)->dims[2]));
  2817.                  pushSTACK(array);
  2818.                  pushSTACK(TheSubr(subr_self)->name);
  2819.                  //: DEUTSCH "~: Array ~ hat einen Fill-Pointer ~ > gewünschte Länge ~."
  2820.                  //: ENGLISH "~: the fill-pointer of array ~ is ~, greater than ~"
  2821.                  //: FRANCAIS "~: La matrice ~ possède un pointeur de remplissage ~ supérieur à la longueur souhaitée ~."
  2822.                  fehler(error,GETTEXT("~: the fill-pointer of array ~ is ~, greater than ~"));
  2823.          }     }
  2824.        # Array modifizieren:
  2825.        { var reg3 object array = STACK_6;
  2826.          set_break_sem_1(); # Unterbrechungen verbieten
  2827.          TheArray(array)->flags = flags; # neue Flags eintragen
  2828.          TheArray(array)->totalsize = totalsize; # neue Total-Size eintragen
  2829.          {var reg1 uintL* dimptr = &TheArray(array)->dims[0];
  2830.           *dimptr++ = displaced_index_offset; # Displaced-Index-Offset eintragen
  2831.           # neue Dimensionen eintragen:
  2832.           { var reg2 object dims = STACK_7;
  2833.             if (listp(dims))
  2834.               { while (consp(dims))
  2835.                   { *dimptr++ = posfixnum_to_L(Car(dims)); dims = Cdr(dims); }
  2836.               }
  2837.               else
  2838.               { *dimptr++ = posfixnum_to_L(dims); }
  2839.           }
  2840.           # evtl. Fill-Pointer eintragen bzw. korrigieren:
  2841.           if (flags & bit(arrayflags_fillp_bit)) # Array mit Fill-Pointer?
  2842.             if (!nullp(STACK_2)) # und fill-pointer angegeben?
  2843.               { # fill-pointer war angegeben und /=NIL
  2844.                 *dimptr = fillpointer;
  2845.               }
  2846.          }
  2847.          # Datenvektor eintragen:
  2848.          TheArray(array)->data = STACK_1; # displaced-to-Argument oder neuer Datenvektor
  2849.          clr_break_sem_1(); # Unterbrechungen wieder zulassen
  2850.          # array als Wert:
  2851.          value1 = array; mv_count=1; skipSTACK(8);
  2852.   }}}} }
  2853.  
  2854.  
  2855. # Funktionen, die Vektoren zu Sequences machen:
  2856.  
  2857. LISPFUNN(vector_init,1)
  2858. # #'(lambda (seq) 0)
  2859.   { skipSTACK(1);
  2860.     value1 = Fixnum_0; mv_count=1; # 0 als Wert
  2861.   }
  2862.  
  2863. LISPFUNN(vector_upd,2)
  2864. # #'(lambda (seq pointer) (1+ pointer))
  2865.   { if (mposfixnump(STACK_0))
  2866.       { var reg1 object newpointer = fixnum_inc(STACK_0,1); # Fixnum >=0 um 1 erhöhen
  2867.         if (posfixnump(newpointer))
  2868.           { # ist ein Fixnum >=0 geblieben
  2869.             skipSTACK(2);
  2870.             value1 = newpointer; mv_count=1; # newpointer als Wert
  2871.             return;
  2872.       }   }
  2873.     # Pointer ist vor oder nach dem Erhöhen kein Fixnum >=0
  2874.     funcall(L(einsplus),1); # (1+ pointer) als Wert
  2875.     skipSTACK(1);
  2876.   }
  2877.  
  2878. LISPFUNN(vector_endtest,2)
  2879. # #'(lambda (seq pointer) (= pointer (vector-length seq)))
  2880.   { var reg1 object seq = STACK_1;
  2881.     if (!vectorp(seq)) { fehler_vector(seq); }
  2882.     if (eq(fixnum(vector_length(seq)),STACK_0))
  2883.       { value1 = T; mv_count=1; skipSTACK(2); } # 1 Wert T
  2884.       else
  2885.       { value1 = NIL; mv_count=1; skipSTACK(2); } # 1 Wert NIL
  2886.   }
  2887.  
  2888. LISPFUNN(vector_fe_init,1)
  2889. # #'(lambda (seq) (1- (vector-length seq)))
  2890.   { var reg1 object seq = popSTACK();
  2891.     if (!vectorp(seq)) { fehler_vector(seq); }
  2892.    {var reg2 uintL len = vector_length(seq);
  2893.     # len = (vector-length seq).
  2894.     # Als Fixnum, und um 1 erniedrigen:
  2895.     value1 = (len==0 ? Fixnum_minus1 : fixnum(len-1));
  2896.     mv_count=1;
  2897.   }}
  2898.  
  2899. LISPFUNN(vector_fe_upd,2)
  2900. # #'(lambda (seq pointer) (1- pointer))
  2901.   { if (mposfixnump(STACK_0))
  2902.       { var reg1 object pointer = popSTACK();
  2903.         value1 = (eq(pointer,Fixnum_0)
  2904.                   ? Fixnum_minus1
  2905.                   : fixnum_inc(pointer,-1) # Fixnum >0 um 1 erniedrigen
  2906.                  );
  2907.         mv_count=1;
  2908.       }
  2909.       else
  2910.       { # Pointer ist vor oder nach dem Erniedrigen kein Fixnum >=0
  2911.         funcall(L(einsminus),1); # (1- pointer) als Wert
  2912.       }
  2913.     skipSTACK(1);
  2914.   }
  2915.  
  2916. LISPFUNN(vector_fe_endtest,2)
  2917. # #'(lambda (seq pointer) (minusp pointer))
  2918.   { value1 = (mpositivep(STACK_0) ? NIL : T); # Vorzeichen von pointer abfragen
  2919.     mv_count=1;
  2920.     skipSTACK(2);
  2921.   }
  2922.  
  2923. LISPFUNN(vector_length,1)
  2924.   { var reg1 object seq = popSTACK();
  2925.     if (!vectorp(seq)) { fehler_vector(seq); }
  2926.     value1 = fixnum(vector_length(seq)); mv_count=1;
  2927.   }
  2928.  
  2929. LISPFUNN(vector_init_start,2)
  2930. # #'(lambda (seq index)
  2931. #     (if (<= 0 index (vector-length seq))
  2932. #       index
  2933. #       (error "Unzulässiger :START - Index : ~S" index)
  2934. #   ) )
  2935.   { var reg1 object seq = STACK_1;
  2936.     if (!vectorp(seq)) { fehler_vector(seq); }
  2937.    {var reg2 uintL len = vector_length(seq);
  2938.     # index sollte ein Fixnum zwischen 0 und len (inclusive) sein:
  2939.     if (mposfixnump(STACK_0) && (posfixnum_to_L(STACK_0)<=len))
  2940.       { value1 = STACK_0; mv_count=1; skipSTACK(2); } # index als Wert
  2941.       else
  2942.       { # Stackaufbau: seq, index.
  2943.         //: DEUTSCH "Unzulässiger START - Index ~ für ~"
  2944.         //: ENGLISH "Illegal START index ~ for ~"
  2945.         //: FRANCAIS "Index START ~ invalide pour ~."
  2946.         fehler(error,GETTEXT("Illegal START index ~ for ~"));
  2947.       }
  2948.   }}
  2949.  
  2950. LISPFUNN(vector_fe_init_end,2)
  2951. # #'(lambda (seq index)
  2952. #     (if (<= 0 index (vector-length seq))
  2953. #       (1- index)
  2954. #       (error "Unzulässiger :END - Index : ~S" index)
  2955. #   ) )
  2956.   { var reg1 object seq = STACK_1;
  2957.     if (!vectorp(seq)) { fehler_vector(seq); }
  2958.    {var reg2 uintL len = vector_length(seq);
  2959.     # index sollte ein Fixnum zwischen 0 und len (inclusive) sein:
  2960.     if (mposfixnump(STACK_0) && (posfixnum_to_L(STACK_0)<=len))
  2961.       { var reg2 object index = STACK_0;
  2962.         skipSTACK(2);
  2963.         value1 = (eq(index,Fixnum_0)
  2964.                   ? Fixnum_minus1
  2965.                   : fixnum_inc(index,-1) # Fixnum >0 um 1 erniedrigen
  2966.                  );
  2967.         mv_count=1;
  2968.       }
  2969.       else
  2970.       { # Stackaufbau: seq, index.
  2971.         //: DEUTSCH "Unzulässiger END - Index ~ für ~"
  2972.         //: ENGLISH "Illegal END index ~ for ~"
  2973.         //: FRANCAIS "Index END ~ invalide pour ~."
  2974.         fehler(error,GETTEXT("Illegal END index ~ for ~"));
  2975.       }
  2976.   }}
  2977.  
  2978. LISPFUNN(make_bit_vector,1)
  2979. # (SYS::MAKE-BIT-VECTOR size) liefert einen Bit-Vector mit size Bits.
  2980.   { if (!mposfixnump(STACK_0))
  2981.       { # STACK_0 = size, Wert für Slot DATUM von TYPE-ERROR
  2982.         pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2983.         pushSTACK(STACK_1); # size
  2984.         pushSTACK(TheSubr(subr_self)->name);
  2985.         //: DEUTSCH "~: Als Bit-Vektoren-Länge ist ~ ungeeignet."
  2986.         //: ENGLISH "~: invalid bit-vector length ~"
  2987.         //: FRANCAIS "~: ~ n'est pas convenable comme longeur de vecteur bit."
  2988.         fehler(type_error,GETTEXT("~: invalid bit-vector length ~"));
  2989.       }
  2990.    {var reg1 uintL size = posfixnum_to_L(popSTACK()); # Länge
  2991.     value1 = allocate_bit_vector(size); # euen Bit-Vektor beschaffen
  2992.     mv_count=1;
  2993.   }}
  2994.  
  2995.