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