home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / sequence.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  189.9 KB  |  4,116 lines
  1. # Sequences für CLISP
  2. # Bruno Haible 23.6.1995
  3.  
  4. #include "lispbibl.c"
  5.  
  6.  
  7. # O(seq_types) enthält eine Liste von Typdescriptoren für Sequences.
  8. # Das sind Simple-Vektoren der Länge 16, mit folgendem Inhalt:
  9. #  SEQ-TYPE        ; der Typ der Sequence, meist ein Symbol
  10. #  Zugriffsfunktionen:
  11. #  SEQ-INIT
  12. #  SEQ-UPD
  13. #  SEQ-ENDTEST
  14. #  SEQ-FE-INIT
  15. #  SEQ-FE-UPD
  16. #  SEQ-FE-ENDTEST
  17. #  SEQ-ACCESS
  18. #  SEQ-ACCESS-SET
  19. #  SEQ-COPY
  20. #  SEQ-LENGTH
  21. #  SEQ-MAKE
  22. #  SEQ-ELT
  23. #  SEQ-SET-ELT
  24. #  SEQ-INIT-START
  25. #  SEQ-FE-INIT-END
  26.  
  27. /*
  28.  
  29.  Erklärung der Einzelfunktionen SEQ-XXX:
  30.  
  31. Ein "Pointer" ist etwas, was durch die Sequence durchlaufen kann.
  32. Es gibt Pointer, die von links nach rechts laufen;
  33.   sie werden mit INIT oder INIT-START kreiert, mit COPY kopiert,
  34.              mit UPD um eine Stelle weitergerückt,
  35.              mit ENDTEST getestet, ob sie am Ende der Sequence angelangt sind,
  36.              mit ACCESS wird das Element, worauf der Pointer zeigt, geholt,
  37.              mit ACCESS-SET wird das Element, worauf der Pointer zeigt, gesetzt.
  38. Es gibt auch Pointer, die von rechts nach links laufen;
  39.   sie werden mit FE-INIT oder FE-INIT-END kreiert, mit COPY kopiert,
  40.              mit FE-UPD um eine Stelle nach links weitergerückt,
  41.              mit FE-ENDTEST getestet, ob sie am Ende der Sequence angelangt sind,
  42.              mit ACCESS wird das Element, worauf der Pointer zeigt, geholt.
  43.   Für sie funktioniert ACCESS-SET nicht.
  44.  
  45. Durchlaufe-Operationen:
  46. INIT          (lambda (seq) ...) -> pointer
  47.               liefert den Pointer zu SEQ, der ganz links steht.
  48. UPD           (lambda (seq pointer) ...) -> pointer
  49.               liefert zu einem Pointer den Pointer eins weiter rechts.
  50.               SEQ-UPD kann voraussetzen, daß dabei der rechte Rand von
  51.               SEQ nicht überschritten wird.
  52. ENDTEST       (lambda (seq pointer) ...) -> boolean
  53.               testet, ob dieser Pointer am rechten Rand von SEQ steht.
  54. Dasselbe "FROM END" :
  55. FE-INIT       (lambda (seq) ...) -> pointer
  56.               liefert den Pointer zu SEQ, der ganz rechts steht.
  57. FE-UPD        (lambda (seq pointer) ...) -> pointer
  58.               liefert zu einem Pointer den Pointer eins weiter links.
  59.               SEQ-FE-UPD kann voraussetzen, daß dabei der linke Rand von
  60.               SEQ nicht überschritten wird.
  61. FE-ENDTEST    (lambda (seq pointer) ...) -> boolean
  62.               testet, ob dieser Pointer am linken Rand von SEQ steht.
  63. Zugriff mit Pointer:
  64. ACCESS        (lambda (seq pointer) ...) -> value
  65.               liefert zu einem Pointer in SEQ das entsprechende Element an
  66.               dieser Stelle.
  67. ACCESS-SET    (lambda (seq pointer value) ...) ->
  68.               setzt das Element in SEQ, auf das der Pointer zeigt, auf den
  69.               gegebenen Wert. Nur bei von links nach rechts laufenden Pointern!
  70. COPY          (lambda (pointer) ...) -> pointer
  71.               liefert eine Kopie des Pointers zu SEQ (denn UPD und FE-UPD
  72.               können destruktiv auf den Pointern arbeiten)
  73. Gesamtlänge:
  74. LENGTH        (lambda (seq) ...) -> size
  75.               liefert die (aktive) Länge der Sequence SEQ.
  76. MAKE          (lambda (size) ...) -> sequence
  77.               liefert eine neu allozierte, leere Sequence, die vom Typ
  78.               SEQ-TYPE ist und die angegebene Länge hat.
  79. Zugriff über Index (meist ineffizienter als über Pointer):
  80. ELT           (lambda (seq index) ...) -> value
  81.               liefert (ELT SEQ index)
  82. SET-ELT       (lambda (seq index value) ...) ->
  83.               setzt (ELT SEQ index) auf value.
  84. INIT-START    (lambda (seq index) ...) -> pointer
  85.               liefert einen nach rechts laufenden Pointer in SEQ
  86.               ab Position index. Muß den Range-test selbst durchführen.
  87. FE-INIT-END   (lambda (seq index) ...) -> pointer
  88.               liefert einen nach links laufenden Pointer in SEQ
  89.               an Position index. Muß den Range-test selbst durchführen.
  90.  
  91. */
  92.  
  93. #define seq_type(seqdesc)         (TheSvector(seqdesc)->data[0])
  94. #define seq_init(seqdesc)         (TheSvector(seqdesc)->data[1])
  95. #define seq_upd(seqdesc)          (TheSvector(seqdesc)->data[2])
  96. #define seq_endtest(seqdesc)      (TheSvector(seqdesc)->data[3])
  97. #define seq_fe_init(seqdesc)      (TheSvector(seqdesc)->data[4])
  98. #define seq_fe_upd(seqdesc)       (TheSvector(seqdesc)->data[5])
  99. #define seq_fe_endtest(seqdesc)   (TheSvector(seqdesc)->data[6])
  100. #define seq_access(seqdesc)       (TheSvector(seqdesc)->data[7])
  101. #define seq_access_set(seqdesc)   (TheSvector(seqdesc)->data[8])
  102. #define seq_copy(seqdesc)         (TheSvector(seqdesc)->data[9])
  103. #define seq_length(seqdesc)       (TheSvector(seqdesc)->data[10])
  104. #define seq_make(seqdesc)         (TheSvector(seqdesc)->data[11])
  105. #define seq_elt(seqdesc)          (TheSvector(seqdesc)->data[12])
  106. #define seq_set_elt(seqdesc)      (TheSvector(seqdesc)->data[13])
  107. #define seq_init_start(seqdesc)   (TheSvector(seqdesc)->data[14])
  108. #define seq_fe_init_end(seqdesc)  (TheSvector(seqdesc)->data[15])
  109.  
  110. # UP: überprüft, ob name ein gültiger Sequence-Typ-Bezeichner ist
  111. # (sonst Error) und liefert den dazugehörigen Typdescriptor.
  112. # valid_type(name)
  113. # > name: Sequence-Typ-Bezeichner
  114. # < ergebnis: dazugehöriger Typdescriptor
  115. # kann GC auslösen
  116.   local object valid_type (object name);
  117.   local object valid_type(name)
  118.     var reg2 object name;
  119.     { # Unsere elementaren Sequence-Typen sind LIST, VECTOR, STRING, BIT-VECTOR.
  120.       # Wir erkennen aber auch gewisse Alias-Namen:
  121.       # - DEFTYPE-defininierte Typen werden expandiert.
  122.       # - ([SIMPLE-]ARRAY [eltype [(dim)]]), (VECTOR [eltype [size]]) ergeben
  123.       #   STRING falls eltype = STRING-CHAR,
  124.       #   BIT-VECTOR falls eltype = BIT,
  125.       #   n [steht für (VECTOR (UNSIGNED-BYTE n))] falls eltype = n BIT,
  126.       #   VECTOR sonst.
  127.       # - (SIMPLE-VECTOR [size]), VECTOR, SIMPLE-VECTOR ergeben VECTOR.
  128.       # - ([SIMPLE-]STRING [size]), [SIMPLE-]STRING ergeben STRING.
  129.       # - ([SIMPLE-]BIT-VECTOR [size]), [SIMPLE-]BIT-VECTOR ergeben BIT-VECTOR.
  130.       # - Zusätzlich (nicht sehr schön): [SIMPLE-]ARRAY ergibt VECTOR.
  131.       reexpand:
  132.       if (symbolp(name))
  133.         { if (eq(name,S(list))) { goto expanded; }
  134.           if (eq(name,S(vector))) { goto expanded; }
  135.           if (eq(name,S(simple_vector))) { name = S(vector); goto expanded; }
  136.           if (eq(name,S(string))) { goto expanded; }
  137.           if (eq(name,S(simple_string))) { name = S(string); goto expanded; }
  138.           if (eq(name,S(bit_vector))) { goto expanded; }
  139.           if (eq(name,S(simple_bit_vector))) { name = S(bit_vector); goto expanded; }
  140.           if (eq(name,S(array)) || eq(name,S(simple_array))) { name = S(vector); goto expanded; }
  141.           # evtl. (get name 'DEFTYPE-EXPANDER) mit Argument (list name) aufrufen:
  142.           {var reg1 object expander = get(name,S(deftype_expander));
  143.            if (!eq(expander,unbound))
  144.              { pushSTACK(expander);
  145.                pushSTACK(name); name = allocate_cons(); Car(name) = popSTACK(); # (list name)
  146.                expander = STACK_0; STACK_0 = name;
  147.                funcall(expander,1); # Expander aufrufen
  148.                name = value1; goto reexpand; # Ergebnis weiterverwenden
  149.           } }
  150.           goto expanded; # sonstige Symbole können DEFSTRUCT-Typen sein
  151.         }
  152.       elif (consp(name))
  153.         { var reg1 object name1 = Car(name);
  154.           if (symbolp(name1))
  155.             { if (nullp(Cdr(name)) || (mconsp(Cdr(name)) && nullp(Cdr(Cdr(name)))))
  156.                 { if (eq(name1,S(simple_vector))) { name = S(vector); goto expanded; }
  157.                   if (eq(name1,S(string)) || eq(name1,S(simple_string))) { name = S(string); goto expanded; }
  158.                   if (eq(name1,S(bit_vector)) || eq(name1,S(simple_bit_vector))) { name = S(bit_vector); goto expanded; }
  159.                 }
  160.              {var reg3 object name2;
  161.               var reg4 object name3;
  162.               if (nullp(name2=Cdr(name))) { name2 = S(mal); name3 = S(mal); goto try_vector; }
  163.               if (consp(name2))
  164.                 { name3=Cdr(name2); name2 = Car(name2);
  165.                   if (nullp(name3)) { name3 = S(mal); goto try_vector; }
  166.                   if (consp(name3) && nullp(Cdr(name3)))
  167.                     { name3 = Car(name3); goto try_vector; }
  168.                 }
  169.               if (FALSE)
  170.                 { try_vector: # Hier ist name2 = (second name), name3 = (third name), Defaults: *
  171.                   if (eq(name1,S(vector))
  172.                       || (   (eq(name1,S(array)) || eq(name1,S(simple_array)))
  173.                           && (eq(name3,S(mal)) || (consp(name3) && nullp(Cdr(name3))))
  174.                      )   )
  175.                     { var reg3 uintB atype = eltype_code(name2);
  176.                       if (atype==Atype_T) { name = S(vector); goto expanded; } # (VECTOR T)
  177.                       elif (atype==Atype_String_Char) { name = S(string); goto expanded; } # (VECTOR STRING-CHAR)
  178.                       elif (atype==Atype_Bit) { name = S(bit_vector); goto expanded; } # (VECTOR BIT)
  179.                       else { name = fixnum(bit(atype)); goto expanded; } # (VECTOR (UNSIGNED-BYTE n))
  180.              }  }   }
  181.               # evtl. (get name1 'DEFTYPE-EXPANDER) mit Argument name aufrufen:
  182.              {var reg3 object expander = get(name1,S(deftype_expander));
  183.               if (!eq(expander,unbound))
  184.                 { pushSTACK(name); funcall(expander,1); # Expander aufrufen
  185.                   name = value1; goto reexpand; # Ergebnis weiterverwenden
  186.         }   }} }
  187.       goto bad_name;
  188.       expanded:
  189.       # SEQ-TYPES-Liste durchgehen:
  190.       { var reg1 object list = O(seq_types);
  191.         while (consp(list))
  192.           { var reg2 object typdescr = Car(list);
  193.             if (eq(name,seq_type(typdescr))) { return typdescr; }
  194.             list = Cdr(list);
  195.       }   }
  196.       bad_name:
  197.       pushSTACK(name);
  198.       //: DEUTSCH "Es gibt keine Sequences vom Typ ~."
  199.       //: ENGLISH "There are no sequences of type ~"
  200.       //: FRANCAIS "Il n'existe pas de séquences de type ~."
  201.       fehler(error, GETTEXT("There are no sequences of type ~"));
  202.     }
  203.  
  204. # UP: liefert den Typdescriptor einer Sequence
  205. # get_seq_type(seq)
  206. # > seq: eine Sequence
  207. # < ergebnis: Typdescriptor oder NIL
  208.   local object get_seq_type (object seq);
  209.   local object get_seq_type(seq)
  210.     var reg2 object seq;
  211.     { var reg3 object name;
  212.       if (listp(seq)) { name = S(list); } # Typ LIST
  213.       elif (stringp(seq)) { name = S(string); } # Typ STRING
  214.       elif (bit_vector_p(seq)) { name = S(bit_vector); } # Typ BIT-VECTOR
  215.       elif ((typecode(seq)&~imm_array_mask)==bvector_type) # Typ n, bedeutet (VECTOR (UNSIGNED-BYTE n))
  216.         { name = fixnum(bit(TheArray(seq)->flags & arrayflags_atype_mask)); }
  217.       elif (vectorp(seq)) { name = S(vector); } # Typ [GENERAL-]VECTOR
  218.       elif (structurep(seq))
  219.         { name = TheStructure(seq)->structure_types; # Structure-Typen-List*e
  220.           while (consp(name)) { name = Cdr(name); } # davon den letzten Typ nehmen
  221.         }
  222.       else return NIL;
  223.       # SEQ-TYPES-Liste durchgehen:
  224.       { var reg1 object list = O(seq_types);
  225.         while (consp(list))
  226.           { var reg2 object typdescr = Car(list);
  227.             if (eq(name,seq_type(typdescr))) { return typdescr; }
  228.             list = Cdr(list);
  229.           }
  230.         return NIL;
  231.     } }
  232.  
  233. # UP: liefert den Typdescriptor einer Sequence, evtl. Fehlermeldung
  234. # get_valid_seq_type(seq)
  235. # > seq: eine Sequence
  236. # < ergebnis: Typdescriptor
  237.   local object get_valid_seq_type (object seq);
  238.   local object get_valid_seq_type(seq)
  239.     var reg2 object seq;
  240.     { var reg1 object typdescr = get_seq_type(seq); # Typdescriptor bestimmen
  241.       if (!(nullp(typdescr))) { return typdescr; } # gefunden -> OK
  242.       # sonst Fehler melden:
  243.       pushSTACK(seq); # Wert für Slot DATUM von TYPE-ERROR
  244.       pushSTACK(S(sequence)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  245.       pushSTACK(seq);
  246.       //: DEUTSCH "Das ist keine Sequence: ~"
  247.       //: ENGLISH "~ is not a sequence"
  248.       //: FRANCAIS "~ n'est pas une séquence."
  249.       fehler(type_error, GETTEXT("~ is not a sequence"));
  250.     }
  251.  
  252. # Fehler, wenn Argument kein Integer >=0
  253.   nonreturning_function(local, fehler_posint, (object fun, object kw, object obj));
  254.   local void fehler_posint(fun,kw,obj)
  255.     var reg3 object fun;
  256.     var reg2 object kw;
  257.     var reg1 object obj;
  258.     { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  259.       pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  260.       pushSTACK(obj);
  261.       pushSTACK(kw);
  262.       pushSTACK(fun);
  263.       //: DEUTSCH "~: ~ muß ein Integer >=0 sein, nicht ~"
  264.       //: ENGLISH "~: ~ should be an integer >=0, not ~"
  265.       //: FRANCAIS "~ : ~ doit être un entier positif ou zéro et non ~"
  266.       fehler(type_error, GETTEXT("~: ~ should be an integer >=0, not ~"));
  267.     }
  268.  
  269. # Macro: Trägt NIL als Defaultwert eines Parameters in den Stack ein:
  270. # default_NIL(par);
  271.   #define default_NIL(par)  \
  272.     if (eq(par,unbound)) { par = NIL; }
  273.  
  274. # Macro: Trägt 0 als Defaultwert von START in den Stack ein:
  275. # start_default_0(start);
  276.   #define start_default_0(start)  \
  277.     if (eq(start,unbound)) { start = Fixnum_0; }
  278.  
  279. # Macro: Trägt (SEQ-LENGTH sequence) als Defaultwert von END in den Stack ein:
  280. # end_default_len(end,seq,typdescr);
  281. # kann GC auslösen
  282.   #define end_default_len(end,seq,typdescr)  \
  283.     if (eq(end,unbound) || eq(end,NIL))                   \
  284.       { var object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet! \
  285.         var reg1 object lengthfun = seq_length(typdescr); \
  286.         pushSTACK(seq); funcall(lengthfun,1);             \
  287.         end = value1;                                     \
  288.         subr_self = old_subr_self;                        \
  289.       }
  290.  
  291. # UP: Überprüft START- und END- Argumente
  292. # > subr_self: Aufrufer (ein SUBR)
  293. # > kwptr: kwptr[0] = START-Keyword,
  294. #          kwptr[1] = END-Keyword
  295. # > argptr: *(argptr STACKop 1) = START-Argument,
  296. #           *(argptr STACKop 0) = END-Argument
  297.   local void test_start_end (object* kwptr, object* argptr);
  298.   local void test_start_end(kwptr,argptr)
  299.     var reg4 object* kwptr;
  300.     var reg3 object* argptr;
  301.     { # START-Argument muß ein Integer >= 0 sein:
  302.       var reg2 object start = *(argptr STACKop 1);
  303.       if (!(integerp(start) && positivep(start)))
  304.         { fehler_posint(TheSubr(subr_self)->name,kwptr[0],start); }
  305.       # END-Argument muß ein Integer >= 0 sein:
  306.      {var reg1 object end = *(argptr STACKop 0);
  307.       if (!(integerp(end) && positivep(end)))
  308.         { fehler_posint(TheSubr(subr_self)->name,kwptr[1],end); }
  309.       # Argumente vergleichen:
  310.       if (!(I_I_comp(end,start)>=0)) # end >= start ?
  311.         { # nein -> Fehler melden:
  312.           pushSTACK(end); pushSTACK(kwptr[1]);
  313.           pushSTACK(start); pushSTACK(kwptr[0]);
  314.           pushSTACK(TheSubr(subr_self)->name);
  315.           //: DEUTSCH "~: ~ = ~ darf ~ = ~ nicht übersteigen."
  316.           //: ENGLISH "~: ~ = ~ should not be greater than ~ = ~"
  317.           //: FRANCAIS "~ : ~ = ~ ne doit pas excéder ~ = ~."
  318.           fehler(error, GETTEXT("~: ~ = ~ should not be greater than ~ = ~"));
  319.         }
  320.     }}
  321.  
  322. # UP: Überprüft START- und END- Argumente (END-Argument evtl. NIL)
  323. # > subr_self: Aufrufer (ein SUBR)
  324. # > kwptr: kwptr[0] = START-Keyword,
  325. #          kwptr[1] = END-Keyword
  326. # > argptr: *(argptr STACKop 1) = START-Argument,
  327. #           *(argptr STACKop 0) = END-Argument
  328.   local void test_start_end_1 (object* kwptr, object* argptr);
  329.   local void test_start_end_1(kwptr,argptr)
  330.     var reg4 object* kwptr;
  331.     var reg3 object* argptr;
  332.     { # START-Argument muß ein Integer >= 0 sein:
  333.       var reg2 object start = *(argptr STACKop 1);
  334.       if (!(integerp(start) && positivep(start)))
  335.         { fehler_posint(TheSubr(subr_self)->name,kwptr[0],start); }
  336.       # END-Argument muß NIL oder ein Integer >= 0 sein:
  337.      {var reg1 object end = *(argptr STACKop 0);
  338.       if (nullp(end)) { return; } # end=NIL -> OK, fertig
  339.       if (!(integerp(end) && positivep(end)))
  340.         { fehler_posint(TheSubr(subr_self)->name,kwptr[1],end); }
  341.       # Argumente vergleichen:
  342.       if (!(I_I_comp(end,start)>=0)) # end >= start ?
  343.         { # nein -> Fehler melden:
  344.           pushSTACK(end); pushSTACK(kwptr[1]);
  345.           pushSTACK(start); pushSTACK(kwptr[0]);
  346.           pushSTACK(TheSubr(subr_self)->name);
  347.           //: DEUTSCH "~: ~ = ~ darf ~ = ~ nicht übersteigen."
  348.           //: ENGLISH "~: ~ = ~ should not be greater than ~ = ~"
  349.           //: FRANCAIS "~ : ~ = ~ ne doit pas excéder ~ = ~."
  350.           fehler(error, GETTEXT("~: ~ = ~ should not be greater than ~ = ~"));
  351.         }
  352.     }}
  353.  
  354. # Macro: Incrementiert eine Integer-Variable (im Stack).
  355. # increment(var)
  356. # > var: alter Wert
  357. # < var: neuer Wert
  358. # < ergebnis: neuer Wert
  359. # kann GC auslösen
  360.   #define increment(var)  (var = I_1_plus_I(var)) # var := (1+ var)
  361.  
  362. # Macro: Decrementiert eine Integer-Variable (im Stack).
  363. # decrement(var)
  364. # > var: alter Wert
  365. # < var: neuer Wert
  366. # < ergebnis: neuer Wert
  367. # kann GC auslösen
  368.   #define decrement(var)  (var = I_minus1_plus_I(var)) # var := (1- var)
  369.  
  370. # Macro: Rückt einen Vorwärts-Pointer (im Stack) weiter.
  371. # pointer_update(pointer,sequence,typdescr);
  372. # pointer muß von der Form STACK_i sein!
  373. # kann GC auslösen
  374.   #define pointer_update(pointer,sequence,typdescr)  \
  375.     { var reg1 object updatefun = seq_upd(typdescr);     \
  376.       pushSTACK(sequence); # sequence                    \
  377.       pushSTACK(*(&(pointer) STACKop 1)); # pointer      \
  378.       funcall(updatefun,2); # (SEQ-UPD sequence pointer) \
  379.       pointer = value1; # =: pointer                     \
  380.     }
  381.  
  382. # Macro: Rückt einen Rückwärts-Pointer (im Stack) weiter.
  383. # pointer_fe_update(pointer,sequence,typdescr);
  384. # pointer muß von der Form STACK_i sein!
  385. # kann GC auslösen
  386.   #define pointer_fe_update(pointer,sequence,typdescr)  \
  387.     { var reg1 object updatefun = seq_fe_upd(typdescr);     \
  388.       pushSTACK(sequence); # sequence                       \
  389.       pushSTACK(*(&(pointer) STACKop 1)); # pointer         \
  390.       funcall(updatefun,2); # (SEQ-FE-UPD sequence pointer) \
  391.       pointer = value1; # =: pointer                        \
  392.     }
  393.  
  394. # UP: kopiert einen Teil einer Sequence in eine andere Sequence.
  395. # > STACK_6: sequence1
  396. # > STACK_5: typdescr1
  397. # > STACK_4: sequence2
  398. # > STACK_3: typdescr2
  399. # > STACK_2: count (ein Integer >=0)
  400. # > STACK_1: pointer1
  401. # > STACK_0: pointer2
  402. # kopiert count Elemente von sequence1 nach sequence2 und rückt dabei
  403. # pointer1 und pointer2 um count Stellen weiter (mit SEQ-UPD), setzt count:=0.
  404. # kann GC auslösen
  405.   local void copy_seqpart_into (void);
  406.   local void copy_seqpart_into()
  407.     { # Methode etwa so:
  408.       # (loop
  409.       #   (when (zerop count) (return))
  410.       #   (SEQ2-ACCESS-SET sequence2 pointer2 (SEQ1-ACCESS sequence1 pointer1))
  411.       #   (setq pointer1 (SEQ1-UPD pointer1))
  412.       #   (setq pointer2 (SEQ2-UPD pointer2))
  413.       #   (decf count)
  414.       # )
  415.       until (eq(STACK_2,Fixnum_0)) # count (ein Integer) = 0 -> Ende
  416.         { # (SEQ1-ACCESS seq1 pointer1) bilden:
  417.           pushSTACK(STACK_(6+0)); # seq1
  418.           pushSTACK(STACK_(1+1)); # pointer1
  419.           funcall(seq_access(STACK_(5+2)),2);
  420.           # (SEQ2-ACCESS-SET seq2 pointer2 ...) ausführen:
  421.           pushSTACK(STACK_(4+0)); # seq2
  422.           pushSTACK(STACK_(0+1)); # pointer2
  423.           pushSTACK(value1);
  424.           funcall(seq_access_set(STACK_(3+3)),3);
  425.           # pointer1 := (SEQ1-UPD seq1 pointer1) :
  426.           pointer_update(STACK_1,STACK_6,STACK_5);
  427.           # pointer2 := (SEQ2-UPD seq2 pointer2) :
  428.           pointer_update(STACK_0,STACK_4,STACK_3);
  429.           # count := (1- count) :
  430.           decrement(STACK_2);
  431.         }
  432.     }
  433.  
  434. LISPFUNN(sequencep,1)
  435. # (SYS::SEQUENCEP object) testet, ob object eine Sequence ist.
  436.   { var reg1 object typdescr = get_seq_type(popSTACK()); # Typdescriptor oder NIL
  437.     value1 = (!(nullp(typdescr)) ? T : NIL); mv_count=1;
  438.   }
  439.  
  440. LISPFUNN(defseq,1)
  441. # (SYSTEM::%DEFSEQ typdescr) erweitert die Liste der Sequencetypen um
  442. # typdescr (muß ein Simple-Vector der Länge 16 sein).
  443.   { # (list typdescr) bilden:
  444.     var reg1 object new_cons = allocate_cons();
  445.     Car(new_cons) = STACK_0;
  446.     # (nconc SEQ_TYPES (list typdescr)) bilden:
  447.     Cdr(new_cons) = nreverse(O(seq_types)); # (nreverse SEQ_TYPES)
  448.     O(seq_types) = nreverse(new_cons);
  449.     # Typ (als Symbol) zurück:
  450.     value1 = seq_type(popSTACK()); mv_count=1;
  451.   }
  452.  
  453. LISPFUNN(elt,2) # (ELT sequence index), CLTL S. 248
  454.   { # sequence überprüfen:
  455.     var reg1 object typdescr = get_valid_seq_type(STACK_1);
  456.     # index überprüfen:
  457.     if (!(mposfixnump(STACK_0)))
  458.       { pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  459.         pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  460.         pushSTACK(STACK_(0+2)); pushSTACK(S(elt));
  461.         //: DEUTSCH "~: Der Index muß ein Fixnum >=0 sein, nicht ~"
  462.         //: ENGLISH "~: the index should be a fixnum >=0, not ~"
  463.         //: FRANCAIS "~ : L'index doit être de type FIXNUM positif ou zéro et non ~"
  464.         fehler(type_error, GETTEXT("~: the index should be a fixnum >=0, not ~"));
  465.       }
  466.     # SEQ-ELT aufrufen:
  467.     funcall(seq_elt(typdescr),2); # (SEQ-ELT sequence index)
  468.     # value1 als Wert
  469.   }
  470.  
  471. LISPFUNN(setelt,3) # (SYSTEM::%SETELT sequence index value), vgl. CLTL S. 248
  472.   { # sequence überprüfen:
  473.     var reg1 object typdescr = get_valid_seq_type(STACK_2);
  474.     # index überprüfen:
  475.     if (!(mposfixnump(STACK_1)))
  476.       { pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  477.         pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  478.         pushSTACK(STACK_(1+2)); pushSTACK(S(elt)); pushSTACK(S(setf));
  479.         //: DEUTSCH "~ ~: Der Index muß ein Fixnum >=0 sein, nicht ~"
  480.         //: ENGLISH "~ ~: the index should be a fixnum >=0, not ~"
  481.         //: FRANCAIS "~ ~ : L'index doit être de type FIXNUM positif ou zéro et non ~"
  482.         fehler(type_error, GETTEXT("~ ~: the index should be a fixnum >=0, not ~"));
  483.       }
  484.     # SEQ-SET-ELT aufrufen:
  485.     pushSTACK(STACK_(2+0)); # sequence
  486.     pushSTACK(STACK_(1+1)); # index
  487.     pushSTACK(STACK_(0+2)); # value
  488.     funcall(seq_set_elt(typdescr),3); # (SEQ-SET-ELT sequence index value)
  489.     value1 = popSTACK(); mv_count=1; # value als Wert
  490.     skipSTACK(2);
  491.   }
  492.  
  493. # UP: Kopiert ein sequence1 - Teilstück in sequence2 hinein
  494. # und liefert sequence2 als Wert.
  495. # copy_seqpart_onto()
  496. # > Stackaufbau: seq1, typdescr1, seq2, typdescr2, count, pointer1
  497. # < STACK: aufgeräumt
  498. # < Wert: gefüllte seq2
  499.   local Values copy_seqpart_onto (void);
  500.   local Values copy_seqpart_onto()
  501.     { # Stackaufbau: seq1, typdescr1, seq2, typdescr2, count, pointer1.
  502.       pushSTACK(STACK_3); funcall(seq_init(STACK_(2+1)),1); # (SEQ2-INIT seq2)
  503.       pushSTACK(value1);
  504.       # Stackaufbau: seq1, typdescr1, seq2, typdescr2, count, pointer1, pointer2.
  505.       copy_seqpart_into(); # Teilstück von seq1 nach seq2 kopieren
  506.       value1 = STACK_4; mv_count=1; # seq2 als Wert
  507.       skipSTACK(7);
  508.     }
  509.  
  510. # UP: Liefert ein neu alloziertes sequence-Teilstück als Wert.
  511. # subseq()
  512. # > Stackaufbau: sequence, start, end, typdescr,
  513. #   mit überprüften Argumenten (start,end Integers >=0, start<=end)
  514. # < STACK: aufgeräumt
  515. # < Wert: Kopie des angegebenen Teilstücks von sequence
  516.   local Values subseq (void);
  517.   local Values subseq()
  518.     { STACK_1 = I_I_minus_I(STACK_1,STACK_2); # count := (- end start)
  519.       # Stackaufbau: sequence, start, count, typdescr.
  520.       pushSTACK(STACK_1); funcall(seq_make(STACK_(0+1)),1); # (SEQ-MAKE count)
  521.      {var reg3 object start = STACK_2;
  522.       var reg2 object typdescr = STACK_0;
  523.       STACK_2 = typdescr;
  524.       pushSTACK(STACK_1);
  525.       STACK_2 = value1;
  526.       # Stackaufbau: sequence, typdescr, seq2, typdescr, count.
  527.       pushSTACK(STACK_4); pushSTACK(start); funcall(seq_init_start(typdescr),2);
  528.       pushSTACK(value1); # (SEQ-INIT-START sequence start)
  529.       # Stackaufbau; seq1, typdescr, seq2, typdescr, count, pointer1.
  530.       return_Values copy_seqpart_onto(); # kopieren, seq2 als Wert
  531.     }}
  532.  
  533. LISPFUN(subseq,2,1,norest,nokey,0,NIL)
  534. # (SUBSEQ sequence start &optional end), CLTL S. 248
  535.   { # Stackaufbau: sequence, start, end.
  536.     # sequence überprüfen:
  537.     var reg1 object typdescr = get_valid_seq_type(STACK_2);
  538.     pushSTACK(typdescr);
  539.     # Stackaufbau: sequence, start, end, typdescr.
  540.     # Defaultwert für end ist (length sequence):
  541.     if (eq(STACK_1,unbound)
  542.         #ifdef X3J13_149
  543.         || nullp(STACK_1)
  544.         #endif
  545.        )
  546.       { var reg3 object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet!
  547.         # end nicht angegeben -> muß end:=(length sequence) setzen:
  548.         pushSTACK(STACK_3); funcall(seq_length(typdescr),1); # (SEQ-LENGTH sequence)
  549.         STACK_1 = value1;
  550.         subr_self = old_subr_self;
  551.       }
  552.     # Stackaufbau: sequence, start, end, typdescr.
  553.     # Start- und End-Argumente überprüfen:
  554.     test_start_end(&O(kwpair_start),&STACK_1);
  555.     # Teilstück bilden:
  556.     return_Values subseq();
  557.   }
  558.  
  559. # UP: Kopiert sequence1 in sequence2 hinein und liefert sequence2 als Wert.
  560. # copy_seq_onto()
  561. # > Stackaufbau: seq1, typdescr1, seq2, typdescr2, len
  562. # < STACK: aufgeräumt
  563. # < Wert: gefüllte seq2
  564.   local Values copy_seq_onto (void);
  565.   local Values copy_seq_onto()
  566.     { # Stackaufbau: seq1, typdescr1, seq2, typdescr2, len.
  567.       pushSTACK(STACK_4); funcall(seq_init(STACK_(3+1)),1); # (SEQ1-INIT seq1)
  568.       pushSTACK(value1);
  569.       # Stackaufbau: seq1, typdescr1, seq2, typdescr2, len, pointer1.
  570.       return_Values copy_seqpart_onto();
  571.     }
  572.  
  573. LISPFUNN(copy_seq,1) # (COPY-SEQ sequence), CLTL S. 248
  574.   { # Stackaufbau: sequence.
  575.     # sequence überprüfen:
  576.     var reg1 object typdescr = get_valid_seq_type(STACK_0);
  577.     pushSTACK(typdescr);
  578.     # Stackaufbau: sequence, typdescr.
  579.     pushSTACK(STACK_1); funcall(seq_length(typdescr),1);
  580.     pushSTACK(value1); # (SEQ-LENGTH sequence)
  581.     # Stackaufbau: sequence, typdescr, len.
  582.     pushSTACK(STACK_0); funcall(seq_make(STACK_(1+1)),1); # (SEQ-MAKE len)
  583.     pushSTACK(STACK_1); pushSTACK(STACK_(0+1)); STACK_2 = value1;
  584.     # Stackaufbau: seq1, typdescr, seq2, typdescr, len.
  585.     return_Values copy_seq_onto();
  586.   }
  587.  
  588. LISPFUNN(length,1) # (LENGTH sequence), CLTL S. 248
  589.   { var reg1 object arg = popSTACK();
  590.     if (consp(arg))
  591.       { # arg ist ein Cons
  592.         value1 = fixnum(llength(arg)); # Listenlänge als Fixnum
  593.         mv_count=1;
  594.         return;
  595.       }
  596.     elif (symbolp(arg))
  597.       { # arg ist ein Symbol
  598.         if (nullp(arg))
  599.           { value1 = Fixnum_0; mv_count=1; # NIL hat als Liste die Länge 0
  600.             return;
  601.       }   } # sonstige Symbole sind keine Sequences
  602.     elif (vectorp(arg))
  603.       { # arg ist ein Vektor
  604.         value1 = fixnum(vector_length(arg)); # Vektorlänge als Fixnum
  605.         mv_count=1;
  606.         return;
  607.       }
  608.     else
  609.       { # arg ist weder eine Liste noch ein Vektor
  610.         var reg2 object typdescr = get_valid_seq_type(arg); # hier evtl. Fehlermeldung
  611.         # sonstige Sequences:
  612.         pushSTACK(arg); funcall(seq_length(typdescr),1); # (SEQ-LENGTH arg) aufrufen
  613.         return;
  614.       }
  615.     # arg ist keine Sequence
  616.     pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  617.     pushSTACK(S(sequence)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  618.     pushSTACK(arg); pushSTACK(S(length));
  619.     //: DEUTSCH "~: ~ ist keine Sequence."
  620.     //: ENGLISH "~: ~ is not a sequence"
  621.     //: FRANCAIS "~ : ~ n'est pas une séquence."
  622.     fehler(type_error, GETTEXT("~: ~ is not a sequence"));
  623.   }
  624.  
  625. LISPFUNN(reverse,1) # (REVERSE sequence), CLTL S. 248
  626.   { var reg1 object arg = STACK_0;
  627.     if (listp(arg))
  628.       { # arg ist eine Liste
  629.         value1 = reverse(arg); mv_count=1; skipSTACK(1);
  630.       }
  631.       else
  632.       { var reg2 object typdescr = get_valid_seq_type(arg);
  633.         # arg ist eine sonstige Sequence
  634.         pushSTACK(typdescr);
  635.         # Stackaufbau: seq1, typdescr.
  636.         pushSTACK(arg); funcall(seq_length(typdescr),1); # (SEQ-LENGTH seq1)
  637.         pushSTACK(value1);
  638.         # Stackaufbau: seq1, typdescr, len.
  639.         pushSTACK(STACK_0); funcall(seq_make(STACK_(1+1)),1); # (SEQ-MAKE len)
  640.         pushSTACK(value1);
  641.         # Stackaufbau: seq1, typdescr, count, seq2.
  642.         pushSTACK(STACK_3); funcall(seq_fe_init(STACK_(2+1)),1); # (SEQ-FE-INIT seq1)
  643.         pushSTACK(value1);
  644.         # Stackaufbau: seq1, typdescr, count, seq2, pointer1.
  645.         pushSTACK(STACK_1); funcall(seq_init(STACK_(3+1)),1); # (SEQ-INIT seq2)
  646.         pushSTACK(value1);
  647.         # Stackaufbau: seq1, typdescr, count, seq2, pointer1, pointer2.
  648.         until (eq(STACK_3,Fixnum_0)) # count (ein Integer) = 0 -> Ende
  649.           { # (SEQ-ACCESS seq1 pointer1) bilden:
  650.             pushSTACK(STACK_5); pushSTACK(STACK_(1+1));
  651.             funcall(seq_access(STACK_(4+2)),2); # (SEQ-ACCESS seq1 pointer1)
  652.             # (SEQ-ACCESS-SET seq2 pointer2 ...) ausführen:
  653.             pushSTACK(STACK_2); pushSTACK(STACK_(0+1)); pushSTACK(value1);
  654.             funcall(seq_access_set(STACK_(4+3)),3); # (SEQ-ACCESS-SET seq2 pointer2 ...)
  655.             # pointer1 := (SEQ-FE-UPD seq1 pointer1) :
  656.             pointer_fe_update(STACK_1,STACK_5,STACK_4);
  657.             # pointer2 := (SEQ-UPD seq2 pointer2) :
  658.             pointer_update(STACK_0,STACK_2,STACK_4);
  659.             # count := (1- count) :
  660.             decrement(STACK_3);
  661.           }
  662.         value1 = STACK_2; mv_count=1; # seq2 als Wert
  663.         skipSTACK(6);
  664.   }   }
  665.  
  666. LISPFUNN(nreverse,1) # (NREVERSE sequence), CLTL S. 248
  667.   { var reg1 object seq = STACK_0;
  668.     if (listp(seq))
  669.       { # seq ist eine Liste
  670.         value1 = nreverse(seq); mv_count=1;
  671.         skipSTACK(1);
  672.       }
  673.     elif (vectorp(seq))
  674.       { # seq ist ein Vektor
  675.         var reg2 object typdescr = get_valid_seq_type(seq);
  676.         pushSTACK(typdescr);
  677.         # Stackaufbau: seq, typdescr.
  678.         pushSTACK(seq); funcall(seq_length(typdescr),1); # (SEQ-LENGTH seq)
  679.         { var reg3 object len = value1;
  680.           var reg4 object len2 = I_I_ash_I(len,Fixnum_minus1);
  681.           pushSTACK(len2); # (ASH len -1) = (FLOOR len 2)
  682.         }
  683.         # Stackaufbau: seq, typdescr, count.
  684.         pushSTACK(STACK_2); funcall(seq_init(STACK_(1+1)),1); # (SEQ-INIT seq)
  685.         pushSTACK(value1);
  686.         # Stackaufbau: seq, typdescr, count, pointer1.
  687.         pushSTACK(STACK_3); funcall(seq_fe_init(STACK_(2+1)),1); # (SEQ-FE-INIT seq)
  688.         pushSTACK(value1);
  689.         # Stackaufbau: seq, typdescr, count, pointer1, pointer2.
  690.         until (eq(STACK_2,Fixnum_0)) # count (ein Integer) = 0 -> Ende
  691.           { # (SEQ-ACCESS seq pointer1) bilden:
  692.             pushSTACK(STACK_4); pushSTACK(STACK_(1+1));
  693.             funcall(seq_access(STACK_(3+2)),2); # (SEQ-ACCESS seq pointer1)
  694.             pushSTACK(value1); # und retten
  695.             # (SEQ-ACCESS seq pointer2) bilden:
  696.             pushSTACK(STACK_(4+1)); pushSTACK(STACK_(0+1+1));
  697.             funcall(seq_access(STACK_(3+1+2)),2); # (SEQ-ACCESS seq pointer2)
  698.             # (SEQ-ACCESS-SET seq pointer1 ...) ausführen:
  699.             pushSTACK(STACK_(4+1)); pushSTACK(STACK_(1+1+1)); pushSTACK(value1);
  700.             funcall(seq_access_set(STACK_(3+1+3)),3); # (SEQ-ACCESS-SET seq pointer1 ...)
  701.             # (SEQ-ACCESS-SET seq pointer2 ...) ausführen:
  702.            {var reg1 object element1 = popSTACK(); # gerettetes ELement
  703.             pushSTACK(STACK_4); pushSTACK(STACK_(0+1)); pushSTACK(element1); }
  704.             funcall(seq_access_set(STACK_(3+3)),3); # (SEQ-ACCESS-SET seq pointer2 ...)
  705.             # pointer1 := (SEQ-UPD seq pointer1) :
  706.             pointer_update(STACK_1,STACK_4,STACK_3);
  707.             # pointer2 := (SEQ-FE-UPD seq pointer2) :
  708.             pointer_fe_update(STACK_0,STACK_4,STACK_3);
  709.             # count := (1- count) :
  710.             decrement(STACK_2);
  711.           }
  712.         skipSTACK(4);
  713.         value1 = popSTACK(); mv_count=1; # modifizierte seq als Wert
  714.       }
  715.     else
  716.       { var reg2 object typdescr = get_valid_seq_type(seq);
  717.         # seq ist eine allgemeine Sequence
  718.         pushSTACK(typdescr);
  719.         # Stackaufbau: seq, typdescr.
  720.         pushSTACK(seq); funcall(seq_length(typdescr),1); # (SEQ-LENGTH seq)
  721.         if (!(posfixnump(value1))) # sollte ein Fixnum >=0 sein
  722.           { pushSTACK(value1); pushSTACK(S(nreverse));
  723.             //: DEUTSCH "~: Fehlerhafte Länge aufgetreten: ~"
  724.             //: ENGLISH "~: bad length ~"
  725.             //: FRANCAIS "~ : occurence d'une mauvaise longueur: ~."
  726.             fehler(error, GETTEXT("~: bad length ~"));
  727.           }
  728.         {var reg9 uintL len = posfixnum_to_L(value1); # len
  729.          # Grundidee: Um eine Sequence mit len Elementen umzudrehen, müssen
  730.          # der linke und der rechte Block mit je floor(len/2) Elementen
  731.          # vertauscht und dann einzeln umgedreht werden (rekursiv!); das
  732.          # mittlere Element (bei ungeradem len) bleibt unverändert.
  733.          # Entrekursivierter Algorithmus:
  734.          # Für j=0,1,2,... sind 2^j mal zwei (fast) adjazente Blöcke
  735.          # der Länge k2=floor(len/2^(j+1)) zu vertauschen.
  736.          var reg8 uintL j = 0; # j := 0
  737.          var reg7 uintL k = len; # k = floor(len/2^j) := len
  738.          var reg6 uintL k2; # k2 = floor(k/2)
  739.          var reg5 uintL k1; # k1 = ceiling(k/2)
  740.          until ((k2 = floor(k,2)) == 0) # k halbiert =0 -> Schleifenende
  741.            { k1 = k - k2; # k1 = (altes k) - (neues k) = ceiling((altes k)/2)
  742.             {var reg4 uintL pstack = 0; # ein Pseudo-Stack
  743.              # Stackaufbau: seq, typdescr.
  744.              pushSTACK(STACK_1); funcall(seq_init(STACK_(0+1)),1); # (SEQ-INIT seq)
  745.              pushSTACK(value1);
  746.              # Stackaufbau: seq, typdescr, pointer1.
  747.              pushSTACK(STACK_2); pushSTACK(fixnum(k1));
  748.              funcall(seq_init_start(STACK_(1+2)),2); # (SEQ-INIT-START seq k1)
  749.              pushSTACK(value1);
  750.              # Stackaufbau: seq, typdescr, pointer1, pointer2.
  751.              # pointer1 und pointer2 laufen gemeinsam durch seq, dabei hat
  752.              # pointer2 einen Vorsprung von k1.
  753.              loop
  754.                { # Zwei Blöcke der Länge k2 = floor(len/2^(j+1)) vertauschen:
  755.                  {var reg2 uintL i = k2; # i:=k2 >0
  756.                   do { # (SEQ-ACCESS seq pointer1) bilden:
  757.                        pushSTACK(STACK_3); pushSTACK(STACK_(1+1));
  758.                        funcall(seq_access(STACK_(2+2)),2); # (SEQ-ACCESS seq pointer1)
  759.                        pushSTACK(value1); # und retten
  760.                        # (SEQ-ACCESS seq pointer2) bilden:
  761.                        pushSTACK(STACK_(3+1)); pushSTACK(STACK_(0+1+1));
  762.                        funcall(seq_access(STACK_(2+1+2)),2); # (SEQ-ACCESS seq pointer2)
  763.                        # (SEQ-ACCESS-SET seq pointer1 ...) ausführen:
  764.                        pushSTACK(STACK_(3+1)); pushSTACK(STACK_(1+1+1)); pushSTACK(value1);
  765.                        funcall(seq_access_set(STACK_(2+1+3)),3); # (SEQ-ACCESS-SET seq pointer1 ...)
  766.                        # (SEQ-ACCESS-SET seq pointer2 ...) ausführen:
  767.                       {var reg1 object element1 = popSTACK(); # gerettetes ELement
  768.                        pushSTACK(STACK_3); pushSTACK(STACK_(0+1)); pushSTACK(element1); }
  769.                        funcall(seq_access_set(STACK_(2+3)),3); # (SEQ-ACCESS-SET seq pointer2 ...)
  770.                        # pointer1 := (SEQ-UPD seq pointer1) :
  771.                        pointer_update(STACK_1,STACK_3,STACK_2);
  772.                        # pointer2 := (SEQ-FE-UPD seq pointer2) :
  773.                        pointer_fe_update(STACK_0,STACK_3,STACK_2);
  774.                        --i; # i:=i-1
  775.                      }
  776.                      until (i==0); # bei i=0 Schleifenende
  777.                  }
  778.                  pstack = pstack+1; # stack:=stack+1
  779.                  if (pstack == (1UL<<j)) break; # stack=2^j geworden -> Schleifenabbruch
  780.                  # pointer1 und pointer2 um k1+(0 oder 1) Stellen weiterrücken:
  781.                  { var reg3 uintL skipcount = k1;
  782.                    { var reg2 uintL r1 = 1;
  783.                      # r := Anzahl der Nullbits am Ende der Dualdarstellung von stack:
  784.                      { var reg1 uintL pstackr = pstack;
  785.                        while ((pstackr & bit(0))==0) { pstackr = pstackr>>1; r1=r1+1; }
  786.                      }
  787.                      # r1 = r+1
  788.                      if (len & bit(j-r1)) # Bit j-r-1 in len gesetzt?
  789.                        { skipcount++; } # falls ja: skipcount=k1+1, sonst skipcount=k1
  790.                    }
  791.                    # skipcount >= k1 >= k2 > 0
  792.                    do { # pointer1 := (SEQ-UPD seq pointer1) :
  793.                         pointer_update(STACK_1,STACK_3,STACK_2);
  794.                         # pointer2 := (SEQ-FE-UPD seq pointer2) :
  795.                         pointer_fe_update(STACK_0,STACK_3,STACK_2);
  796.                         --skipcount;
  797.                       }
  798.                       until (skipcount==0);
  799.                } }
  800.              skipSTACK(2); # pointer1 und pointer2 vergessen
  801.             }
  802.             j=j+1; k=k2; # j:=j+1, k halbieren
  803.         }  }
  804.         skipSTACK(1); # typdescr vergessen
  805.         value1 = popSTACK(); mv_count=1; # modifizierte seq als Wert
  806.       }
  807.   }
  808.  
  809. LISPFUN(make_sequence,2,0,norest,key,2,\
  810.         (kw(initial_element),kw(update)) )
  811. # (MAKE-SEQUENCE type size [:initial-element] [:update]), CLTL S. 249
  812. # mit zusätzlichem Argument :update, z.B.
  813. # (make-sequence 'vector 5 :initial-element 3 :update #'1+) ==> #(3 4 5 6 7)
  814.   { # Stackaufbau: type, size, initial-element, updatefun.
  815.     # type überprüfen:
  816.     var reg4 object typdescr = valid_type(STACK_3);
  817.     STACK_3 = typdescr;
  818.     # size überprüfen, muß Integer >=0 sein:
  819.    {var reg3 object size = STACK_2;
  820.     if (!(integerp(size) && positivep(size)))
  821.       { pushSTACK(size); # Wert für Slot DATUM von TYPE-ERROR
  822.         pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  823.         pushSTACK(size); pushSTACK(S(make_sequence));
  824.         //: DEUTSCH "~: SIZE muß ein Integer >=0 sein, nicht ~"
  825.         //: ENGLISH "~: size should be an integer >=0, not ~"
  826.         //: FRANCAIS "~ : SIZE doit être un entier positif ou zéro et non ~"
  827.         fehler(type_error, GETTEXT("~: size should be an integer >=0, not ~"));
  828.       }
  829.     # initial-element bei Strings defaultmäßig ergänzen:
  830.     if (eq(STACK_1,unbound)) # :initial-element nicht angegeben?
  831.       { if (!eq(STACK_0,unbound)) # :update ohne :initial-element -> Error
  832.           { pushSTACK(S(make_sequence));
  833.             //: DEUTSCH "~: :UPDATE darf nur mit :INITIAL-ELEMENT angegeben werden."
  834.             //: ENGLISH "~: :update must not be specified without :initial-element"
  835.             //: FRANCAIS "~ : :UPDATE ne peut être spécifié qu'avec :INITIAL-ELEMENT."
  836.             fehler(error, GETTEXT("~: :update must not be specified without :initial-element"));
  837.           }
  838.         if (eq(seq_type(typdescr),S(string))) # Typname = STRING ?
  839.           { STACK_1 = code_char(' '); } # initial-element := ' '
  840.         elif (mposfixnump(seq_type(typdescr))) # Typname Integer? (bedeutet Byte-Vektoren)
  841.           { STACK_1 = Fixnum_0; } # initial-element := 0
  842.       }
  843.     # Stackaufbau: typdescr, size, initial-element, updatefun.
  844.     pushSTACK(size); funcall(seq_make(typdescr),1); # (SEQ-MAKE size)
  845.    }
  846.     if (!(eq(STACK_1,unbound))) # :initial-element angegeben?
  847.       if (!(eq(STACK_2,Fixnum_0))) # size (ein Integer) = 0 -> nichts zu tun
  848.         { pushSTACK(value1);
  849.           # Stackaufbau: typdescr, count, element, updatefun, seq.
  850.           pushSTACK(STACK_0); funcall(seq_init(STACK_(4+1)),1); # (SEQ-INIT seq)
  851.           pushSTACK(value1);
  852.           # Stackaufbau: typdescr, count, element, updatefun, seq, pointer.
  853.           loop
  854.             { pushSTACK(STACK_(1+0)); pushSTACK(STACK_(0+1)); pushSTACK(STACK_(3+2));
  855.               funcall(seq_access_set(STACK_(5+3)),3); # (SEQ-ACCESS-SET seq pointer element)
  856.               # pointer := (SEQ-UPD seq pointer) :
  857.               pointer_update(STACK_0,STACK_1,STACK_5);
  858.               # count := (1- count) :
  859.               decrement(STACK_4);
  860.               if (eq(STACK_4,Fixnum_0)) break; # count (ein Integer) = 0 -> Schleifenende
  861.               {var reg1 object updatefun = STACK_2;
  862.                if (!(eq(updatefun,unbound))) # falls angegeben,
  863.                  { pushSTACK(STACK_3); funcall(updatefun,1); # (FUNCALL updatefun element)
  864.                    STACK_3 = value1; # =: element
  865.             } }  }
  866.           skipSTACK(1); # pointer vergessen
  867.           value1 = popSTACK(); # seq
  868.         }
  869.     mv_count=1; # seq als Wert
  870.     skipSTACK(4);
  871.   }
  872.  
  873. # UP: Wandelt ein Objekt in eine Sequence gegebenen Typs um.
  874. # coerce_sequence(obj,result_type)
  875. # > obj: Objekt, sollte eine Sequence sein
  876. # > result_type: Bezeichner (Symbol) des Sequence-Typs
  877. # < Wert: Sequence vom Typ result_type
  878. # kann GC auslösen
  879.   global Values coerce_sequence (object sequence, object result_type);
  880.   global Values coerce_sequence(sequence,result_type)
  881.     var reg4 object sequence;
  882.     var reg3 object result_type;
  883.     { pushSTACK(sequence);
  884.       pushSTACK(result_type);
  885.       { # result-type überprüfen:
  886.         var reg2 object typdescr2 = valid_type(result_type);
  887.         pushSTACK(seq_type(typdescr2)); # neuer type2
  888.         pushSTACK(typdescr2);
  889.         # Stackaufbau: seq1, result-type, type2, typdescr2.
  890.        {var reg1 object typdescr1 = get_valid_seq_type(STACK_3); # Typ von seq1
  891.         if (eq(seq_type(typdescr1),STACK_1))
  892.           { # beide Typen dieselben -> nichts zu tun
  893.             skipSTACK(3); value1 = popSTACK(); mv_count=1; # seq1 als Wert
  894.           }
  895.           else
  896.           { STACK_2 = typdescr1;
  897.             # Stackaufbau: seq1, typdescr1, type2, typdescr2.
  898.             pushSTACK(STACK_3); funcall(seq_length(typdescr1),1); # (SEQ1-LENGTH seq1)
  899.             pushSTACK(value1);
  900.             # Stackaufbau: seq1, typdescr1, type2, typdescr2, len.
  901.             pushSTACK(STACK_0); funcall(seq_make(STACK_(1+1)),1); # (SEQ2-MAKE len)
  902.             STACK_2 = value1;
  903.             # Stackaufbau: seq1, typdescr1, seq2, typdescr2, len.
  904.             return_Values copy_seq_onto();
  905.           }
  906.     } }}
  907.  
  908.   local void fehler_bad_length (object len,object concatenate_sym);
  909.   local void fehler_bad_length (len,concatenate_sym)
  910.     var object len;
  911.     var object concatenate_sym;
  912.     { pushSTACK(len);
  913.       pushSTACK(concatenate_sym);
  914.       //: DEUTSCH "~: Fehlerhafte Länge aufgetreten: ~"
  915.       //: ENGLISH "~: bad length ~"
  916.       //: FRANCAIS "~ : occurence d'une mauvaise longueur: ~"
  917.       fehler(error, GETTEXT("~: bad length ~"));
  918.     }
  919.  
  920. LISPFUN(concatenate,1,0,rest,nokey,0,NIL)
  921. # (CONCATENATE result-type {sequence}), CLTL S. 249
  922.   { var reg5 object* args_pointer = rest_args_pointer;
  923.     # result-type in Typdescriptor umwandeln:
  924.     { var reg1 object type = Before(args_pointer);
  925.       type = valid_type(type);
  926.       BEFORE(args_pointer) = type;
  927.     }
  928.     # args_pointer = Pointer über die Argumente,
  929.     # rest_args_pointer = Pointer über die argcount Sequence-Argumente.
  930.     # Stackaufbau: [args_pointer] typdescr2, [rest_args_pointer] {sequence}, [STACK].
  931.     # Brauche 2*argcount STACK-Einträge:
  932.     get_space_on_STACK(sizeof(object) * 2*(uintL)argcount);
  933.    {var reg3 object* behind_args_pointer = args_end_pointer; # Pointer unter die Argumente
  934.     # Stackaufbau: [args_pointer] typdescr2,
  935.     #              [rest_args_pointer] {sequence}, [behind_args_pointer].
  936.     # Typdescriptoren und Längen bestimmen und im STACK ablegen:
  937.     { var reg3 object* ptr = rest_args_pointer;
  938.       var reg4 uintC count;
  939.       dotimesC(count,argcount,
  940.         { var reg2 object seq = NEXT(ptr); # nächste Sequence
  941.           var reg1 object typdescr = get_valid_seq_type(seq);
  942.           pushSTACK(typdescr); # Typdescriptor in den Stack
  943.           pushSTACK(seq); funcall(seq_length(typdescr),1); # (SEQ-LENGTH seq)
  944.           pushSTACK(value1); # Länge in den Stack
  945.         });
  946.     }
  947.     # Stackaufbau: [args_pointer] typdescr2,
  948.     #              [rest_args_pointer] {sequence},
  949.     #              [behind_args_pointer] {typdescr, len}, [STACK].
  950.     # Längen addieren:
  951.     { var reg2 object total_length = Fixnum_0;
  952.       {var reg3 object* ptr = behind_args_pointer;
  953.        var reg4 uintC count;
  954.        dotimesC(count,argcount,
  955.          { NEXT(ptr); # typdescr überspringen
  956.           {var reg1 object len = NEXT(ptr); # nächste Länge
  957.            if (!(posfixnump(len)))
  958.              fehler_bad_length(len,S(concatenate));
  959.            total_length = I_I_plus_I(total_length,len); # total_length = total_length + len
  960.          }});
  961.       }
  962.       pushSTACK(NIL); pushSTACK(NIL); pushSTACK(NIL); # Dummies
  963.       # neue Sequence allozieren:
  964.       {var reg2 object* ptr = args_pointer;
  965.        var reg1 object typdescr2 = NEXT(ptr);
  966.        pushSTACK(typdescr2);
  967.        pushSTACK(total_length); funcall(seq_make(typdescr2),1); # (SEQ2-MAKE total_length)
  968.        STACK_1 = value1; # =: seq2
  969.     } }
  970.     # Stackaufbau: [args_pointer] typdescr2,
  971.     #              [rest_args_pointer] {sequence},
  972.     #              [behind_args_pointer] {typdescr, len},
  973.     #              NIL, NIL, seq2, typdescr2, [STACK].
  974.     pushSTACK(NIL); pushSTACK(NIL); # Dummies
  975.     # Stackaufbau: [args_pointer] typdescr2,
  976.     #              [rest_args_pointer] {sequence},
  977.     #              [behind_args_pointer] {typdescr, len},
  978.     #              NIL, NIL, seq2, typdescr2, NIL, NIL, [STACK].
  979.     pushSTACK(STACK_(3)); funcall(seq_init(STACK_(2+1)),1); # (SEQ-INIT seq2)
  980.     pushSTACK(value1);
  981.     # Stackaufbau: [args_pointer] typdescr2,
  982.     #              [rest_args_pointer] {sequence},
  983.     #              [behind_args_pointer] {typdescr, len},
  984.     #              NIL, NIL, seq2, typdescr2, NIL, NIL, pointer2, [STACK].
  985.     # Schleife über die argcount Sequences: in seq2 hineinkopieren
  986.     dotimesC(argcount,argcount,
  987.       { STACK_6 = NEXT(rest_args_pointer); # seq1 = nächste Sequence
  988.         STACK_5 = NEXT(behind_args_pointer); # deren typdescr1
  989.         STACK_2 = NEXT(behind_args_pointer); # deren Länge
  990.         pushSTACK(STACK_6); funcall(seq_init(STACK_(5+1)),1); # (SEQ1-INIT seq1)
  991.         STACK_1 = value1; # =: pointer1
  992.         # Stackaufbau: [args_pointer] typdescr2,
  993.         #              [rest_args_pointer] {sequence},
  994.         #              [behind_args_pointer] {typdescr, len},
  995.         #              seq1, typdescr1, seq2, typdescr2, count,
  996.         #              pointer1, pointer2, [STACK].
  997.         copy_seqpart_into(); # ganze seq1 in die seq2 hineinkopieren
  998.       });
  999.     value1 = STACK_4; mv_count=1; # seq2 als Wert
  1000.     set_args_end_pointer(args_pointer); # STACK aufräumen
  1001.   }}
  1002.  
  1003. # UP: führt eine Boolesche Operation mit Prädikat wie SOME oder EVERY aus.
  1004. # > Stackaufbau: [args_pointer] ... predicate sequence,
  1005. #                [rest_args_pointer] {sequence} [STACK].
  1006. # > fun: Routine, die das predicate-Ergebnis abtestet und
  1007. #        TRUE liefert (und in value1 ihr Ergebnis hinterläßt),
  1008. #        falls vorzeitig herausgesprungen werden soll.
  1009. # > argcount: Anzahl der Sequence-Argumente - 1
  1010. # > default: Defaultwert am Schluß
  1011. # < 1 Wert: wie von fun beim Hinausspringen vorgegeben, oder default.
  1012. # < STACK: aufgeräumt (= args_pointer beim Einsprung)
  1013. # kann GC auslösen
  1014.   typedef boolean seq_boolop_fun (object pred_ergebnis);
  1015.   local Values seq_boolop (seq_boolop_fun* boolop_fun,
  1016.                            object* args_pointer,
  1017.                            object* rest_args_pointer,
  1018.                            uintC argcount,
  1019.                            object defolt);
  1020.   local Values seq_boolop(boolop_fun,args_pointer,rest_args_pointer,argcount,defolt)
  1021.     var seq_boolop_fun* boolop_fun;
  1022.     var reg10 object* args_pointer;
  1023.     var reg8 object* rest_args_pointer;
  1024.     var reg9 uintC argcount;
  1025.     var object defolt;
  1026.     { BEFORE(rest_args_pointer);
  1027.       # rest_args_pointer zeigt jetzt über alle argcount+1 Sequence-Argumente
  1028.       pushSTACK(defolt); # Defaultwert retten
  1029.       # 3*(argcount+1) Plätze auf dem STACK beanspruchen:
  1030.       # (2mal für Typdescriptoren und Pointer, 1mal für Funktionsaufruf)
  1031.       get_space_on_STACK(sizeof(object)*3*(uintL)(argcount+1));
  1032.      {var reg7 object* typdescr_pointer = args_end_pointer; # Pointer über die Typdescriptoren
  1033.       # Typdescriptoren und je einen Pointer zu jeder der argcount+1
  1034.       # Sequences bestimmen und im STACK ablegen:
  1035.       { var reg4 object* ptr = rest_args_pointer;
  1036.         var reg3 uintC count;
  1037.         dotimespC(count,argcount+1,
  1038.           { var reg1 object seq = NEXT(ptr); # nächste Sequence
  1039.             var reg2 object typdescr = get_valid_seq_type(seq);
  1040.             pushSTACK(typdescr); # Typdescriptor im STACK ablegen
  1041.             pushSTACK(seq); funcall(seq_init(typdescr),1); # (SEQ-INIT sequence)
  1042.             pushSTACK(value1); # Pointer im STACK ablegen
  1043.           });
  1044.       }
  1045.       # Stackaufbau:
  1046.       #         [args_pointer] ... predicate,
  1047.       #         [rest_args_pointer] {sequence}, default,
  1048.       #         [typdescr_pointer] {typdescr, pointer}, [STACK].
  1049.       # Schleife: die Funktion aufrufen:
  1050.       loop
  1051.         { var reg5 object* ptr1 = rest_args_pointer;
  1052.           var reg4 object* ptr2 = typdescr_pointer;
  1053.           # ptr1 läuft von oben durch die Sequences durch,
  1054.           # ptr2 läuft von oben durch die Typdescr/Pointer durch.
  1055.           var reg6 uintC count;
  1056.           dotimespC(count,argcount+1,
  1057.             { var reg3 object* sequence_ = &NEXT(ptr1);
  1058.               var reg2 object* typdescr_ = &NEXT(ptr2);
  1059.               var reg1 object* pointer_ = &NEXT(ptr2);
  1060.               # (SEQ-ENDTEST sequence pointer) :
  1061.               pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_endtest(*typdescr_),2);
  1062.               # eine der Sequences zu Ende -> große Schleife beenden:
  1063.               if (!(nullp(value1))) goto end_with_default;
  1064.               # (SEQ-ACCESS sequence pointer) :
  1065.               pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_access(*typdescr_),2);
  1066.               # als Argument auf den STACK legen:
  1067.               pushSTACK(value1);
  1068.               # pointer := (SEQ-UPD sequence pointer) :
  1069.               pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_upd(*typdescr_),2);
  1070.               *pointer_ = value1;
  1071.             });
  1072.           # Alle Sequences abgearbeitet.
  1073.           # (FUNCALL predicate (SEQ-ACCESS sequence pointer) ...) aufrufen:
  1074.           { var reg1 object* ptr = rest_args_pointer;
  1075.             var reg2 object predicate = BEFORE(ptr);
  1076.             funcall(predicate,argcount+1);
  1077.           }
  1078.           # Abtestroutine drauf anwenden:
  1079.           if ((*boolop_fun)(value1)) goto end_with_value1;
  1080.         }
  1081.       end_with_default:
  1082.         { var reg1 object* ptr = typdescr_pointer;
  1083.           value1 = BEFORE(ptr); # default als Wert
  1084.         }
  1085.       end_with_value1:
  1086.         mv_count=1; # 1 Wert
  1087.         set_args_end_pointer(args_pointer); # STACK aufräumen
  1088.     }}
  1089.  
  1090. # Hilfsfunktion für MAP:
  1091.   local boolean boolop_nothing (object pred_ergebnis);
  1092.   local boolean boolop_nothing(pred_ergebnis)
  1093.     var object pred_ergebnis;
  1094.     { return FALSE; } # nie vorzeitig zurückkehren
  1095.  
  1096. LISPFUN(map,3,0,rest,nokey,0,NIL)
  1097. # (MAP result-type function sequence {sequence}), CLTL S. 249
  1098.   { var reg10 object* args_pointer = rest_args_pointer STACKop 3;
  1099.     # args_pointer = Pointer über die Argumente,
  1100.     # rest_args_pointer = Pointer über die argcount weiteren Sequence-Argumente.
  1101.     var reg7 object* result_type_ = &Next(args_pointer);
  1102.     # result_type_ zeigt in den STACK, auf result-type.
  1103.     if (!(nullp(*result_type_)))
  1104.       # allgemeines result-type
  1105.       { BEFORE(rest_args_pointer);
  1106.         # rest_args_pointer zeigt jetzt über alle argcount+1 Sequence-Argumente
  1107.         # 4*(argcount+1) Plätze auf dem STACK beanspruchen:
  1108.         # (3mal für Typdescriptoren und Pointer, 1mal für Funktionsaufruf)
  1109.         get_space_on_STACK(sizeof(object)*4*(uintL)(argcount+1));
  1110.         # result-type überprüfen:
  1111.         *result_type_ = valid_type(*result_type_);
  1112.        {var reg8 object* typdescr_pointer = args_end_pointer; # Pointer über die Typdescriptoren
  1113.         # Typdescriptoren und je zwei Pointer zu jeder der argcount+1
  1114.         # Sequences bestimmen und im STACK ablegen:
  1115.         { var reg4 object* ptr = rest_args_pointer;
  1116.           var reg5 uintC count;
  1117.           dotimespC(count,argcount+1,
  1118.             { var reg1 object* sequence_ = &NEXT(ptr);
  1119.               var reg2 object seq = *sequence_; # nächste Sequence
  1120.               var reg3 object typdescr = get_valid_seq_type(seq);
  1121.               pushSTACK(typdescr); # Typdescriptor im STACK ablegen
  1122.               pushSTACK(seq); funcall(seq_init(typdescr),1); # (SEQ-INIT sequence)
  1123.               pushSTACK(value1); # Pointer im STACK ablegen
  1124.               pushSTACK(*sequence_); funcall(seq_init(STACK_(1+1)),1); # (SEQ-INIT sequence)
  1125.               pushSTACK(value1); # Pointer im STACK ablegen
  1126.             });
  1127.         }
  1128.         # Stackaufbau:
  1129.         #         [args_pointer] *result_type_ = typdescr2, function,
  1130.         #         [rest_args_pointer] {sequence},
  1131.         #         [typdescr_pointer] {typdescr, pointer, pointer}, [STACK].
  1132.         # Minimale Länge aller Sequences bestimmen, indem jeweils mit dem
  1133.         # zweiten Pointer durchgelaufen wird:
  1134.         pushSTACK(Fixnum_0); # minlength:=0
  1135.         loop
  1136.           { var reg5 object* ptr1 = rest_args_pointer;
  1137.             var reg4 object* ptr2 = typdescr_pointer;
  1138.             # ptr1 läuft von oben durch die Sequences durch,
  1139.             # ptr2 läuft von oben durch die Typdescr/Pointer durch.
  1140.             var reg6 uintC count;
  1141.             dotimespC(count,argcount+1,
  1142.               { var reg3 object* sequence_ = &NEXT(ptr1);
  1143.                 var reg2 object* typdescr_ = &NEXT(ptr2);
  1144.                 NEXT(ptr2);
  1145.                {var reg1 object* pointer_ = &NEXT(ptr2);
  1146.                 # (SEQ-ENDTEST sequence pointer) :
  1147.                 pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_endtest(*typdescr_),2);
  1148.                 # eine der Sequences zu Ende -> große Schleife beenden:
  1149.                 if (!(nullp(value1))) goto end_found;
  1150.                 # pointer := (SEQ-UPD sequence pointer) :
  1151.                 pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_upd(*typdescr_),2);
  1152.                 *pointer_ = value1;
  1153.               }});
  1154.             # Keine der Sequences war zu Ende.
  1155.             STACK_0 = fixnum_inc(STACK_0,1); # minlength := minlength+1
  1156.           }
  1157.         end_found:
  1158.         # STACK_0 = minimale Länge der Sequences
  1159.         # Stackaufbau:
  1160.         #         [args_pointer] *result_type_ = typdescr2, function,
  1161.         #         [rest_args_pointer] {sequence},
  1162.         #         [typdescr_pointer] {typdescr, pointer, pointer},
  1163.         #         size [STACK].
  1164.         # Neue Sequence der Länge size allozieren:
  1165.         pushSTACK(STACK_0); funcall(seq_make(*result_type_),1); # (SEQ2-MAKE size)
  1166.         pushSTACK(value1); # seq2 im STACK ablegen
  1167.         pushSTACK(STACK_0); funcall(seq_init(*result_type_),1); # (SEQ2-INIT seq2)
  1168.         pushSTACK(value1); # pointer2 im STACK ablegen
  1169.         # Stackaufbau:
  1170.         #         [args_pointer] *result_type_ = typdescr2, function,
  1171.         #         [rest_args_pointer] {sequence},
  1172.         #         [typdescr_pointer] {typdescr, pointer, pointer},
  1173.         #         size, seq2, pointer2 [STACK].
  1174.         # size mal die Funktion aufrufen, Ergebnis in seq2 eintragen:
  1175.         until (eq(STACK_2,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  1176.           { var reg5 object* ptr1 = rest_args_pointer;
  1177.             var reg4 object* ptr2 = typdescr_pointer;
  1178.             # ptr1 läuft von oben durch die Sequences durch,
  1179.             # ptr2 läuft von oben durch die Typdescr/Pointer durch.
  1180.             var reg6 uintC count;
  1181.             dotimespC(count,argcount+1,
  1182.               { var reg3 object* sequence_ = &NEXT(ptr1);
  1183.                 var reg2 object* typdescr_ = &NEXT(ptr2);
  1184.                 var reg1 object* pointer_ = &NEXT(ptr2);
  1185.                 NEXT(ptr2);
  1186.                 # (SEQ-ACCESS sequence pointer) :
  1187.                 pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_access(*typdescr_),2);
  1188.                 # als Argument auf den STACK legen:
  1189.                 pushSTACK(value1);
  1190.                 # pointer := (SEQ-UPD sequence pointer) :
  1191.                 pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_upd(*typdescr_),2);
  1192.                 *pointer_ = value1;
  1193.               });
  1194.             # Alle Sequences abgearbeitet.
  1195.             # (FUNCALL function (SEQ-ACCESS sequence pointer) ...) aufrufen:
  1196.             funcall(*(result_type_ STACKop -1),argcount+1);
  1197.             # (SEQ2-ACCESS-SET seq2 pointer2 ...) ausführen:
  1198.             pushSTACK(STACK_(1+0)); pushSTACK(STACK_(0+1)); pushSTACK(value1);
  1199.             funcall(seq_access_set(*result_type_),3);
  1200.             # pointer2 := (SEQ2-UPD seq2 pointer2) :
  1201.             pointer_update(STACK_0,STACK_1,*result_type_);
  1202.             # size := (1- size) :
  1203.             STACK_2 = fixnum_inc(STACK_2,-1);
  1204.           }
  1205.         value1 = STACK_1; mv_count=1; # seq2 als Wert
  1206.         set_args_end_pointer(args_pointer); # STACK aufräumen
  1207.       }}
  1208.       else
  1209.       # result-type = NIL -> viel einfacher:
  1210.       # seq_boolop mit boolop_nothing als Funktion und NIL als (Default-)Wert.
  1211.       # Dadurch wird function auf alle Elemente der Sequences angewandt.
  1212.       return_Values seq_boolop(&boolop_nothing,args_pointer,rest_args_pointer,argcount,NIL);
  1213.   }
  1214.  
  1215. LISPFUN(map_into,2,0,rest,nokey,0,NIL)
  1216. # (MAP-INTO result-sequence function {sequence}), CLtL2 S. 395
  1217.   { var reg7 object* args_pointer = rest_args_pointer STACKop 2;
  1218.     # args_pointer = Pointer über die Argumente,
  1219.     # rest_args_pointer = Pointer über die argcount Sequence-Argumente.
  1220.     # 3*argcount Plätze auf dem STACK beanspruchen:
  1221.     # (2mal für Typdescriptoren und Pointer, 1mal für Funktionsaufruf)
  1222.     get_space_on_STACK(sizeof(object)*3*(uintL)argcount);
  1223.     # result-sequence der Einfachheit halber nochmal in den STACK:
  1224.     pushSTACK(Next(args_pointer));
  1225.    {var reg8 object* typdescr_pointer = args_end_pointer; # Pointer über die Typdescriptoren
  1226.     # Typdescriptoren und je einen Pointer zu jeder der argcount+1
  1227.     # Sequences bestimmen und im STACK ablegen:
  1228.     { var reg3 object* ptr = rest_args_pointer;
  1229.       var reg4 uintC count;
  1230.       dotimespC(count,argcount+1,
  1231.         { var reg1 object seq = NEXT(ptr);
  1232.           var reg2 object typdescr = get_valid_seq_type(seq);
  1233.           pushSTACK(typdescr); # Typdescriptor im STACK ablegen
  1234.           pushSTACK(seq); funcall(seq_init(typdescr),1); # (SEQ-INIT sequence)
  1235.           pushSTACK(value1); # Pointer im STACK ablegen
  1236.         });
  1237.     }
  1238.     # Stackaufbau:
  1239.     #         [args_pointer] result-sequence, function,
  1240.     #         [rest_args_pointer] {sequence}, result-sequence,
  1241.     #         [typdescr_pointer] {typdescr, pointer},
  1242.     #         result-typdescr, result-pointer, [STACK].
  1243.     # Sooft wie nötig, die Funktion aufrufen, Ergebnis in result-sequence eintragen:
  1244.     loop
  1245.       { # Test, ob eine weitere Iteration nötig:
  1246.         { var reg5 object* ptr1 = rest_args_pointer;
  1247.           var reg4 object* ptr2 = typdescr_pointer;
  1248.           # ptr1 läuft von oben durch die Sequences durch,
  1249.           # ptr2 läuft von oben durch die Typdescr/Pointer durch.
  1250.           var reg6 uintC count;
  1251.           dotimesC(count,argcount,
  1252.             { var reg3 object sequence = NEXT(ptr1);
  1253.               var reg2 object typdescr = NEXT(ptr2);
  1254.               var reg1 object pointer = NEXT(ptr2);
  1255.               # (SEQ-ENDTEST sequence pointer) :
  1256.               pushSTACK(sequence); pushSTACK(pointer); funcall(seq_endtest(typdescr),2);
  1257.               # eine der Sequences zu Ende -> große Schleife beenden:
  1258.               if (!nullp(value1)) goto end_reached;
  1259.             });
  1260.           # result-sequence zu Ende -> große Schleife beenden:
  1261.           { var reg3 object sequence = NEXT(ptr1);
  1262.             var reg2 object typdescr = NEXT(ptr2);
  1263.             var reg1 object pointer = NEXT(ptr2);
  1264.             if (vectorp(sequence))
  1265.               { # Bei der result-sequence wird der Fill-Pointer ignoriert.
  1266.                 # pointer ist der Index als Fixnum.
  1267.                 if (posfixnum_to_L(pointer) >= array_total_size(sequence))
  1268.                   goto end_reached;
  1269.               }
  1270.               else
  1271.               { # (SEQ-ENDTEST sequence pointer) :
  1272.                 pushSTACK(sequence); pushSTACK(pointer); funcall(seq_endtest(typdescr),2);
  1273.                 if (!nullp(value1)) goto end_reached;
  1274.           }   }
  1275.         }
  1276.         # Jetzt die Funktion aufrufen:
  1277.         { var reg5 object* ptr1 = rest_args_pointer;
  1278.           var reg4 object* ptr2 = typdescr_pointer;
  1279.           # ptr1 läuft von oben durch die Sequences durch,
  1280.           # ptr2 läuft von oben durch die Typdescr/Pointer durch.
  1281.           var reg6 uintC count;
  1282.           dotimesC(count,argcount,
  1283.             { var reg3 object* sequence_ = &NEXT(ptr1);
  1284.               var reg2 object* typdescr_ = &NEXT(ptr2);
  1285.               var reg1 object* pointer_ = &NEXT(ptr2);
  1286.               # (SEQ-ACCESS sequence pointer) :
  1287.               pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_access(*typdescr_),2);
  1288.               # als Argument auf den STACK legen:
  1289.               pushSTACK(value1);
  1290.               # pointer := (SEQ-UPD sequence pointer) :
  1291.               pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_upd(*typdescr_),2);
  1292.               *pointer_ = value1;
  1293.             });
  1294.           # Alle Sequences abgearbeitet.
  1295.           # (FUNCALL function (SEQ-ACCESS sequence pointer) ...) aufrufen:
  1296.           funcall(Before(rest_args_pointer),argcount);
  1297.           # (SEQ-ACCESS-SET result-sequence result-pointer ...) ausführen:
  1298.           { var reg3 object* sequence_ = &NEXT(ptr1);
  1299.             var reg2 object* typdescr_ = &NEXT(ptr2);
  1300.             var reg1 object* pointer_ = &NEXT(ptr2);
  1301.             pushSTACK(*sequence_); pushSTACK(*pointer_); pushSTACK(value1);
  1302.             funcall(seq_access_set(*typdescr_),3);
  1303.             # pointer := (SEQ-UPD sequence pointer) :
  1304.             pushSTACK(*sequence_); pushSTACK(*pointer_); funcall(seq_upd(*typdescr_),2);
  1305.             *pointer_ = value1;
  1306.         } }
  1307.       }
  1308.     end_reached:
  1309.     { var reg1 object result = Next(args_pointer);
  1310.       if (vectorp(result) && array_has_fill_pointer_p(result))
  1311.         { # (SYS::SET-FILL-POINTER result-sequence result-pointer)
  1312.           pushSTACK(result); pushSTACK(STACK_(0+1)); funcall(L(set_fill_pointer),2);
  1313.     }   }
  1314.     value1 = Next(args_pointer); # result-sequence als Wert
  1315.     set_args_end_pointer(args_pointer); # STACK aufräumen
  1316.   }}
  1317.  
  1318. # Hilfsfunktion für SOME:
  1319.   local boolean boolop_some (object pred_ergebnis);
  1320.   local boolean boolop_some(pred_ergebnis)
  1321.     var reg1 object pred_ergebnis;
  1322.     { if (nullp(pred_ergebnis)) # Funktionsergebnis abtesten
  1323.         { return FALSE; } # =NIL -> weitersuchen
  1324.         else
  1325.         { value1 = pred_ergebnis; # /=NIL -> dies als Wert
  1326.           return TRUE;
  1327.     }   }
  1328.  
  1329. LISPFUN(some,2,0,rest,nokey,0,NIL)
  1330. # (SOME predicate sequence {sequence}), CLTL S. 250
  1331.   { return_Values seq_boolop(&boolop_some,rest_args_pointer STACKop 2,rest_args_pointer,argcount,NIL); }
  1332.  
  1333. # Hilfsfunktion für EVERY:
  1334.   local boolean boolop_every (object pred_ergebnis);
  1335.   local boolean boolop_every(pred_ergebnis)
  1336.     var reg1 object pred_ergebnis;
  1337.     { if (!(nullp(pred_ergebnis))) # Funktionsergebnis abtesten
  1338.         { return FALSE; } # /=NIL -> weitersuchen
  1339.         else
  1340.         { value1 = pred_ergebnis; # =NIL -> dies (= NIL) als Wert
  1341.           return TRUE;
  1342.     }   }
  1343.  
  1344. LISPFUN(every,2,0,rest,nokey,0,NIL)
  1345. # (EVERY predicate sequence {sequence}), CLTL S. 250
  1346.   { return_Values seq_boolop(&boolop_every,rest_args_pointer STACKop 2,rest_args_pointer,argcount,T); }
  1347.  
  1348. # Hilfsfunktion für NOTANY:
  1349.   local boolean boolop_notany (object pred_ergebnis);
  1350.   local boolean boolop_notany(pred_ergebnis)
  1351.     var reg1 object pred_ergebnis;
  1352.     { if (nullp(pred_ergebnis)) # Funktionsergebnis abtesten
  1353.         { return FALSE; } # =NIL -> weitersuchen
  1354.         else
  1355.         { value1 = NIL; # /=NIL -> NIL als Wert
  1356.           return TRUE;
  1357.     }   }
  1358.  
  1359. LISPFUN(notany,2,0,rest,nokey,0,NIL)
  1360. # (NOTANY predicate sequence {sequence}), CLTL S. 250
  1361.   { return_Values seq_boolop(&boolop_notany,rest_args_pointer STACKop 2,rest_args_pointer,argcount,T); }
  1362.  
  1363. # Hilfsfunktion für NOTEVERY:
  1364.   local boolean boolop_notevery (object pred_ergebnis);
  1365.   local boolean boolop_notevery(pred_ergebnis)
  1366.     var reg1 object pred_ergebnis;
  1367.     { if (!(nullp(pred_ergebnis))) # Funktionsergebnis abtesten
  1368.         { return FALSE; } # /=NIL -> weitersuchen
  1369.         else
  1370.         { value1 = T; # =NIL -> T als Wert
  1371.           return TRUE;
  1372.     }   }
  1373.  
  1374. LISPFUN(notevery,2,0,rest,nokey,0,NIL)
  1375. # (NOTEVERY predicate sequence {sequence}), CLTL S. 250
  1376.   { return_Values seq_boolop(&boolop_notevery,rest_args_pointer STACKop 2,rest_args_pointer,argcount,NIL); }
  1377.  
  1378. # UP: Überprüft das :KEY-Argument
  1379. # test_key_arg(stackptr)
  1380. # > *(stackptr-4): optionales Argument
  1381. # < *(stackptr-4): korrekte KEY-Funktion
  1382.   local void test_key_arg (object* stackptr);
  1383.   local void test_key_arg(stackptr)
  1384.     var reg2 object* stackptr;
  1385.     { var reg1 object key_arg = *(stackptr STACKop -4);
  1386.       if (eq(key_arg,unbound) || nullp(key_arg))
  1387.         *(stackptr STACKop -4) = L(identity); # #'IDENTITY als Default für :KEY
  1388.     }
  1389.  
  1390. # Anwenden eines :KEY-Arguments
  1391. # funcall_key(key);
  1392. # > key: Wert des :KEY-Arguments
  1393. # > value1: Element einer Sequence
  1394. # < value1: (FUNCALL key value1)
  1395. # kann GC auslösen
  1396.   #define funcall_key(key)  \
  1397.     { var reg1 object _key = (key);                                           \
  1398.       if (!eq(_key,L(identity))) # :KEY #'IDENTITY ist sehr häufig, Abkürzung \
  1399.         { pushSTACK(value1); funcall(_key,1); }                               \
  1400.     }
  1401.  
  1402. LISPFUN(reduce,2,0,norest,key,5,\
  1403.         (kw(from_end),kw(start),kw(end),kw(key),kw(initial_value)) )
  1404. # (REDUCE function sequence [:from-end] [:start] [:end] [:key] [:initial-value]),
  1405. # CLTL S. 251, CLTL2 S. 397
  1406.   { # Stackaufbau: function, sequence, from-end, start, end, key, initial-value.
  1407.     # sequence überprüfen:
  1408.     pushSTACK(get_valid_seq_type(STACK_5));
  1409.     # Stackaufbau: function, sequence, from-end, start, end, key, initial-value,
  1410.     #              typdescr.
  1411.     # key überprüfen:
  1412.     test_key_arg(&STACK_(5+1));
  1413.     # Defaultwert für start ist 0:
  1414.     start_default_0(STACK_(3+1));
  1415.     # Defaultwert für end ist die Länge der Sequence:
  1416.     end_default_len(STACK_(2+1),STACK_(5+1),STACK_0);
  1417.     # start- und end-Argumente überprüfen:
  1418.     test_start_end(&O(kwpair_start),&STACK_(2+1));
  1419.     # start- und end-Argumente subtrahieren und vergleichen:
  1420.     { var reg1 object count = I_I_minus_I(STACK_(2+1),STACK_(3+1));
  1421.       # count = (- end start), ein Integer >=0.
  1422.       if (eq(count,Fixnum_0)) # count = 0 ?
  1423.         # start und end sind gleich
  1424.         { if (eq(STACK_(0+1),unbound)) # initial-value angegeben?
  1425.             { # nein -> function mit 0 Argumenten aufrufen:
  1426.               funcall(STACK_(6+1),0);
  1427.             }
  1428.             else
  1429.             { # ja -> initial-value als Wert:
  1430.               value1 = STACK_(0+1); mv_count=1;
  1431.             }
  1432.           skipSTACK(7+1);
  1433.           return;
  1434.         }
  1435.       # allgemeiner Fall: start < end, count > 0
  1436.       pushSTACK(count);
  1437.     }
  1438.     # Stackaufbau: function, sequence, from-end, start, end, key, initial-value,
  1439.     #              typdescr, count.
  1440.     # from-end abfragen:
  1441.     if (!(eq(STACK_(4+2),unbound)) && !(nullp(STACK_(4+2))))
  1442.       # from-end ist angegeben und /=NIL
  1443.       { # Durchlauf-Pointer bestimmen:
  1444.         pushSTACK(STACK_(5+2)); pushSTACK(STACK_(2+2+1));
  1445.         funcall(seq_fe_init_end(STACK_(1+2)),2); # (SEQ-FE-INIT-END seq end)
  1446.         pushSTACK(value1); # =: pointer
  1447.         # Stackaufbau: function, sequence, from-end, start, end, key, initial-value,
  1448.         #              typdescr, count, pointer.
  1449.         # Startwert bestimmen:
  1450.         if (eq(STACK_(0+3),unbound))
  1451.           # initial-value ist nicht angegeben
  1452.           { pushSTACK(STACK_(5+3)); pushSTACK(STACK_(0+1));
  1453.             funcall(seq_access(STACK_(2+2)),2); # (SEQ-ACCESS seq pointer)
  1454.             funcall_key(STACK_(1+3)); # (FUNCALL key (SEQ-ACCESS seq pointer))
  1455.             pushSTACK(value1); # =: value
  1456.             goto into_fromend_loop;
  1457.           }
  1458.           else
  1459.           # initial-value ist angegeben
  1460.           { pushSTACK(STACK_(0+3)); } # value := initial-value
  1461.         # Stackaufbau: function, seq, from-end, start, end, key, initial-value,
  1462.         #              typdescr, count, pointer, value.
  1463.         do { # nächstes value berechnen:
  1464.              pushSTACK(STACK_(5+4)); pushSTACK(STACK_(1+1));
  1465.              funcall(seq_access(STACK_(3+2)),2); # (SEQ-ACCESS seq pointer)
  1466.              funcall_key(STACK_(1+4)); # (FUNCALL key (SEQ-ACCESS seq pointer))
  1467.              pushSTACK(value1); pushSTACK(STACK_(0+1));
  1468.              funcall(STACK_(6+4+2),2); # (FUNCALL fun (FUNCALL key (SEQ-ACCESS seq pointer)) value)
  1469.              STACK_0 = value1; # =: value
  1470.              into_fromend_loop:
  1471.              # pointer weiterrücken:
  1472.              pointer_fe_update(STACK_1,STACK_(5+4),STACK_3);
  1473.              # count := (1- count) :
  1474.              decrement(STACK_2);
  1475.            }
  1476.            until (eq(STACK_2,Fixnum_0)); # count (ein Integer) = 0 ?
  1477.         value1 = popSTACK(); mv_count=1; # value als Wert
  1478.         skipSTACK(7+3);
  1479.       }
  1480.       else
  1481.       # from-end ist nicht angegeben
  1482.       { # Durchlauf-Pointer bestimmen:
  1483.         pushSTACK(STACK_(5+2)); pushSTACK(STACK_(3+2+1));
  1484.         funcall(seq_init_start(STACK_(1+2)),2); # (SEQ-INIT-START seq start)
  1485.         pushSTACK(value1); # =: pointer
  1486.         # Stackaufbau: function, sequence, from-end, start, end, key, initial-value,
  1487.         #              typdescr, count, pointer.
  1488.         # Startwert bestimmen:
  1489.         if (eq(STACK_(0+3),unbound))
  1490.           # initial-value ist nicht angegeben
  1491.           { pushSTACK(STACK_(5+3)); pushSTACK(STACK_(0+1));
  1492.             funcall(seq_access(STACK_(2+2)),2); # (SEQ-ACCESS seq pointer)
  1493.             funcall_key(STACK_(1+3)); # (FUNCALL key (SEQ-ACCESS seq pointer))
  1494.             pushSTACK(value1); # =: value
  1495.             goto into_fromstart_loop;
  1496.           }
  1497.           else
  1498.           # initial-value ist angegeben
  1499.           { pushSTACK(STACK_(0+3)); } # value := initial-value
  1500.         # Stackaufbau: function, seq, from-end, start, end, key, initial-value,
  1501.         #              typdescr, count, pointer, value.
  1502.         do { # nächstes value berechnen:
  1503.              pushSTACK(STACK_(5+4)); pushSTACK(STACK_(1+1));
  1504.              funcall(seq_access(STACK_(3+2)),2); # (SEQ-ACCESS seq pointer)
  1505.              funcall_key(STACK_(1+4)); # (FUNCALL key (SEQ-ACCESS seq pointer))
  1506.              pushSTACK(STACK_0); pushSTACK(value1);
  1507.              funcall(STACK_(6+4+2),2); # (FUNCALL fun value (FUNCALL key (SEQ-ACCESS seq pointer)))
  1508.              STACK_0 = value1; # =: value
  1509.              into_fromstart_loop:
  1510.              # pointer weiterrücken:
  1511.              pointer_update(STACK_1,STACK_(5+4),STACK_3);
  1512.              # count := (1- count) :
  1513.              decrement(STACK_2);
  1514.            }
  1515.            until (eq(STACK_2,Fixnum_0)); # count (ein Integer) = 0 ?
  1516.         value1 = popSTACK(); mv_count=1; # value als Wert
  1517.         skipSTACK(7+3);
  1518.       }
  1519.   }
  1520.  
  1521. LISPFUN(fill,2,0,norest,key,2, (kw(start),kw(end)) )
  1522. # (FILL sequence item [:start] [:end]), CLTL S. 252
  1523.   { # Stackaufbau: sequence, item, start, end.
  1524.     # sequence überprüfen:
  1525.     pushSTACK(get_valid_seq_type(STACK_3));
  1526.     # Stackaufbau: sequence, item, start, end, typdescr.
  1527.     # Defaultwert für start ist 0:
  1528.     start_default_0(STACK_2);
  1529.     # Defaultwert für end ist die Länge der Sequence:
  1530.     end_default_len(STACK_1,STACK_4,STACK_0);
  1531.     # start- und end-Argumente überprüfen:
  1532.     test_start_end(&O(kwpair_start),&STACK_1);
  1533.     # start- und end-Argumente subtrahieren:
  1534.     STACK_1 = I_I_minus_I(STACK_1,STACK_2); # (- end start), ein Integer >=0
  1535.     # Stackaufbau: sequence, item, start, count, typdescr.
  1536.     # Durchlauf-Pointer bestimmen:
  1537.     pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  1538.     funcall(seq_init_start(STACK_(0+2)),2); # (SEQ-INIT-START sequence start)
  1539.     STACK_2 = value1; # =: pointer
  1540.     # Stackaufbau: sequence, item, pointer, count, typdescr.
  1541.     until (eq(STACK_1,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  1542.       { pushSTACK(STACK_4); pushSTACK(STACK_(2+1)); pushSTACK(STACK_(3+2));
  1543.         funcall(seq_access_set(STACK_(0+3)),3); # (SEQ-ACCESS-SET sequence pointer item)
  1544.         # pointer := (SEQ-UPD sequence pointer) :
  1545.         pointer_update(STACK_2,STACK_4,STACK_0);
  1546.         # count := (1- count) :
  1547.         decrement(STACK_1);
  1548.       }
  1549.     skipSTACK(4);
  1550.     value1 = popSTACK(); mv_count=1; # sequence als Wert
  1551.   }
  1552.  
  1553. LISPFUN(replace,2,0,norest,key,4,\
  1554.         (kw(start1),kw(end1),kw(start2),kw(end2)) )
  1555. # (REPLACE sequence1 sequence2 [:start1] [:end1] [:start2] [:end2]),
  1556. # CLTL S. 252
  1557.   { # Methode (schematisch):
  1558.     # Argumente überprüfen.
  1559.     # Anzahl der zu kopierenden Elemente bestimmen:
  1560.     #   count1 := (- end1 start1), count2 := (- end2 start2).
  1561.     #   count1 < count2  ->  count := count1, end2 := (+ start2 count).
  1562.     #   count1 > count2  ->  count := count2, #| end1 := (+ start1 count) |# .
  1563.     # Nun ist (= count #|(- end1 start1)|# (- end2 start2)).
  1564.     # Falls sequence1 und sequence2 EQ sind, die Indexbereiche sich
  1565.     # überschneiden (also nicht (or (>= start2 end1) (>= start1 end2)) gilt)
  1566.     # und nach oben kopiert werden soll (also (< start2 start1) gilt):
  1567.     #   Das Source-Stück aus sequence2 herauskopieren:
  1568.     #   (unless (or #|(>= start2 end1)|# (>= start1 end2) (>= start2 start1))
  1569.     #     (psetq sequence2 (subseq sequence2 start2 end2)
  1570.     #            start2    0
  1571.     #         #| end2      count |#
  1572.     #   ) )
  1573.     # Dann elementweise kopieren: für i=0,1,...
  1574.     #   (setf (elt sequence1 (+ start1 i)) (elt sequence2 (+ start2 i))).
  1575.     # Stackaufbau: sequence1, sequence2, start1, end1, start2, end2.
  1576.     # sequence1 überprüfen:
  1577.     pushSTACK(get_valid_seq_type(STACK_5));
  1578.     # sequence1 überprüfen:
  1579.     pushSTACK(get_valid_seq_type(STACK_(4+1)));
  1580.     # Stackaufbau: sequence1, sequence2, start1, end1, start2, end2,
  1581.     #              typdescr1, typdescr2.
  1582.     # Defaultwert für start1 ist 0:
  1583.     start_default_0(STACK_(3+2));
  1584.     # Defaultwert für end1 ist die Länge von sequence1:
  1585.     end_default_len(STACK_(2+2),STACK_(5+2),STACK_1);
  1586.     # Defaultwert für start2 ist 0:
  1587.     start_default_0(STACK_(1+2));
  1588.     # Defaultwert für end2 ist die Länge von sequence2:
  1589.     end_default_len(STACK_(0+2),STACK_(4+2),STACK_0);
  1590.     # start- und end-Argumente überprüfen:
  1591.     test_start_end(&O(kwpair_start1),&STACK_(2+2));
  1592.     test_start_end(&O(kwpair_start2),&STACK_(0+2));
  1593.     # count1 bestimmen:
  1594.     STACK_(2+2) = I_I_minus_I(STACK_(2+2),STACK_(3+2)); # (- end1 start1) = count1
  1595.     # Stackaufbau: sequence1, sequence2, start1, count1, start2, end2,
  1596.     #              typdescr1, typdescr2.
  1597.     # count2 bestimmen:
  1598.    {var reg1 object count2 = I_I_minus_I(STACK_(0+2),STACK_(1+2)); # (- end2 start2)
  1599.     # count bestimmen und evtl. end2 herabsetzen:
  1600.     if (I_I_comp(STACK_(2+2),count2)<0) # count1 < count2 ?
  1601.       { # ja -> count1 ist das Minimum
  1602.         STACK_(0+2) = I_I_plus_I(STACK_(1+2),STACK_(2+2)); # end2 := (+ start2 count1)
  1603.       }
  1604.       else
  1605.       { # nein -> count2 ist das Minimum
  1606.         STACK_(2+2) = count2; # count := count2
  1607.    }  }
  1608.     # Stackaufbau: sequence1, sequence2, start1, count, start2, end2,
  1609.     #              typdescr1, typdescr2.
  1610.     # Falls beide Sequences dieselben sind und die Bereiche sich
  1611.     # überschneiden, muß die Source erst herauskopiert werden:
  1612.     if (eq(STACK_(5+2),STACK_(4+2)) # (eq sequence1 sequence2)
  1613.         && (I_I_comp(STACK_(1+2),STACK_(3+2))<0) # (< start2 start1)
  1614.         && (I_I_comp(STACK_(3+2),STACK_(0+2))<0) # (< start1 end2)
  1615.        )
  1616.       { # Stück aus sequence2 herauskopieren:
  1617.         pushSTACK(STACK_(4+2)); pushSTACK(STACK_(1+2+1)); pushSTACK(STACK_(0+2+2));
  1618.         pushSTACK(STACK_(0+3)); subseq(); # (SUBSEQ sequence2 start2 end2)
  1619.         STACK_(4+2) = value1; # =: sequence2
  1620.         # Indizes adjustieren:
  1621.         STACK_(1+2) = Fixnum_0; # start2 := 0
  1622.       }
  1623.     # Stackaufbau: sequence1, sequence2, start1, count, start2, dummy,
  1624.     #              typdescr1, typdescr2.
  1625.     # Argumente für copy_seqpart_into auf den Stack legen:
  1626.     pushSTACK(STACK_(4+2+0)); pushSTACK(STACK_(0+1));
  1627.     pushSTACK(STACK_(5+2+2)); pushSTACK(STACK_(1+3));
  1628.     pushSTACK(STACK_(2+2+4));
  1629.     # Stackaufbau: sequence1, sequence2, start1, count, start2, dummy,
  1630.     #              typdescr1, typdescr2,
  1631.     #              sequence2, typdescr2, sequence1, typdescr1, count.
  1632.     pushSTACK(STACK_4); pushSTACK(STACK_(1+2+5+1));
  1633.     funcall(seq_init_start(STACK_(3+2)),2); # (SEQ-INIT-START sequence2 start2)
  1634.     pushSTACK(value1); # =: pointer2
  1635.     pushSTACK(STACK_(2+1)); pushSTACK(STACK_(3+2+5+1+1));
  1636.     funcall(seq_init_start(STACK_(1+1+2)),2); # (SEQ-INIT-START sequence1 start1)
  1637.     pushSTACK(value1); # =: pointer1
  1638.     # Stackaufbau: sequence1, sequence2, start1, count, start2, dummy,
  1639.     #              typdescr1, typdescr2,
  1640.     #              sequence2, typdescr2, sequence1, typdescr1, count,
  1641.     #              pointer2, pointer1.
  1642.     copy_seqpart_into(); # kopiere von sequence2 nach sequence1
  1643.     skipSTACK(5+2+5+2);
  1644.     value1 = popSTACK(); mv_count=1; # sequence1 als Wert
  1645.   }
  1646.  
  1647. # Unterprogramm zum Ausführen des Tests :TEST
  1648. # up_test(stackptr,x)
  1649. # > *(stackptr-5): die Testfunktion
  1650. # > *(stackptr+1): das zu vergleichende Item
  1651. # > x: Argument
  1652. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1653. # kann GC auslösen
  1654.   local boolean up_test (object* stackptr, object x);
  1655.   local boolean up_test(stackptr,x)
  1656.     var object* stackptr;
  1657.     var object x;
  1658.     { # nach CLTL S. 247 ein (funcall testfun item x) ausführen:
  1659.       pushSTACK(*(stackptr STACKop 1)); # item
  1660.       pushSTACK(x); # x
  1661.       funcall(*(stackptr STACKop -5),2);
  1662.       if (nullp(value1)) return FALSE; else return TRUE;
  1663.     }
  1664.  
  1665. # Unterprogramm zum Ausführen des Tests :TEST-NOT
  1666. # up_test_not(stackptr,x)
  1667. # > *(stackptr-6): die Testfunktion
  1668. # > *(stackptr+1): das zu vergleichende Item
  1669. # > x: Argument
  1670. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1671. # kann GC auslösen
  1672.   local boolean up_test_not (object* stackptr, object x);
  1673.   local boolean up_test_not(stackptr,x)
  1674.     var object* stackptr;
  1675.     var object x;
  1676.     { # nach CLTL S. 247 ein (not (funcall testfun item x)) ausführen:
  1677.       pushSTACK(*(stackptr STACKop 1)); # item
  1678.       pushSTACK(x); # x
  1679.       funcall(*(stackptr STACKop -6),2);
  1680.       if (nullp(value1)) return TRUE; else return FALSE;
  1681.     }
  1682.  
  1683. # Unterprogramm zum Ausführen des Tests -IF
  1684. # up_if(stackptr,x)
  1685. # > *(stackptr+1): das Testprädikat
  1686. # > x: Argument
  1687. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1688. # kann GC auslösen
  1689.   local boolean up_if (object* stackptr, object x);
  1690.   local boolean up_if(stackptr,x)
  1691.     var object* stackptr;
  1692.     var object x;
  1693.     { # nach CLTL S. 247 ein (funcall predicate x) ausführen:
  1694.       pushSTACK(x); funcall(*(stackptr STACKop 1),1);
  1695.       if (nullp(value1)) return FALSE; else return TRUE;
  1696.     }
  1697.  
  1698. # Unterprogramm zum Ausführen des Tests -IF-NOT
  1699. # up_if_not(stackptr,x)
  1700. # > *(stackptr+1): das Testprädikat
  1701. # > x: Argument
  1702. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1703. # kann GC auslösen
  1704.   local boolean up_if_not (object* stackptr, object x);
  1705.   local boolean up_if_not(stackptr,x)
  1706.     var object* stackptr;
  1707.     var object x;
  1708.     { # nach CLTL S. 247 ein (not (funcall predicate x)) ausführen:
  1709.       pushSTACK(x); funcall(*(stackptr STACKop 1),1);
  1710.       if (nullp(value1)) return TRUE; else return FALSE;
  1711.     }
  1712.  
  1713. # UP: Überprüft das :COUNT-Argument
  1714. # > STACK_1: optionales Argument
  1715. # > subr_self: Aufrufer (ein SUBR)
  1716. # < STACK_1: korrekter COUNT-Wert: NIL oder ein Integer >=0
  1717.   local void test_count_arg (void);
  1718.   local void test_count_arg()
  1719.     { var reg1 object count = STACK_1;
  1720.       if (eq(count,unbound))
  1721.         { STACK_1 = NIL; } # Defaultwert NIL
  1722.         else
  1723.         # COUNT-Argument muß NIL oder ein Integer >= 0 sein:
  1724.         if (!(nullp(count) || (integerp(count) && positivep(count))))
  1725.           { fehler_posint(TheSubr(subr_self)->name,S(Kcount),count); }
  1726.     }
  1727.  
  1728. # Fehler, wenn beide :TEST, :TEST-NOT - Argumente angegeben wurden.
  1729. # fehler_both_tests();
  1730. # > subr_self: Aufrufer (ein SUBR)
  1731.   nonreturning_function(global, fehler_both_tests, (void));
  1732.   global void fehler_both_tests()
  1733.     { pushSTACK(TheSubr(subr_self)->name);
  1734.       //: DEUTSCH "~: Argumente zu :TEST und :TEST-NOT dürfen nicht beide angegeben werden."
  1735.       //: ENGLISH "~: Must not specify both arguments to :TEST and :TEST-NOT"
  1736.       //: FRANCAIS "~ : Les arguments pour :TEST et :TEST-NOT ne peuvent être spécifiés en même temps."
  1737.       fehler(error, GETTEXT("~: Must not specify both arguments to :TEST and :TEST-NOT"));
  1738.     }
  1739.  
  1740. # UP: Überprüft die :TEST, :TEST-NOT - Argumente
  1741. # test_test_args(stackptr)
  1742. # > stackptr: Pointer in den STACK
  1743. # > *(stackptr-5): :TEST-Argument
  1744. # > *(stackptr-6): :TEST-NOT-Argument
  1745. # > subr_self: Aufrufer (ein SUBR)
  1746. # < *(stackptr-5): verarbeitetes :TEST-Argument
  1747. # < *(stackptr-6): verarbeitetes :TEST-NOT-Argument
  1748. # < up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  1749. #       > stackptr: derselbe Pointer in den Stack, *(stackptr+1) = item,
  1750. #         *(stackptr-5) = :test-Argument, *(stackptr-6) = :test-not-Argument,
  1751. #       > x: Argument
  1752. #       < TRUE, falls der Test erfüllt ist, FALSE sonst.
  1753.   # up_function sei der Typ der Adresse einer solchen Testfunktion:
  1754.   typedef boolean (*up_function) (object* stackptr, object x);
  1755.   local up_function test_test_args (object* stackptr);
  1756.   local up_function test_test_args(stackptr)
  1757.     var reg1 object* stackptr;
  1758.     { var reg3 object test_arg = *(stackptr STACKop -5);
  1759.       if (eq(test_arg,unbound)) { test_arg=NIL; }
  1760.       # test_arg ist das :TEST-Argument
  1761.      {var reg2 object test_not_arg = *(stackptr STACKop -6);
  1762.       if (eq(test_not_arg,unbound)) { test_not_arg=NIL; }
  1763.       # test_not_arg ist das :TEST-NOT-Argument
  1764.       if (nullp(test_not_arg))
  1765.         # :TEST-NOT wurde nicht angegeben
  1766.         { if (nullp(test_arg))
  1767.             *(stackptr STACKop -5) = L(eql); # #'EQL als Default für :TEST
  1768.           return(&up_test);
  1769.         }
  1770.         # :TEST-NOT wurde angegeben
  1771.         { if (nullp(test_arg))
  1772.             return(&up_test_not);
  1773.           else
  1774.             fehler_both_tests();
  1775.     }}  }
  1776.  
  1777. # UP: bereitet eine Sequence-Operation mit Test vor.
  1778. # > Stackaufbau:
  1779. #     ... sequence [stackptr] from-end start end key ... [STACK]
  1780. #   genauer:
  1781. #     ... item sequence [stackptr] from-end start end key test test-not ... [STACK]
  1782. #     oder
  1783. #     ... test sequence [stackptr] from-end start end key ... [STACK]
  1784. #     oder
  1785. #     ... test-not sequence [stackptr] from-end start end key ... [STACK]
  1786. # > stackptr: Pointer in den Stack
  1787. # > subr_self: Aufrufer (ein SUBR)
  1788. # < STACK: wird um 1 erniedrigt
  1789. # < STACK_0: typdescr zu sequence
  1790.   local void seq_prepare_testop (object* stackptr);
  1791.   local void seq_prepare_testop(stackptr)
  1792.     var reg1 object* stackptr;
  1793.     { # sequence überprüfen, typdescr auf den Stack:
  1794.       pushSTACK(get_valid_seq_type(*(stackptr STACKop 0)));
  1795.       # key überprüfen:
  1796.       test_key_arg(stackptr);
  1797.       # Defaultwert für from-end ist NIL:
  1798.       default_NIL(*(stackptr STACKop -1));
  1799.       # Defaultwert für start ist 0:
  1800.       start_default_0(*(stackptr STACKop -2));
  1801.       # Defaultwert für end ist NIL:
  1802.       default_NIL(*(stackptr STACKop -3));
  1803.       # start und end überprüfen:
  1804.       test_start_end_1(&O(kwpair_start),&*(stackptr STACKop -3));
  1805.     }
  1806.  
  1807. # UP: führt eine Sequence-Filter-Operation aus.
  1808. # Eine Sequence wird durchlaufen und dabei in einem Bit-Vektor abgespeichert,
  1809. # welche Elemente dem Test genügen. Dann wird eine Routine aufgerufen, die
  1810. # den Rest erledigt.
  1811. # > Stackaufbau:
  1812. #     ... sequence [stackptr] from-end start end key ... count typdescr [STACK]
  1813. # > stackptr: Pointer in den Stack
  1814. # > up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  1815. #           > stackptr: derselbe Pointer in den Stack,
  1816. #           > x: Argument
  1817. #           < TRUE, falls der Test erfüllt ist, FALSE sonst.
  1818. # > help_fun: Adresse einer Hilfsroutine, die den Rest erledigt.
  1819. #   Spezifiziert durch:
  1820. #       > stackptr: Pointer in den Stack,
  1821. #         *(stackptr+0)=sequence, *(stackptr-2)=start, *(stackptr-3)=end,
  1822. #       > STACK_2: typdescr,
  1823. #       > STACK_1: Länge l der Sequence,
  1824. #       > STACK_0: Bit-Vektor bv,
  1825. #       > bvl: Länge des Bit-Vektors (= end - start),
  1826. #       > dl: Anzahl der im Bit-Vektor gesetzten Bits,
  1827. #       < ergebnis: Ergebnis
  1828. # > subr_self: Aufrufer (ein SUBR)
  1829. # < mv_space/mv_count: Werte
  1830. # kann GC auslösen
  1831.   # help_function sei der Typ der Adresse einer solchen Hilfsfunktion:
  1832.   typedef object (*help_function) (object* stackptr, uintL bvl, uintL dl);
  1833.   local Values seq_filterop (object* stackptr, up_function up_fun, help_function help_fun);
  1834.   local Values seq_filterop(stackptr,up_fun,help_fun)
  1835.     var reg1 object* stackptr;
  1836.     var reg5 up_function up_fun;
  1837.     var reg6 help_function help_fun;
  1838.     { # COUNT-Argument muß NIL oder ein Integer >= 0 sein:
  1839.       test_count_arg();
  1840.      {var reg7 object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet!
  1841.       # l = (SEQ-LENGTH sequence) bestimmen:
  1842.       pushSTACK(*(stackptr STACKop 0)); # sequence
  1843.       funcall(seq_length(STACK_(0+1)),1); # (SEQ-LENGTH sequence)
  1844.       pushSTACK(value1); # l in den Stack
  1845.       subr_self = old_subr_self;
  1846.      }
  1847.       # Defaultwert für END ist l:
  1848.       if (nullp(*(stackptr STACKop -3))) # end=NIL ?
  1849.         { *(stackptr STACKop -3) = STACK_0; # ja -> end:=l
  1850.           # Dann nochmals start und end überprüfen:
  1851.           test_start_end(&O(kwpair_start),&*(stackptr STACKop -3));
  1852.         }
  1853.       # Nun sind alle Argumente überprüft.
  1854.       pushSTACK(*(stackptr STACKop 0)); # sequence
  1855.       pushSTACK(*(stackptr STACKop -4)); # key
  1856.       # (- end start) bestimmen und neuen Bitvektor allozieren:
  1857.      {var reg3 uintL bvl; # Bitvektor-Länge
  1858.       var reg4 uintL dl = 0; # Anzahl der im Bitvektor gesetzten Bits
  1859.       { var reg2 object bvsize = I_I_minus_I(*(stackptr STACKop -3),*(stackptr STACKop -2));
  1860.         # bvsize = (- end start), ein Integer >=0
  1861.         if (!(posfixnump(bvsize))) # Fixnum?
  1862.           { pushSTACK(*(stackptr STACKop 0)); # sequence
  1863.             pushSTACK(TheSubr(subr_self)->name);
  1864.             //: DEUTSCH "~: Zu lange Sequence: ~"
  1865.             //: ENGLISH "~: sequence ~ is too long"
  1866.             //: FRANCAIS "~ : Séquence trop longue: ~"
  1867.             fehler(error, GETTEXT("~: sequence ~ is too long"));
  1868.           }
  1869.         bvl = posfixnum_to_L(bvsize); # Länge des Bitvektors als Longword
  1870.       }
  1871.       pushSTACK(allocate_bit_vector_0(bvl)); # neuer Bitvektor bv
  1872.       # Stackaufbau: ... count, typdescr,
  1873.       #              l, sequence, key, bv [STACK].
  1874.       if (!(nullp(*(stackptr STACKop -1)))) # from-end abfragen
  1875.         # from-end ist angegeben
  1876.         { pushSTACK(STACK_2); # sequence
  1877.           pushSTACK(*(stackptr STACKop -3)); # end
  1878.           funcall(seq_fe_init_end(STACK_(0+4+2)),2); # (SEQ-FE-INIT-END sequence end)
  1879.           pushSTACK(value1); # =: pointer
  1880.           pushSTACK(STACK_(1+4+1)); # countdown := count
  1881.           # Stackaufbau: ... count, typdescr,
  1882.           #              l, sequence, key, bv,
  1883.           #              pointer, countdown [STACK].
  1884.          {var reg2 uintL bvi = bvl; # Schleife bvl mal durchlaufen
  1885.           until (bvi==0)
  1886.             { bvi--;
  1887.               if (!(nullp(STACK_(1+4+2))) && eq(STACK_0,Fixnum_0))
  1888.                 # count/=NIL und countdown=0 -> Schleife kann abgebrochen werden
  1889.                 break;
  1890.               # nächstes Element abtesten:
  1891.               pushSTACK(STACK_(2+2)); # sequence
  1892.               pushSTACK(STACK_(1+1)); # pointer
  1893.               funcall(seq_access(STACK_(0+4+2+2)),2); # (SEQ-ACCESS sequence pointer)
  1894.               funcall_key(STACK_(1+2)); # (FUNCALL key ...)
  1895.               if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  1896.                 # Test erfüllt
  1897.                 { sbvector_bset(STACK_(0+2),bvi); # (setf (sbit bv bvi) 1)
  1898.                   dl++; # dl := dl+1, ein gesetztes Bit mehr
  1899.                   if (!(nullp(STACK_(1+4+2)))) # falls count/=NIL:
  1900.                     { decrement(STACK_0); } # (decf countdown)
  1901.                 }
  1902.               # pointer weiterrücken:
  1903.               pointer_fe_update(STACK_1,STACK_(2+2),STACK_(0+4+2));
  1904.         }}  }
  1905.         else
  1906.         # from-end ist nicht angegeben
  1907.         { pushSTACK(STACK_2); # sequence
  1908.           pushSTACK(*(stackptr STACKop -2)); # start
  1909.           funcall(seq_init_start(STACK_(0+4+2)),2); # (SEQ-INIT-START sequence start)
  1910.           pushSTACK(value1); # =: pointer
  1911.           pushSTACK(STACK_(1+4+1)); # countdown := count
  1912.           # Stackaufbau: ... count, typdescr,
  1913.           #              l, sequence, key, bv,
  1914.           #              pointer, countdown [STACK].
  1915.          {var reg2 uintL bvi = 0; # Schleife bvl mal durchlaufen
  1916.           until (bvi==bvl)
  1917.             { if (!(nullp(STACK_(1+4+2))) && eq(STACK_0,Fixnum_0))
  1918.                 # count/=NIL und countdown=0 -> Schleife kann abgebrochen werden
  1919.                 break;
  1920.               # nächstes Element abtesten:
  1921.               pushSTACK(STACK_(2+2)); # sequence
  1922.               pushSTACK(STACK_(1+1)); # pointer
  1923.               funcall(seq_access(STACK_(0+4+2+2)),2); # (SEQ-ACCESS sequence pointer)
  1924.               funcall_key(STACK_(1+2)); # (FUNCALL key ...)
  1925.               if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  1926.                 # Test erfüllt
  1927.                 { sbvector_bset(STACK_(0+2),bvi); # (setf (sbit bv bvi) 1)
  1928.                   dl++; # dl := dl+1, ein gesetztes Bit mehr
  1929.                   if (!(nullp(STACK_(1+4+2)))) # falls count/=NIL:
  1930.                     { decrement(STACK_0); } # (decf countdown)
  1931.                 }
  1932.               # pointer weiterrücken:
  1933.               pointer_update(STACK_1,STACK_(2+2),STACK_(0+4+2));
  1934.               bvi++;
  1935.         }}  }
  1936.       skipSTACK(2); # pointer und countdown vergessen
  1937.       # Stackaufbau: ... count, typdescr,
  1938.       #              l, sequence, key, bv [STACK].
  1939.       STACK_2 = STACK_0; skipSTACK(2); # bv hochschieben
  1940.       # Stackaufbau: ... count, typdescr, l, bv [STACK].
  1941.       value1 = (*help_fun)(stackptr,bvl,dl); # Rest durchführen
  1942.       mv_count=1; # Ergebnis als Wert
  1943.       skipSTACK(2); # l und bv vergessen
  1944.     }}
  1945.  
  1946. # UP: Hilfsroutine für REMOVE-Funktionen.
  1947. # Bildet zu einer Sequence eine neue Sequence, in der genau die Elemente
  1948. # fehlen, die in einem Bitvektor markiert sind.
  1949. # > stackptr: Pointer in den Stack,
  1950. #   *(stackptr+0)=sequence, *(stackptr-2)=start, *(stackptr-3)=end,
  1951. # > STACK_2: typdescr,
  1952. # > STACK_1: Länge l der Sequence,
  1953. # > STACK_0: Bit-Vektor bv,
  1954. # > bvl: Länge des Bit-Vektors (= end - start),
  1955. # > dl: Anzahl der im Bit-Vektor gesetzten Bits,
  1956. # < ergebnis: Ergebnis
  1957. # kann GC auslösen
  1958.   local object remove_help (object* stackptr, uintL bvl, uintL dl);
  1959.   local object remove_help(stackptr,bvl,dl)
  1960.     var reg1 object* stackptr;
  1961.     var reg3 uintL bvl;
  1962.     var reg4 uintL dl;
  1963.     { # dl=0 -> sequence unverändert zurückgeben:
  1964.       if (dl==0) { return *(stackptr STACKop 0); }
  1965.       # neue Sequence allozieren:
  1966.       pushSTACK(I_I_minus_I(STACK_1,fixnum(dl))); # (- l dl)
  1967.       funcall(seq_make(STACK_(2+1)),1); # (SEQ-MAKE (- l dl))
  1968.       pushSTACK(value1);
  1969.       # Stackaufbau: typdescr, l, bv, sequence2.
  1970.       pushSTACK(*(stackptr STACKop 0)); # sequence
  1971.       pushSTACK(STACK_(3+1)); # typdescr
  1972.       pushSTACK(STACK_(0+2)); # sequence2
  1973.       pushSTACK(STACK_(3+3)); # typdescr
  1974.       pushSTACK(*(stackptr STACKop -2)); # start
  1975.       # Stackaufbau: typdescr, l, bv, sequence2,
  1976.       #              seq1, typdescr1, seq2, typdescr2, start.
  1977.       pushSTACK(STACK_4); funcall(seq_init(STACK_(3+1)),1); # (SEQ-INIT sequence)
  1978.       pushSTACK(value1); # =: pointer1
  1979.       pushSTACK(STACK_(2+1)); funcall(seq_init(STACK_(1+1+1)),1); # (SEQ-INIT sequence2)
  1980.       pushSTACK(value1); # =: pointer2
  1981.       # Stackaufbau: typdescr, l, bv, sequence2,
  1982.       #              seq1, typdescr1, seq2, typdescr2, start,
  1983.       #              pointer1, pointer2.
  1984.       { # Vorderes Teilstück:
  1985.         # Elemente mit Index <start von sequence1 nach sequence2
  1986.         # unverändert übertragen:
  1987.         copy_seqpart_into();
  1988.       }
  1989.       { # Mittleres Teilstück: sieben.
  1990.         var reg2 uintL bvi = 0;
  1991.         until (bvi==bvl)
  1992.           { if (!(sbvector_btst(STACK_(1+5+2),bvi))) # (sbit bv bvi) abfragen
  1993.               # Bit ist nicht gesetzt, also Element übernehmen
  1994.               { pushSTACK(STACK_(4+2)); pushSTACK(STACK_(1+1));
  1995.                 funcall(seq_access(STACK_(3+2+2)),2); # (SEQ-ACCESS seq1 pointer1)
  1996.                 pushSTACK(STACK_(2+2)); pushSTACK(STACK_(0+1)); pushSTACK(value1);
  1997.                 funcall(seq_access_set(STACK_(1+2+3)),3); # (SEQ-ACCESS-SET seq2 pointer2 ...)
  1998.                 # pointer2 := (SEQ-UPD seq2 pointer2) :
  1999.                 pointer_update(STACK_0,STACK_(2+2),STACK_(1+2));
  2000.               }
  2001.             # pointer1 := (SEQ-UPD seq1 pointer1) :
  2002.             pointer_update(STACK_1,STACK_(4+2),STACK_(3+2));
  2003.             bvi++;
  2004.       }   }
  2005.       { # Hinteres Teilstück:
  2006.         # Elemente mit Index >=end von sequence1 nach sequence2
  2007.         # unverändert übertragen:
  2008.         STACK_(0+2) = I_I_minus_I(STACK_(2+5+2),*(stackptr STACKop -3)); # (- l end)
  2009.         copy_seqpart_into();
  2010.       }
  2011.       skipSTACK(5+2);
  2012.       return popSTACK(); # sequence2 als Ergebnis
  2013.     }
  2014.  
  2015. # UP: Hilfsroutine für DELETE-Funktionen.
  2016. # Entfernt aus einer Sequence genau die Elemente, die in einem Bitvektor
  2017. # markiert sind.
  2018. # > stackptr: Pointer in den Stack,
  2019. #   *(stackptr+0)=sequence, *(stackptr-2)=start, *(stackptr-3)=end,
  2020. # > STACK_2: typdescr,
  2021. # > STACK_1: Länge l der Sequence,
  2022. # > STACK_0: Bit-Vektor bv,
  2023. # > bvl: Länge des Bit-Vektors (= end - start),
  2024. # > dl: Anzahl der im Bit-Vektor gesetzten Bits,
  2025. # < ergebnis: Ergebnis
  2026. # kann GC auslösen
  2027.   local object delete_help (object* stackptr, uintL bvl, uintL dl);
  2028.   local object delete_help(stackptr,bvl,dl)
  2029.     var reg4 object* stackptr;
  2030.     var reg5 uintL bvl;
  2031.     var reg6 uintL dl;
  2032.     { # dl=0 -> sequence unverändert zurückgeben:
  2033.       if (dl==0) { return *(stackptr STACKop 0); }
  2034.      {var reg7 object type = seq_type(STACK_2);
  2035.       if (eq(type,S(list))) # Typ LIST ?
  2036.         { # Noch überprüfen, ob sequence wirklich eine Liste ist.
  2037.           # Wegen l >= dl > 0 ist zu testen, ob sequence ein Cons ist.
  2038.           if (mconsp(*(stackptr STACKop 0)))
  2039.             { # Listen speziell behandeln:
  2040.               var object whole_list = *(stackptr STACKop 0); # ganze Liste
  2041.               var reg1 object* list_ = &whole_list;
  2042.               var reg2 object list = *list_;
  2043.               # Stets list = *list_.
  2044.               # Vorderes Teilstück:
  2045.               # start mal mit list:=Cdr(list) weiterrücken:
  2046.               { var reg3 uintL count;
  2047.                 dotimesL(count,posfixnum_to_L(*(stackptr STACKop -2)),
  2048.                   { list_ = &Cdr(list); list = *list_; });
  2049.               }
  2050.               # Mittleres Teilstück:
  2051.               # bvl mal ein Bit abfragen und evtl. ein Cons streichen:
  2052.               { var reg3 uintL bvi = 0;
  2053.                 until (bvi==bvl)
  2054.                   { if (sbvector_btst(STACK_0,bvi)) # (sbit bv bvi) abfragen
  2055.                       # Bit ist =1 -> Cons bei list herausnehmen:
  2056.                       { *list_ = list = Cdr(list); }
  2057.                       else
  2058.                       # Bit ist =0 -> nur weiterrücken:
  2059.                       { list_ = &Cdr(list); list = *list_; }
  2060.                     bvi++;
  2061.               }   }
  2062.               return whole_list; # modifizierte Liste als Ergebnis
  2063.             }
  2064.             else
  2065.             goto other;
  2066.         }
  2067.       elif (eq(type,S(vector)) || eq(type,S(string)) || eq(type,S(bit_vector)) || posfixnump(type))
  2068.         # Typ [GENERAL-]VECTOR, STRING, BIT-VECTOR, Byte-VECTOR
  2069.         { # Noch überprüfen, ob sequence wirklich ein Vektor ist.
  2070.           var reg3 object sequence = *(stackptr STACKop 0);
  2071.           if (!(vectorp(sequence))) { goto other; }
  2072.           # Bei Arrays ohne Fill-Pointer kann man nichts Spezielles machen:
  2073.           if (!(array_has_fill_pointer_p(sequence))) { goto other; }
  2074.           # sequence ist ein Vektor mit Fill-Pointer.
  2075.           # Elemente zusammenschieben und dann Fill-Pointer herabsetzen:
  2076.           pushSTACK(sequence); # sequence
  2077.           pushSTACK(*(stackptr STACKop -2)); # i := start
  2078.           pushSTACK(STACK_0); # j := i
  2079.           # Stackaufbau: typdescr, l, bv, sequence, i, j.
  2080.           # j = Source-Index, i = Destination-Index, start <= i <= j .
  2081.           # Mittleres Teilstück:
  2082.           { var reg1 uintL bvi = 0;
  2083.             until (bvi==bvl)
  2084.               { if (!(sbvector_btst(STACK_3,bvi))) # (sbit bv bvi) abfragen
  2085.                   # Bit gelöscht -> Element übertragen:
  2086.                   { # (setf (aref sequence i) (aref sequence j)) :
  2087.                     pushSTACK(STACK_2); pushSTACK(STACK_(0+1));
  2088.                     funcall(L(aref),2); # (AREF sequence j)
  2089.                     pushSTACK(STACK_2); pushSTACK(STACK_(1+1)); pushSTACK(value1);
  2090.                     funcall(L(store),3); # (SYS::STORE sequence i ...)
  2091.                     # i:=i+1 :
  2092.                     STACK_1 = fixnum_inc(STACK_1,1);
  2093.                   }
  2094.                 # j:=j+1 :
  2095.                 STACK_0 = fixnum_inc(STACK_0,1);
  2096.                 bvi++;
  2097.           }   }
  2098.           # Hinteres Teilstück:
  2099.           { until (eq(STACK_0,STACK_4)) # solange bis j = l (beides Fixnums)
  2100.               # Element übertragen:
  2101.               { # (setf (aref sequence i) (aref sequence j)) :
  2102.                 pushSTACK(STACK_2); pushSTACK(STACK_(0+1));
  2103.                 funcall(L(aref),2); # (AREF sequence j)
  2104.                 pushSTACK(STACK_2); pushSTACK(STACK_(1+1)); pushSTACK(value1);
  2105.                 funcall(L(store),3); # (SYS::STORE sequence i ...)
  2106.                 # i:=i+1 :
  2107.                 STACK_1 = fixnum_inc(STACK_1,1);
  2108.                 # j:=j+1 :
  2109.                 STACK_0 = fixnum_inc(STACK_0,1);
  2110.           }   }
  2111.           skipSTACK(1);
  2112.           # Stackaufbau: typdescr, l, bv, sequence, i.
  2113.           # (setf (fill-pointer sequence) i) :
  2114.           funcall(L(set_fill_pointer),2); # (SYS::SET-FILL-POINTER sequence i)
  2115.           # Stackaufbau: typdescr, l, bv.
  2116.           return *(stackptr STACKop 0); # sequence mit modifiziertem Fill-Pointer
  2117.         }
  2118.       other: # sonstige Sequences
  2119.         return remove_help(stackptr,bvl,dl); # DELETE wie REMOVE behandeln
  2120.     }}
  2121.  
  2122. LISPFUN(remove,2,0,norest,key,7,\
  2123.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not),kw(count)) )
  2124. # (REMOVE item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not] [:count]),
  2125. # CLTL S. 253
  2126.   { var reg1 object* stackptr = &STACK_7;
  2127.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  2128.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2129.     seq_filterop(stackptr,up_fun,&remove_help); # Filtern
  2130.     skipSTACK(2+7+1);
  2131.   }
  2132.  
  2133. LISPFUN(remove_if,2,0,norest,key,5,\
  2134.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2135. # (REMOVE-IF test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2136. # CLTL S. 253
  2137.   { var reg1 object* stackptr = &STACK_5;
  2138.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2139.     seq_filterop(stackptr,&up_if,&remove_help); # Filtern
  2140.     skipSTACK(2+5+1);
  2141.   }
  2142.  
  2143. LISPFUN(remove_if_not,2,0,norest,key,5,\
  2144.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2145. # (REMOVE-IF-NOT test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2146. # CLTL S. 253
  2147.   { var reg1 object* stackptr = &STACK_5;
  2148.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2149.     seq_filterop(stackptr,&up_if_not,&remove_help); # Filtern
  2150.     skipSTACK(2+5+1);
  2151.   }
  2152.  
  2153. LISPFUN(delete,2,0,norest,key,7,\
  2154.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not),kw(count)) )
  2155. # (DELETE item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not] [:count]),
  2156. # CLTL S. 254
  2157.   { var reg1 object* stackptr = &STACK_7;
  2158.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  2159.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2160.     seq_filterop(stackptr,up_fun,&delete_help); # Filtern
  2161.     skipSTACK(2+7+1);
  2162.   }
  2163.  
  2164. LISPFUN(delete_if,2,0,norest,key,5,\
  2165.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2166. # (DELETE-IF test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2167. # CLTL S. 254
  2168.   { var reg1 object* stackptr = &STACK_5;
  2169.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2170.     seq_filterop(stackptr,&up_if,&delete_help); # Filtern
  2171.     skipSTACK(2+5+1);
  2172.   }
  2173.  
  2174. LISPFUN(delete_if_not,2,0,norest,key,5,\
  2175.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2176. # (DELETE-IF-NOT test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2177. # CLTL S. 254
  2178.   { var reg1 object* stackptr = &STACK_5;
  2179.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2180.     seq_filterop(stackptr,&up_if_not,&delete_help); # Filtern
  2181.     skipSTACK(2+5+1);
  2182.   }
  2183.  
  2184. # Unterprogramm zum Ausführen des Tests :TEST
  2185. # up2_test(stackptr,x,y)
  2186. # > *(stackptr-5): die Testfunktion
  2187. # > x,y: Argumente
  2188. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  2189. # kann GC auslösen
  2190.   local boolean up2_test (object* stackptr, object x, object y);
  2191.   local boolean up2_test(stackptr,x,y)
  2192.     var object* stackptr;
  2193.     var object x;
  2194.     var object y;
  2195.     { # ein (funcall testfun x y) ausführen:
  2196.       pushSTACK(x); # x
  2197.       pushSTACK(y); # y
  2198.       funcall(*(stackptr STACKop -5),2);
  2199.       if (nullp(value1)) return FALSE; else return TRUE;
  2200.     }
  2201.  
  2202. # Unterprogramm zum Ausführen des Tests :TEST-NOT
  2203. # up2_test_not(stackptr,x,y)
  2204. # > *(stackptr-6): die Testfunktion
  2205. # > x,y: Argumente
  2206. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  2207. # kann GC auslösen
  2208.   local boolean up2_test_not (object* stackptr, object x, object y);
  2209.   local boolean up2_test_not(stackptr,x,y)
  2210.     var object* stackptr;
  2211.     var object x;
  2212.     var object y;
  2213.     { # ein (not (funcall testfun x y)) ausführen:
  2214.       pushSTACK(x); # x
  2215.       pushSTACK(y); # y
  2216.       funcall(*(stackptr STACKop -6),2);
  2217.       if (nullp(value1)) return TRUE; else return FALSE;
  2218.     }
  2219.  
  2220. # UP: Überprüft die :TEST, :TEST-NOT - Argumente
  2221. # test_test2_args(stackptr)
  2222. # > stackptr: Pointer in den STACK
  2223. # > *(stackptr-5): :TEST-Argument
  2224. # > *(stackptr-6): :TEST-NOT-Argument
  2225. # > subr_self: Aufrufer (ein SUBR)
  2226. # < *(stackptr-5): verarbeitetes :TEST-Argument
  2227. # < *(stackptr-6): verarbeitetes :TEST-NOT-Argument
  2228. # < up2_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  2229. #       > stackptr: derselbe Pointer in den Stack,
  2230. #         *(stackptr-5) = :test-Argument, *(stackptr-6) = :test-not-Argument,
  2231. #       > x,y: Argumente
  2232. #       < TRUE, falls der Test erfüllt ist, FALSE sonst.
  2233.   # up2_function sei der Typ der Adresse einer solchen Testfunktion:
  2234.   typedef boolean (*up2_function) (object* stackptr, object x, object y);
  2235.   local up2_function test_test2_args (object* stackptr);
  2236.   local up2_function test_test2_args(stackptr)
  2237.     var reg1 object* stackptr;
  2238.     { var reg3 object test_arg = *(stackptr STACKop -5);
  2239.       if (eq(test_arg,unbound)) { test_arg=NIL; }
  2240.       # test_arg ist das :TEST-Argument
  2241.      {var reg2 object test_not_arg = *(stackptr STACKop -6);
  2242.       if (eq(test_not_arg,unbound)) { test_not_arg=NIL; }
  2243.       # test_not_arg ist das :TEST-NOT-Argument
  2244.       if (nullp(test_not_arg))
  2245.         # :TEST-NOT wurde nicht angegeben
  2246.         { if (nullp(test_arg))
  2247.             *(stackptr STACKop -5) = L(eql); # #'EQL als Default für :TEST
  2248.           return(&up2_test);
  2249.         }
  2250.         # :TEST-NOT wurde angegeben
  2251.         { if (nullp(test_arg))
  2252.             return(&up2_test_not);
  2253.           else
  2254.             fehler_both_tests();
  2255.     }}  }
  2256.  
  2257. # UP: führt eine Sequence-Duplicates-Operation aus.
  2258. # seq_duplicates(help_fun)
  2259. # Eine Sequence wird durchlaufen und dabei in einem Bit-Vektor abgespeichert,
  2260. # welche Elemente doppelt vorkommen. Dann wird eine Routine aufgerufen, die
  2261. # den Rest erledigt.
  2262. # > Stackaufbau:
  2263. #     sequence from-end start end key test test-not [STACK]
  2264. # > help_fun: Adresse einer Hilfsroutine, die den Rest erledigt.
  2265. #     Spezifiziert durch:
  2266. #       > stackptr: Pointer in den Stack,
  2267. #         *(stackptr+0)=sequence, *(stackptr-2)=start, *(stackptr-3)=end,
  2268. #       > STACK_2: typdescr,
  2269. #       > STACK_1: Länge der Sequence,
  2270. #       > STACK_0: Bit-Vektor bv,
  2271. #       > bvl: Länge des Bit-Vektors (= end - start),
  2272. #       > dl: Anzahl der im Bit-Vektor gesetzten Bits,
  2273. #       < ergebnis: Ergebnis
  2274. #       kann GC auslösen
  2275. # > subr_self: Aufrufer (ein SUBR)
  2276. # < mv_space/mv_count: Werte
  2277. # kann GC auslösen
  2278.   local Values seq_duplicates (help_function help_fun);
  2279.   local Values seq_duplicates(help_fun)
  2280.     var reg8 help_function help_fun;
  2281.     { var reg2 object* stackptr = &STACK_6;
  2282.       # Stackaufbau:
  2283.       #   sequence [stackptr], from-end, start, end, key, test, test-not.
  2284.       # sequence überprüfen:
  2285.       { var reg1 object sequence = *(stackptr STACKop 0);
  2286.         pushSTACK(get_valid_seq_type(sequence)); # typdescr auf den Stack
  2287.       }
  2288.       # Stackaufbau:
  2289.       #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2290.       #   typdescr.
  2291.       # :test und :test-not überprüfen:
  2292.      {var reg3 up2_function up2_fun = test_test2_args(stackptr);
  2293.       # key überprüfen:
  2294.       test_key_arg(stackptr);
  2295.       # Defaultwert für from-end ist NIL:
  2296.       default_NIL(*(stackptr STACKop -1));
  2297.       # Defaultwert für start ist 0:
  2298.       start_default_0(*(stackptr STACKop -2));
  2299.       # Defaultwert für end ist nil:
  2300.       default_NIL(*(stackptr STACKop -3));
  2301.       # start und end überprüfen:
  2302.       test_start_end_1(&O(kwpair_start),&*(stackptr STACKop -3));
  2303.       # Länge der Sequence bestimmen:
  2304.       { var reg9 object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet!
  2305.         pushSTACK(STACK_(6+1)); # sequence
  2306.         funcall(seq_length(STACK_(0+1)),1); # (SEQ-LENGTH sequence)
  2307.         pushSTACK(value1); # l
  2308.         subr_self = old_subr_self;
  2309.       }
  2310.       # Stackaufbau:
  2311.       #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2312.       #   typdescr, l.
  2313.       # Defaultwert für end ist l = (length sequence):
  2314.       if (nullp(*(stackptr STACKop -3)))
  2315.         { *(stackptr STACKop -3) = STACK_0; # end := l
  2316.           # Dann nochmals start und end überprüfen:
  2317.           test_start_end(&O(kwpair_start),&*(stackptr STACKop -3));
  2318.         }
  2319.       # Nun sind alle Argumente überprüft.
  2320.       { var reg5 uintL bvl; # Bitvektor-Länge
  2321.         var reg6 uintL dl; # Anzahl der im Bitvektor gesetzten Bits
  2322.         # (- end start) bestimmen und neuen Bitvektor allozieren:
  2323.         { var reg1 object size = I_I_minus_I(STACK_(3+2),STACK_(4+2));
  2324.           # size = (- end start), ein Integer >=0
  2325.           if (!(posfixnump(size)))
  2326.             { pushSTACK(*(stackptr STACKop 0)); # sequence
  2327.               //: DEUTSCH "Zu lange Sequence: ~"
  2328.               //: ENGLISH "too long sequence ~"
  2329.               //: FRANCAIS "Séquence trop longue : ~"
  2330.               fehler(error, GETTEXT("too long sequence ~"));
  2331.             }
  2332.           bvl = posfixnum_to_L(size);
  2333.         }
  2334.         pushSTACK(allocate_bit_vector_0(bvl));
  2335.         # Stackaufbau:
  2336.         #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2337.         #   typdescr, l, bv.
  2338.         dl = 0; # dl := 0
  2339.         # Bei :test #'eq/eql/equal und großer Länge verwende Hashtabelle:
  2340.         if (bvl < 10) goto standard;
  2341.         if (!(up2_fun == &up2_test)) goto standard;
  2342.         { var reg7 object test = STACK_(1+3);
  2343.           if (!(eq(test,L(eq)) || eq(test,L(eql)) || eq(test,L(equal))
  2344.                 || eq(test,S(eq)) || eq(test,S(eql)) || eq(test,S(equal))
  2345.              ) )
  2346.             goto standard;
  2347.         }
  2348.         if (FALSE)
  2349.           standard: # Standardmethode
  2350.           { if (!(nullp(STACK_(5+3)))) # from-end abfragen
  2351.               # from-end ist angegeben
  2352.               {{pushSTACK(STACK_(6+3)); # sequence
  2353.                 pushSTACK(STACK_(4+3+1)); # start
  2354.                 funcall(seq_init_start(STACK_(2+2)),2); # (SEQ-INIT-START sequence start)
  2355.                 pushSTACK(value1); # =: pointer1
  2356.                }
  2357.                # Stackaufbau:
  2358.                #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2359.                #   typdescr, l, bv,
  2360.                #   pointer1.
  2361.                # pointer1 läuft von links nach rechts (von start bis end).
  2362.                {var reg4 uintL bvi1 = 0; # Schleife bvl mal durchlaufen
  2363.                 until (bvi1==bvl)
  2364.                   { if (!(sbvector_btst(STACK_(0+1),bvi1))) # (sbit bv bvi1) abfragen
  2365.                       # falls Bit=0: dieses Element ist noch nicht gestrichen ->
  2366.                       # teste, ob es weiter rechts vorkommt:
  2367.                       {{pushSTACK(STACK_(6+3+1)); # sequence
  2368.                         pushSTACK(STACK_(0+1)); # pointer1
  2369.                         funcall(seq_access(STACK_(2+1+2)),2); # (SEQ-ACCESS sequence pointer1)
  2370.                         funcall_key(STACK_(2+3+1)); # (FUNCALL key (SEQ-ACCESS sequence pointer1))
  2371.                         pushSTACK(value1); # =: item1
  2372.                        }
  2373.                         # Stackaufbau:
  2374.                         #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2375.                         #   typdescr, l, bv,
  2376.                         #   pointer1, item1.
  2377.                         # pointer1 := (SEQ-UPD sequence pointer1) :
  2378.                         pointer_update(STACK_1,STACK_(6+3+2),STACK_(2+2));
  2379.                         # pointer2 := (SEQ-COPY pointer1) :
  2380.                        {pushSTACK(STACK_1); funcall(seq_copy(STACK_(2+2+1)),1); # (SEQ-COPY pointer1)
  2381.                         pushSTACK(value1); # =: pointer2
  2382.                        }
  2383.                         # Stackaufbau:
  2384.                         #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2385.                         #   typdescr, l, bv,
  2386.                         #   pointer1, item1, pointer2.
  2387.                         # pointer2 läuft von pointer1 nach rechts.
  2388.                        {var reg1 uintL bvi2 = bvi1+1; # bvi2 := bvi1+1
  2389.                         until (bvi2==bvl)
  2390.                           { if (!(sbvector_btst(STACK_(0+3),bvi2))) # (sbit bv bvi2) abfragen
  2391.                               # falls Bit=0: dieses Element ist auch noch nicht gestrichen.
  2392.                               # vergleiche beide Elemente:
  2393.                               { pushSTACK(STACK_(6+3+3)); # sequence
  2394.                                 pushSTACK(STACK_(0+1)); # pointer2
  2395.                                 funcall(seq_access(STACK_(2+3+2)),2); # (SEQ-ACCESS sequence pointer2)
  2396.                                 funcall_key(STACK_(2+3+3)); # (FUNCALL key (SEQ-ACCESS sequence pointer2))
  2397.                                 # value1 =: item2
  2398.                                 # item1 und item2 vergleichen:
  2399.                                 if ((*up2_fun)(stackptr,STACK_1,value1)) # Testroutine aufrufen
  2400.                                   # Test erfüllt -> vermerke, daß item2 zu streichen ist:
  2401.                                   { sbvector_bset(STACK_(0+3),bvi2); # (setf (sbit bv bvi2) 1)
  2402.                                     dl = dl+1; # dl:=dl+1
  2403.                                   }
  2404.                               }
  2405.                             # pointer2 := (SEQ-UPD sequence pointer2) :
  2406.                             pointer_update(STACK_0,STACK_(6+3+3),STACK_(2+3));
  2407.                             bvi2++; # bvi2 := bvi2+1
  2408.                        }  }
  2409.                         skipSTACK(2); # item1 und pointer2 vergessen
  2410.                       }
  2411.                       else
  2412.                       # falls Bit=1: dieses Element einfach übergehen
  2413.                       { # pointer1 := (SEQ-UPD sequence pointer1) :
  2414.                         pointer_update(STACK_0,STACK_(6+3+1),STACK_(2+1));
  2415.                       }
  2416.                     bvi1++;
  2417.                }  }
  2418.                 skipSTACK(1); # pointer1 vergessen
  2419.               }
  2420.               else
  2421.               # from-end ist nicht angegeben
  2422.               {{pushSTACK(STACK_(6+3)); # sequence
  2423.                 pushSTACK(STACK_(4+3+1)); # start
  2424.                 funcall(seq_init_start(STACK_(2+2)),2); # (SEQ-INIT-START sequence start)
  2425.                 pushSTACK(value1); # =: pointer0
  2426.                }
  2427.                # Stackaufbau:
  2428.                #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2429.                #   typdescr, l, bv,
  2430.                #   pointer0.
  2431.                # pointer0 steht links.
  2432.                {pushSTACK(STACK_0); funcall(seq_copy(STACK_(2+1+1)),1); # (SEQ-COPY pointer0)
  2433.                 pushSTACK(value1); # =: pointer2
  2434.                }
  2435.                # Stackaufbau:
  2436.                #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2437.                #   typdescr, l, bv,
  2438.                #   pointer0, pointer2.
  2439.                # pointer2 läuft von links nach rechts (von start bis end).
  2440.                {var reg4 uintL bvi2 = 0; # Schleife bvl mal durchlaufen
  2441.                 until (bvi2==bvl)
  2442.                   { if (!(sbvector_btst(STACK_(0+2),bvi2))) # (sbit bv bvi2) abfragen
  2443.                       # falls Bit=0: dieses Element ist noch nicht gestrichen ->
  2444.                       # teste, ob es weiter links vorkommt:
  2445.                       {{pushSTACK(STACK_(6+3+2)); # sequence
  2446.                         pushSTACK(STACK_(0+1)); # pointer2
  2447.                         funcall(seq_access(STACK_(2+2+2)),2); # (SEQ-ACCESS sequence pointer2)
  2448.                         funcall_key(STACK_(2+3+2)); # (FUNCALL key (SEQ-ACCESS sequence pointer1))
  2449.                         pushSTACK(value1); # =: item2
  2450.                        }
  2451.                         # Stackaufbau:
  2452.                         #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2453.                         #   typdescr, l, bv,
  2454.                         #   pointer0, pointer2, item2.
  2455.                         # pointer1 := (SEQ-COPY pointer0) :
  2456.                        {pushSTACK(STACK_2); funcall(seq_copy(STACK_(2+3+1)),1); # (SEQ-COPY pointer0)
  2457.                         pushSTACK(value1); # =: pointer1
  2458.                        }
  2459.                         # Stackaufbau:
  2460.                         #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2461.                         #   typdescr, l, bv,
  2462.                         #   pointer0, pointer2, item2, pointer1.
  2463.                         # pointer1 läuft von links bis pointer2.
  2464.                        {var reg1 uintL bvi1 = 0; # bvi1 := 0
  2465.                         until (bvi1==bvi2)
  2466.                           { if (!(sbvector_btst(STACK_(0+4),bvi1))) # (sbit bv bvi1) abfragen
  2467.                               # falls Bit=0: dieses Element ist auch noch nicht gestrichen.
  2468.                               # vergleiche beide Elemente:
  2469.                               { pushSTACK(STACK_(6+3+4)); # sequence
  2470.                                 pushSTACK(STACK_(0+1)); # pointer1
  2471.                                 funcall(seq_access(STACK_(2+4+2)),2); # (SEQ-ACCESS sequence pointer1)
  2472.                                 funcall_key(STACK_(2+3+4)); # (FUNCALL key (SEQ-ACCESS sequence pointer1))
  2473.                                 # value1 =: item1
  2474.                                 # item1 und item2 vergleichen:
  2475.                                 if ((*up2_fun)(stackptr,value1,STACK_1)) # Testroutine aufrufen
  2476.                                   # Test erfüllt -> vermerke, daß item1 zu streichen ist:
  2477.                                   { sbvector_bset(STACK_(0+4),bvi1); # (setf (sbit bv bvi1) 1)
  2478.                                     dl = dl+1; # dl:=dl+1
  2479.                                   }
  2480.                               }
  2481.                             # pointer1 := (SEQ-UPD sequence pointer1) :
  2482.                             pointer_update(STACK_0,STACK_(6+3+4),STACK_(2+4));
  2483.                             bvi1++; # bvi1 := bvi1+1
  2484.                        }  }
  2485.                         skipSTACK(2); # item2 und pointer1 vergessen
  2486.                       }
  2487.                     # falls Bit=1: dieses Element einfach übergehen
  2488.                     # pointer2 := (SEQ-UPD sequence pointer2) :
  2489.                     pointer_update(STACK_0,STACK_(6+3+2),STACK_(2+2));
  2490.                     bvi2++; # bvi2 := bvi2+1
  2491.                }  }
  2492.                 skipSTACK(2); # pointer0 und pointer2 vergessen
  2493.               }
  2494.           }
  2495.           else
  2496.           # Methode mit Hash-Tabelle
  2497.           { # mit (MAKE-HASH-TABLE :test test) eine leere Hash-Tabelle bauen:
  2498.             pushSTACK(S(Ktest)); pushSTACK(STACK_(1+3+1)); funcall(L(make_hash_table),2);
  2499.             pushSTACK(value1); # ht retten
  2500.             {pushSTACK(STACK_(6+3+1)); # sequence
  2501.              pushSTACK(STACK_(4+3+2)); # start
  2502.              funcall(seq_init_start(STACK_(2+3)),2); # (SEQ-INIT-START sequence start)
  2503.              pushSTACK(value1); # =: pointer
  2504.             }
  2505.             # Stackaufbau:
  2506.             #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2507.             #   typdescr, l, bv,
  2508.             #   ht, pointer.
  2509.             if (!(nullp(STACK_(5+3+2)))) # from-end abfragen
  2510.               # from-end ist angegeben
  2511.               { # pointer läuft von links nach rechts (von start bis end).
  2512.                 var reg2 uintL bvi = 0; # Schleife bvl mal durchlaufen
  2513.                 until (bvi==bvl)
  2514.                   {{pushSTACK(STACK_(6+3+2)); # sequence
  2515.                     pushSTACK(STACK_(0+1)); # pointer
  2516.                     funcall(seq_access(STACK_(2+2+2)),2); # (SEQ-ACCESS sequence pointer)
  2517.                     funcall_key(STACK_(2+3+2)); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  2518.                    }# item wird in die Tabelle gesteckt; war es schon
  2519.                     # drin, wird bei pointer gestrichen.
  2520.                    {var reg1 object old_value = shifthash(STACK_1,value1,T);
  2521.                     if (!nullp(old_value))
  2522.                       # item war schon in ht -> wird jetzt gestrichen
  2523.                       { sbvector_bset(STACK_(0+2),bvi); # (setf (sbit bv bvi) 1)
  2524.                         dl = dl+1; # dl:=dl+1
  2525.                    }  }
  2526.                     # pointer := (SEQ-UPD sequence pointer) :
  2527.                     pointer_update(STACK_0,STACK_(6+3+2),STACK_(2+2));
  2528.                     bvi++; # bvi := bvi+1
  2529.                   }
  2530.               }
  2531.               else
  2532.               # from-end ist nicht angegeben
  2533.               { # pointer läuft von links nach rechts (von start bis end).
  2534.                 var reg2 uintL bvi = 0; # Schleife bvl mal durchlaufen
  2535.                 until (bvi==bvl)
  2536.                   {{pushSTACK(STACK_(6+3+2)); # sequence
  2537.                     pushSTACK(STACK_(0+1)); # pointer
  2538.                     funcall(seq_access(STACK_(2+2+2)),2); # (SEQ-ACCESS sequence pointer)
  2539.                     funcall_key(STACK_(2+3+2)); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  2540.                    }# item wird in die Tabelle gesteckt; war es schon
  2541.                     # drin, wird an der vorigen Position gestrichen.
  2542.                    {var reg1 object old_value =
  2543.                       shifthash(STACK_1,value1,fixnum(bvi));
  2544.                     if (!nullp(old_value))
  2545.                       # item war schon in ht -> wird an der vorigen Position gestrichen
  2546.                       { var reg1 uintL i = posfixnum_to_L(old_value);
  2547.                         sbvector_bset(STACK_(0+2),i); # (setf (sbit bv i) 1)
  2548.                         dl = dl+1; # dl:=dl+1
  2549.                    }  }
  2550.                     # pointer := (SEQ-UPD sequence pointer) :
  2551.                     pointer_update(STACK_0,STACK_(6+3+2),STACK_(2+2));
  2552.                     bvi++; # bvi := bvi+1
  2553.                   }
  2554.               }
  2555.             skipSTACK(2); # ht und pointer vergessen
  2556.           }
  2557.         # Stackaufbau:
  2558.         #   sequence [stackptr], from-end, start, end, key, test, test-not,
  2559.         #   typdescr, l, bv.
  2560.         value1 = (*help_fun)(stackptr,bvl,dl); # Rest durchführen
  2561.         mv_count=1; # Ergebnis als Wert
  2562.         skipSTACK(7+3); # STACK aufräumen
  2563.     }}}
  2564.  
  2565. LISPFUN(remove_duplicates,1,0,norest,key,6,\
  2566.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not)) )
  2567. # (REMOVE-DUPLICATES sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not]),
  2568. # CLTL S. 254
  2569.   { return_Values seq_duplicates(&remove_help); }
  2570.  
  2571. LISPFUN(delete_duplicates,1,0,norest,key,6,\
  2572.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not)) )
  2573. # (DELETE-DUPLICATES sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not]),
  2574. # CLTL S. 254
  2575.   { return_Values seq_duplicates(&delete_help); }
  2576.  
  2577. # UP: Hilfsroutine für SUBSTITUTE-Funktionen.
  2578. # Bildet zu einer Sequence eine neue Sequence, in der genau die Elemente
  2579. # ersetzt sind, die in einem Bitvektor markiert sind.
  2580. # > stackptr: Pointer in den Stack, *(stackptr+2)=newitem,
  2581. #   *(stackptr+0)=sequence, *(stackptr-2)=start, *(stackptr-3)=end,
  2582. # > STACK_2: typdescr,
  2583. # > STACK_1: Länge l der Sequence,
  2584. # > STACK_0: Bit-Vektor bv,
  2585. # > bvl: Länge des Bit-Vektors (= end - start),
  2586. # > dl: Anzahl der im Bit-Vektor gesetzten Bits,
  2587. # < ergebnis: Ergebnis
  2588. # kann GC auslösen
  2589.   local object substitute_help (object* stackptr, uintL bvl, uintL dl);
  2590.   local object substitute_help(stackptr,bvl,dl)
  2591.     var reg4 object* stackptr;
  2592.     var reg5 uintL bvl;
  2593.     var reg6 uintL dl;
  2594.     { # dl=0 -> sequence unverändert zurückgeben:
  2595.       if (dl==0) { return *(stackptr STACKop 0); }
  2596.       if (eq(seq_type(STACK_2),S(list))) # Typ LIST ?
  2597.         # Noch überprüfen, ob sequence wirklich eine Liste ist.
  2598.         # Wegen l >= dl > 0 ist zu testen, ob sequence ein Cons ist.
  2599.         if (mconsp(*(stackptr STACKop 0)))
  2600.           { # Listen speziell behandeln:
  2601.             pushSTACK(NIL); # L1 := nil
  2602.             pushSTACK(*(stackptr STACKop 0)); # L2 := sequence
  2603.             # Stackaufbau: ..., typdescr, l, bv,
  2604.             #              L1, L2.
  2605.             # Erste start Conses kopieren:
  2606.             { var reg3 uintL count = posfixnum_to_L(*(stackptr STACKop -2)); # 0 <= start <= l ==> start ist Fixnum
  2607.               dotimesL(count,count,
  2608.                 { # Hier gilt (revappend L1 L2) = sequence
  2609.                   var reg1 object new_cons = allocate_cons();
  2610.                   var reg2 object L2 = STACK_0;
  2611.                   Car(new_cons) = Car(L2);
  2612.                   STACK_0 = Cdr(L2); # L2 := (cdr L2)
  2613.                   Cdr(new_cons) = STACK_1; STACK_1 = new_cons; # L1 := (cons ... L1)
  2614.                 });
  2615.             }
  2616.             # bvl bis über die letzte Eins im Bit-Vector erniedrigen:
  2617.             # (Es gibt Einsen, da dl>0.)
  2618.             { var reg2 object bv = STACK_(0+2);
  2619.               loop { var reg1 uintL bvl_1 = bvl-1;
  2620.                      if (sbvector_btst(bv,bvl_1)) break; #  Bit bvl-1 abfragen
  2621.                      bvl = bvl_1; # Bit =0 -> bvl erniedrigen und weitersuchen
  2622.             }      }
  2623.             # Teilabschnitt kopieren bzw. mit newitem füllen:
  2624.             { var reg2 uintL bvi = 0; # bvi := 0
  2625.               until (bvi==bvl) # Schleife bvl mal durchlaufen
  2626.                 { if (sbvector_btst(STACK_(0+2),bvi)) # (sbit bv bvi) abfragen
  2627.                     { # Bit =1 -> newitem nehmen
  2628.                       pushSTACK(*(stackptr STACKop 2)); # newitem
  2629.                     }
  2630.                     else
  2631.                     { # Bit =0 -> (car L2) nehmen
  2632.                       pushSTACK(Car(STACK_0));
  2633.                     }
  2634.                   {var reg1 object new_cons = allocate_cons();
  2635.                    Car(new_cons) = popSTACK(); # mit Obigem als CAR
  2636.                    Cdr(new_cons) = STACK_1; STACK_1 = new_cons; # L1 := (cons ... L1)
  2637.                   }
  2638.                   STACK_0 = Cdr(STACK_0); # L2 := (cdr L2)
  2639.                   bvi++; # bvi:=bvi+1
  2640.             }   }
  2641.             # letzten Teilabschnitt unverändert dazunehmen:
  2642.             { var reg1 object L2 = popSTACK();
  2643.               var reg2 object L1 = popSTACK();
  2644.               return nreconc(L1,L2); # (nreconc L1 L2) als Ergebnis
  2645.           } }
  2646.       # neue Sequence allozieren:
  2647.       pushSTACK(STACK_1); # l
  2648.       funcall(seq_make(STACK_(2+1)),1); # (SEQ-MAKE l)
  2649.       pushSTACK(value1); # =: sequence2
  2650.       # Stackaufbau: ..., typdescr, l, bv, sequence2.
  2651.       pushSTACK(*(stackptr STACKop 0)); # sequence
  2652.       pushSTACK(STACK_(3+1)); # typdescr
  2653.       pushSTACK(STACK_(0+2)); # sequence2
  2654.       pushSTACK(STACK_(3+3)); # typdescr
  2655.       pushSTACK(*(stackptr STACKop -2)); # start
  2656.       # Stackaufbau: ..., typdescr, l, bv, sequence2,
  2657.       #              seq1, typdescr1, seq2, typdescr2, start.
  2658.       pushSTACK(STACK_4); funcall(seq_init(STACK_(3+1)),1); # (SEQ-INIT sequence)
  2659.       pushSTACK(value1); # =: pointer1
  2660.       pushSTACK(STACK_(2+1)); funcall(seq_init(STACK_(1+1+1)),1); # (SEQ-INIT sequence2)
  2661.       pushSTACK(value1); # =: pointer2
  2662.       # Stackaufbau: ..., typdescr, l, bv, sequence2,
  2663.       #              seq1, typdescr1, seq2, typdescr2, start,
  2664.       #              pointer1, pointer2.
  2665.       { # Vorderes Teilstück:
  2666.         # Elemente mit Index <start von sequence1 nach sequence2
  2667.         # unverändert übertragen:
  2668.         copy_seqpart_into();
  2669.       }
  2670.       { # Mittleres Teilstück:
  2671.         var reg2 uintL bvi = 0;
  2672.         until (bvi==bvl)
  2673.           { var reg1 object item; # zu übernehmendes Element
  2674.             if (sbvector_btst(STACK_(1+5+2),bvi)) # (sbit bv bvi) abfragen
  2675.               # Bit =1 -> newitem nehmen:
  2676.               { item = *(stackptr STACKop 2); }
  2677.               else
  2678.               # Bit =0 -> Element aus sequence übernehmen:
  2679.               { pushSTACK(STACK_(4+2)); pushSTACK(STACK_(1+1));
  2680.                 funcall(seq_access(STACK_(3+2+2)),2); # (SEQ-ACCESS seq1 pointer1)
  2681.                 item = value1;
  2682.               }
  2683.             pushSTACK(STACK_(2+2)); pushSTACK(STACK_(0+1)); pushSTACK(item);
  2684.             funcall(seq_access_set(STACK_(1+2+3)),3); # (SEQ-ACCESS-SET seq2 pointer2 ...)
  2685.             # pointer1, pointer2, bvi weiterrücken:
  2686.             # pointer1 := (SEQ-UPD seq1 pointer1) :
  2687.             pointer_update(STACK_1,STACK_(4+2),STACK_(3+2));
  2688.             # pointer2 := (SEQ-UPD seq2 pointer2) :
  2689.             pointer_update(STACK_0,STACK_(2+2),STACK_(1+2));
  2690.             bvi++;
  2691.       }   }
  2692.       { # Hinteres Teilstück:
  2693.         # Elemente mit Index >=end von sequence1 nach sequence2
  2694.         # unverändert übertragen:
  2695.         STACK_(0+2) = I_I_minus_I(STACK_(2+5+2),*(stackptr STACKop -3)); # (- l end)
  2696.         copy_seqpart_into();
  2697.       }
  2698.       skipSTACK(5+2);
  2699.       return popSTACK(); # sequence2 als Ergebnis
  2700.     }
  2701.  
  2702. LISPFUN(substitute,3,0,norest,key,7,\
  2703.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not),kw(count)) )
  2704. # (SUBSTITUTE newitem item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not] [:count]),
  2705. # CLTL S. 255
  2706.   { var reg1 object* stackptr = &STACK_7;
  2707.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  2708.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2709.     seq_filterop(stackptr,up_fun,&substitute_help); # Filtern
  2710.     skipSTACK(3+7+1);
  2711.   }
  2712.  
  2713. LISPFUN(substitute_if,3,0,norest,key,5,\
  2714.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2715. # (SUBSTITUTE-IF newitem test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2716. # CLTL S. 255
  2717.   { var reg1 object* stackptr = &STACK_5;
  2718.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2719.     seq_filterop(stackptr,&up_if,&substitute_help); # Filtern
  2720.     skipSTACK(3+5+1);
  2721.   }
  2722.  
  2723. LISPFUN(substitute_if_not,3,0,norest,key,5,\
  2724.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2725. # (SUBSTITUTE-IF-NOT newitem test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2726. # CLTL S. 255
  2727.   { var reg1 object* stackptr = &STACK_5;
  2728.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2729.     seq_filterop(stackptr,&up_if_not,&substitute_help); # Filtern
  2730.     skipSTACK(3+5+1);
  2731.   }
  2732.  
  2733. # UP: Hilfsroutine für NSUBSTITUTE-Funktionen im Fall FROM-END.
  2734. # Ersetzt in einer Sequence genau die Elemente, die in einem Bitvektor
  2735. # markiert sind.
  2736. # > stackptr: Pointer in den Stack, *(stackptr+2)=newitem,
  2737. #   *(stackptr+0)=sequence, *(stackptr-2)=start, *(stackptr-3)=end,
  2738. # > STACK_2: typdescr,
  2739. # > STACK_1: Länge l der Sequence,
  2740. # > STACK_0: Bit-Vektor bv,
  2741. # > bvl: Länge des Bit-Vektors (= end - start),
  2742. # > dl: Anzahl der im Bit-Vektor gesetzten Bits,
  2743. # < ergebnis: Ergebnis
  2744. # kann GC auslösen
  2745.   local object nsubstitute_fe_help (object* stackptr, uintL bvl, uintL dl);
  2746.   local object nsubstitute_fe_help(stackptr,bvl,dl)
  2747.     var reg1 object* stackptr;
  2748.     var reg3 uintL bvl;
  2749.     var uintL dl;
  2750.     { {pushSTACK(*(stackptr STACKop 0)); # sequence
  2751.        pushSTACK(*(stackptr STACKop -2)); # start
  2752.        funcall(seq_init_start(STACK_(2+2)),2); # (SEQ-INIT-START sequence start)
  2753.        pushSTACK(value1); # =: pointer
  2754.       }
  2755.       # Stackaufbau: ..., typdescr, l, bv,
  2756.       #                   pointer.
  2757.       {var reg2 uintL bvi = 0; # bvi := 0
  2758.        until (bvi==bvl) # Schleife bvl mal durchlaufen
  2759.          { if (sbvector_btst(STACK_(0+1),bvi)) # (sbit bv bvi) abfragen
  2760.              # Bit =1 -> ersetze Element durch newitem:
  2761.              { pushSTACK(*(stackptr STACKop 0)); # sequence
  2762.                pushSTACK(STACK_(0+1)); # pointer
  2763.                pushSTACK(*(stackptr STACKop 2)); # newitem
  2764.                funcall(seq_access_set(STACK_(2+1+3)),3); # (SEQ-ACCESS-SET sequence pointer newitem)
  2765.              }
  2766.            # pointer := (SEQ-UPD sequence pointer) :
  2767.            pointer_update(STACK_0,*(stackptr STACKop 0),STACK_(2+1));
  2768.            bvi++; # bvi:=bvi+1
  2769.       }  }
  2770.       skipSTACK(1); # pointer vergessen
  2771.       return *(stackptr STACKop 0); # sequence als Ergebnis
  2772.     }
  2773.  
  2774. # Macro: endvar := (and end (- end start)) auf den STACK legen
  2775. # init_endvar(stackptr);
  2776. # > stackptr: Pointer in den Stack, *(stackptr+1)=start, *(stackptr+0)=end
  2777.   #define init_endvar(stackptr)  \
  2778.     {var reg1 object end = *(stackptr STACKop 0); # end                                   \
  2779.      if (!(nullp(end)))                                                                   \
  2780.        { end = I_I_minus_I(end,*(stackptr STACKop 1)); } # (- end start), ein Integer >=0 \
  2781.      pushSTACK(end);                                                                      \
  2782.     }
  2783.  
  2784. # Macro: endvar decrementieren falls endvar/=NIL
  2785. # decrement_endvar(endvar);
  2786. # > object endvar: entweder NIL oder ein Fixnum >0
  2787. # < object endvar: entweder immer noch NIL oder (decrementiert) ein Fixnum >=0
  2788.   #define decrement_endvar(endvar)  \
  2789.     { if (!(nullp(endvar))) # end angegeben ?                \
  2790.         { decrement(endvar); } # ja -> endvar := (1- endvar) \
  2791.     }
  2792.  
  2793. # UP: Führt eine NSUBSTITUTE-Operation durch.
  2794. # > Stackaufbau:
  2795. #     ... sequence [stackptr] from-end start end key ... count typdescr [STACK]
  2796. # > stackptr: Pointer in den Stack, *(stackptr+2)=newitem
  2797. # > up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  2798. #           > stackptr: derselbe Pointer in den Stack,
  2799. #           > x: Argument
  2800. #           < TRUE, falls der Test erfüllt ist, FALSE sonst.
  2801. # > subr_self: Aufrufer (ein SUBR)
  2802. # < mv_space/mv_count: Werte
  2803. # kann GC auslösen
  2804.   local Values nsubstitute_op (object* stackptr, up_function up_fun);
  2805.   local Values nsubstitute_op(stackptr,up_fun)
  2806.     var reg1 object* stackptr;
  2807.     var reg2 up_function up_fun;
  2808.     { if (!(nullp(*(stackptr STACKop -1)))) # from-end abfragen
  2809.         # from-end ist angegeben -> Bit-Vector erzeugen und dann ersetzen:
  2810.         { return_Values seq_filterop(stackptr,up_fun,&nsubstitute_fe_help); }
  2811.         else
  2812.         # from-end ist nicht angegeben
  2813.         { # COUNT-Argument muß NIL oder ein Integer >= 0 sein:
  2814.           test_count_arg();
  2815.           # Nun sind alle Argumente überprüft.
  2816.           pushSTACK(*(stackptr STACKop 0)); # sequence
  2817.           pushSTACK(*(stackptr STACKop -4)); # key
  2818.           init_endvar(&*(stackptr STACKop -3)); # endvar := (and end (- end start)) auf den Stack
  2819.           pushSTACK(STACK_(1+3)); # countdown := count
  2820.           # Stackaufbau: ..., count, typdescr,
  2821.           #              sequence, key, endvar, countdown.
  2822.           {pushSTACK(STACK_3); # sequence
  2823.            pushSTACK(*(stackptr STACKop -2)); # start
  2824.            funcall(seq_init_start(STACK_(0+4+2)),2); # (SEQ-INIT-START sequence start)
  2825.            pushSTACK(value1); # =: pointer
  2826.           }
  2827.           # Stackaufbau: ..., count, typdescr,
  2828.           #              sequence, key, endvar, countdown, pointer.
  2829.           # endvar und countdown sind jeweils entweder =NIL oder ein Integer >=0.
  2830.           { until (eq(STACK_2,Fixnum_0)) # endvar = 0 ?
  2831.                 # (also end angegeben und (- end start) Elemente durchlaufen ?)
  2832.                 # ja -> fertig
  2833.               { pushSTACK(STACK_4); pushSTACK(STACK_(0+1));
  2834.                 funcall(seq_endtest(STACK_(0+5+2)),2); # (SEQ-ENDTEST sequence pointer)
  2835.                 if (!(nullp(value1))) break; # Pointer am Ende -> fertig
  2836.                 if (eq(STACK_1,Fixnum_0)) # countdown=0 ?
  2837.                   # (also count angegeben und erschöpft?)
  2838.                   break; # ja -> Schleife kann abgebrochen werden
  2839.                 # item herausgreifen:
  2840.                 pushSTACK(STACK_4); pushSTACK(STACK_(0+1));
  2841.                 funcall(seq_access(STACK_(0+5+2)),2); # (SEQ-ACCESS sequence pointer)
  2842.                 funcall_key(STACK_3); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  2843.                 # value1 =: item
  2844.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  2845.                   # Test ist erfüllt
  2846.                   { pushSTACK(STACK_4); pushSTACK(STACK_(0+1));
  2847.                     pushSTACK(*(stackptr STACKop 2)); # newitem
  2848.                     funcall(seq_access_set(STACK_(0+5+3)),3); # (SEQ-ACCESS-SET sequence pointer newitem)
  2849.                     if (!(nullp(STACK_(1+5)))) # falls count/=NIL:
  2850.                       { decrement(STACK_1); } # (decf countdown)
  2851.                   }
  2852.                 # pointer := (SEQ-UPD sequence pointer) :
  2853.                 pointer_update(STACK_0,STACK_4,STACK_(0+5));
  2854.                 # endvar eventuell decrementieren:
  2855.                 decrement_endvar(STACK_2);
  2856.           }   }
  2857.           skipSTACK(4);
  2858.           value1 = popSTACK(); mv_count=1; # modifizierte Sequence als Wert
  2859.         }
  2860.     }
  2861.  
  2862. LISPFUN(nsubstitute,3,0,norest,key,7,\
  2863.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not),kw(count)) )
  2864. # (NSUBSTITUTE newitem item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not] [:count]),
  2865. # CLTL S. 256
  2866.   { var reg1 object* stackptr = &STACK_7;
  2867.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  2868.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2869.     nsubstitute_op(stackptr,up_fun); # gefiltert ersetzen
  2870.     skipSTACK(3+7+1);
  2871.   }
  2872.  
  2873. LISPFUN(nsubstitute_if,3,0,norest,key,5,\
  2874.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2875. # (NSUBSTITUTE-IF newitem test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2876. # CLTL S. 256
  2877.   { var reg1 object* stackptr = &STACK_5;
  2878.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2879.     nsubstitute_op(stackptr,&up_if); # gefiltert ersetzen
  2880.     skipSTACK(3+5+1);
  2881.   }
  2882.  
  2883. LISPFUN(nsubstitute_if_not,3,0,norest,key,5,\
  2884.         (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  2885. # (NSUBSTITUTE-IF-NOT newitem test sequence [:from-end] [:start] [:end] [:key] [:count]),
  2886. # CLTL S. 256
  2887.   { var reg1 object* stackptr = &STACK_5;
  2888.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2889.     nsubstitute_op(stackptr,&up_if_not); # gefiltert ersetzen
  2890.     skipSTACK(3+5+1);
  2891.   }
  2892.  
  2893. # UP: Führt eine FIND-Operation durch.
  2894. # > Stackaufbau:
  2895. #     ... sequence [stackptr] from-end start end key ... typdescr [STACK]
  2896. # > stackptr: Pointer in den Stack
  2897. # > up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  2898. #           > stackptr: derselbe Pointer in den Stack,
  2899. #           > x: Argument
  2900. #           < TRUE, falls der Test erfüllt ist, FALSE sonst.
  2901. # > subr_self: Aufrufer (ein SUBR)
  2902. # < mv_space/mv_count: Werte
  2903. # kann GC auslösen
  2904.   local Values find_op (object* stackptr, up_function up_fun);
  2905.   local Values find_op(stackptr,up_fun)
  2906.     var reg1 object* stackptr;
  2907.     var reg2 up_function up_fun;
  2908.     { pushSTACK(*(stackptr STACKop 0)); # sequence
  2909.       # Stackaufbau: ..., typdescr, sequence.
  2910.       if (!(nullp(*(stackptr STACKop -1)))) # from-end abfragen
  2911.         # from-end ist angegeben
  2912.         { # Defaultwert für end ist die Länge der Sequence:
  2913.           if (nullp(*(stackptr STACKop -3)))
  2914.             { { var reg4 object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet!
  2915.                 pushSTACK(STACK_0); funcall(seq_length(STACK_(1+1)),1); # (SEQ-LENGTH sequence)
  2916.                 *(stackptr STACKop -3) = value1; # =: end
  2917.                 subr_self = old_subr_self;
  2918.               }
  2919.               # Dann nochmals start und end überprüfen:
  2920.               test_start_end(&O(kwpair_start),&*(stackptr STACKop -3));
  2921.             }
  2922.           {pushSTACK(STACK_0); pushSTACK(*(stackptr STACKop -3));
  2923.            funcall(seq_fe_init_end(STACK_(1+2)),2); # (SEQ-FE-INIT-END sequence end)
  2924.            pushSTACK(value1); # =: pointer
  2925.           }
  2926.           { # count := (- end start), ein Integer >=0 :
  2927.             pushSTACK(I_I_minus_I(*(stackptr STACKop -3),*(stackptr STACKop -2)));
  2928.           }
  2929.           # Stackaufbau: ..., typdescr, sequence, pointer, count.
  2930.           { until (eq(STACK_0,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  2931.               { # item herausgreifen:
  2932.                 pushSTACK(STACK_2); pushSTACK(STACK_(1+1));
  2933.                 funcall(seq_access(STACK_(3+2)),2); # (SEQ-ACCESS sequence pointer)
  2934.                 pushSTACK(value1); # =: item
  2935.                 funcall_key(*(stackptr STACKop -4)); # (FUNCALL key item)
  2936.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  2937.                   goto found; # Test erfüllt -> gefunden
  2938.                 # Test ist nicht erfüllt
  2939.                 skipSTACK(1); # item vergessen
  2940.                 # pointer weiterrücken und count decrementieren:
  2941.                 # pointer := (SEQ-FE-UPD sequence pointer) :
  2942.                 pointer_fe_update(STACK_1,STACK_2,STACK_3);
  2943.                 decrement(STACK_0); # count := (1- count)
  2944.         } }   }
  2945.         else
  2946.         # from-end ist nicht angegeben
  2947.         { init_endvar(&*(stackptr STACKop -3)); # endvar := (and end (- end start)) auf den Stack
  2948.           # Stackaufbau: ..., typdescr, sequence, endvar.
  2949.           {pushSTACK(STACK_1); pushSTACK(*(stackptr STACKop -2));
  2950.            funcall(seq_init_start(STACK_(2+2)),2); # (SEQ-INIT-START sequence start)
  2951.            pushSTACK(value1); # =: pointer
  2952.           }
  2953.           # Stackaufbau: ... typdescr, sequence, endvar, pointer
  2954.           { until (eq(STACK_1,Fixnum_0)) # endvar = 0 ?
  2955.                 # (also end angegeben und (- end start) Elemente durchlaufen ?)
  2956.                 # ja -> fertig
  2957.               { pushSTACK(STACK_2); pushSTACK(STACK_(0+1));
  2958.                 funcall(seq_endtest(STACK_(3+2)),2); # (SEQ-ENDTEST sequence pointer)
  2959.                 if (!(nullp(value1))) break; # Pointer am Ende -> fertig
  2960.                 # item herausgreifen:
  2961.                 pushSTACK(STACK_2); pushSTACK(STACK_(0+1));
  2962.                 funcall(seq_access(STACK_(3+2)),2); # (SEQ-ACCESS sequence pointer)
  2963.                 pushSTACK(value1); # =: item
  2964.                 funcall_key(*(stackptr STACKop -4)); # (FUNCALL key item)
  2965.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  2966.                   goto found; # Test erfüllt -> gefunden
  2967.                 # Test ist nicht erfüllt
  2968.                 skipSTACK(1); # item vergessen
  2969.                 # pointer := (SEQ-UPD sequence pointer) :
  2970.                 pointer_update(STACK_0,STACK_2,STACK_3);
  2971.                 # endvar eventuell decrementieren:
  2972.                 decrement_endvar(STACK_1);
  2973.         } }   }
  2974.       skipSTACK(3); # STACK aufräumen
  2975.       value1 = NIL; mv_count=1; return; # NIL als Wert
  2976.       found: # item gefunden, das den Test erfüllt. STACK_0 = item.
  2977.       value1 = popSTACK(); mv_count=1; # item als Wert
  2978.       skipSTACK(3); # STACK aufräumen
  2979.     }
  2980.  
  2981. LISPFUN(find,2,0,norest,key,6,\
  2982.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not)) )
  2983. # (FIND item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not]),
  2984. # CLTL S. 257
  2985.   { var reg1 object* stackptr = &STACK_6;
  2986.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  2987.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2988.     find_op(stackptr,up_fun); # suchen
  2989.     skipSTACK(2+6+1);
  2990.   }
  2991.  
  2992. LISPFUN(find_if,2,0,norest,key,4,\
  2993.         (kw(from_end),kw(start),kw(end),kw(key)) )
  2994. # (FIND-IF test sequence [:from-end] [:start] [:end] [:key]),
  2995. # CLTL S. 257
  2996.   { var reg1 object* stackptr = &STACK_4;
  2997.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  2998.     find_op(stackptr,&up_if); # suchen
  2999.     skipSTACK(2+4+1);
  3000.   }
  3001.  
  3002. LISPFUN(find_if_not,2,0,norest,key,4,\
  3003.         (kw(from_end),kw(start),kw(end),kw(key)) )
  3004. # (FIND-IF-NOT test sequence [:from-end] [:start] [:end] [:key]),
  3005. # CLTL S. 257
  3006.   { var reg1 object* stackptr = &STACK_4;
  3007.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3008.     find_op(stackptr,&up_if_not); # suchen
  3009.     skipSTACK(2+4+1);
  3010.   }
  3011.  
  3012. # UP: Führt eine POSITION-Operation durch.
  3013. # > Stackaufbau:
  3014. #     ... sequence [stackptr] from-end start end key ... typdescr [STACK]
  3015. # > stackptr: Pointer in den Stack
  3016. # > up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  3017. #           > stackptr: derselbe Pointer in den Stack,
  3018. #           > x: Argument
  3019. #           < TRUE, falls der Test erfüllt ist, FALSE sonst.
  3020. # > subr_self: Aufrufer (ein SUBR)
  3021. # < mv_space/mv_count: Werte
  3022. # kann GC auslösen
  3023.   local Values position_op (object* stackptr, up_function up_fun);
  3024.   local Values position_op(stackptr,up_fun)
  3025.     var reg1 object* stackptr;
  3026.     var reg2 up_function up_fun;
  3027.     { pushSTACK(*(stackptr STACKop 0)); # sequence
  3028.       # Stackaufbau: ..., typdescr, sequence.
  3029.       if (!(nullp(*(stackptr STACKop -1)))) # from-end abfragen
  3030.         # from-end ist angegeben
  3031.         { # Defaultwert für end ist die Länge der Sequence:
  3032.           if (nullp(*(stackptr STACKop -3)))
  3033.             { { var reg4 object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet!
  3034.                 pushSTACK(STACK_0); funcall(seq_length(STACK_(1+1)),1); # (SEQ-LENGTH sequence)
  3035.                 *(stackptr STACKop -3) = value1; # =: end
  3036.                 subr_self = old_subr_self;
  3037.               }
  3038.               # Dann nochmals start und end überprüfen:
  3039.               test_start_end(&O(kwpair_start),&*(stackptr STACKop -3));
  3040.             }
  3041.           pushSTACK(*(stackptr STACKop -3)); # index := end
  3042.           {pushSTACK(STACK_(0+1)); pushSTACK(*(stackptr STACKop -3));
  3043.            funcall(seq_fe_init_end(STACK_(1+1+2)),2); # (SEQ-FE-INIT-END sequence end)
  3044.            pushSTACK(value1); # =: pointer
  3045.           }
  3046.           { # count := (- end start), ein Integer >=0 :
  3047.             pushSTACK(I_I_minus_I(*(stackptr STACKop -3),*(stackptr STACKop -2)));
  3048.           }
  3049.           # Stackaufbau: ..., typdescr, sequence, index, pointer, count.
  3050.           { until (eq(STACK_0,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  3051.               { # index decrementieren:
  3052.                 decrement(STACK_2);
  3053.                 # item herausgreifen:
  3054.                 pushSTACK(STACK_3); pushSTACK(STACK_(1+1));
  3055.                 funcall(seq_access(STACK_(4+2)),2); # (SEQ-ACCESS sequence pointer)
  3056.                 funcall_key(*(stackptr STACKop -4)); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  3057.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  3058.                   goto found; # Test erfüllt -> gefunden
  3059.                 # Test ist nicht erfüllt
  3060.                 # pointer weiterrücken und count decrementieren:
  3061.                 # pointer := (SEQ-FE-UPD sequence pointer) :
  3062.                 pointer_fe_update(STACK_1,STACK_3,STACK_4);
  3063.                 decrement(STACK_0); # count := (1- count)
  3064.         } }   }
  3065.         else
  3066.         # from-end ist nicht angegeben
  3067.         { pushSTACK(*(stackptr STACKop -2)); # index := start
  3068.           init_endvar(&*(stackptr STACKop -3)); # endvar := (and end (- end start)) auf den Stack
  3069.           # Stackaufbau: ..., typdescr, sequence, index, endvar.
  3070.           {pushSTACK(STACK_2); pushSTACK(*(stackptr STACKop -2));
  3071.            funcall(seq_init_start(STACK_(3+2)),2); # (SEQ-INIT-START sequence start)
  3072.            pushSTACK(value1); # =: pointer
  3073.           }
  3074.           # Stackaufbau: ... typdescr, sequence, index, endvar, pointer
  3075.           { until (eq(STACK_1,Fixnum_0)) # endvar = 0 ?
  3076.                 # (also end angegeben und (- end start) Elemente durchlaufen ?)
  3077.                 # ja -> fertig
  3078.               { pushSTACK(STACK_3); pushSTACK(STACK_(0+1));
  3079.                 funcall(seq_endtest(STACK_(4+2)),2); # (SEQ-ENDTEST sequence pointer)
  3080.                 if (!(nullp(value1))) break; # Pointer am Ende -> fertig
  3081.                 # item herausgreifen:
  3082.                 pushSTACK(STACK_3); pushSTACK(STACK_(0+1));
  3083.                 funcall(seq_access(STACK_(4+2)),2); # (SEQ-ACCESS sequence pointer)
  3084.                 funcall_key(*(stackptr STACKop -4)); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  3085.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  3086.                   goto found; # Test erfüllt -> gefunden
  3087.                 # Test ist nicht erfüllt
  3088.                 # pointer := (SEQ-UPD sequence pointer) :
  3089.                 pointer_update(STACK_0,STACK_3,STACK_4);
  3090.                 # endvar eventuell decrementieren:
  3091.                 decrement_endvar(STACK_1);
  3092.                 # index incrementieren:
  3093.                 increment(STACK_2);
  3094.         } }   }
  3095.       skipSTACK(4); # STACK aufräumen
  3096.       value1 = NIL; mv_count=1; return; # NIL als Wert
  3097.       found: # item gefunden, das den Test erfüllt. STACK_2 = index.
  3098.       value1 = STACK_2; mv_count=1; # index als Wert
  3099.       skipSTACK(4); # STACK aufräumen
  3100.     }
  3101.  
  3102. LISPFUN(position,2,0,norest,key,6,\
  3103.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not)) )
  3104. # (POSITION item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not]),
  3105. # CLTL S. 257
  3106.   { var reg1 object* stackptr = &STACK_6;
  3107.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  3108.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3109.     position_op(stackptr,up_fun); # suchen
  3110.     skipSTACK(2+6+1);
  3111.   }
  3112.  
  3113. LISPFUN(position_if,2,0,norest,key,4,\
  3114.         (kw(from_end),kw(start),kw(end),kw(key)) )
  3115. # (POSITION-IF test sequence [:from-end] [:start] [:end] [:key]),
  3116. # CLTL S. 257
  3117.   { var reg1 object* stackptr = &STACK_4;
  3118.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3119.     position_op(stackptr,&up_if); # suchen
  3120.     skipSTACK(2+4+1);
  3121.   }
  3122.  
  3123. LISPFUN(position_if_not,2,0,norest,key,4,\
  3124.         (kw(from_end),kw(start),kw(end),kw(key)) )
  3125. # (POSITION-IF-NOT test sequence [:from-end] [:start] [:end] [:key]),
  3126. # CLTL S. 257
  3127.   { var reg1 object* stackptr = &STACK_4;
  3128.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3129.     position_op(stackptr,&up_if_not); # suchen
  3130.     skipSTACK(2+4+1);
  3131.   }
  3132.  
  3133. # UP: Führt eine COUNT-Operation durch.
  3134. # > Stackaufbau:
  3135. #     ... sequence [stackptr] from-end start end key ... typdescr [STACK]
  3136. # > stackptr: Pointer in den Stack
  3137. # > up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  3138. #           > stackptr: derselbe Pointer in den Stack,
  3139. #           > x: Argument
  3140. #           < TRUE, falls der Test erfüllt ist, FALSE sonst.
  3141. # > subr_self: Aufrufer (ein SUBR)
  3142. # < mv_space/mv_count: Werte
  3143. # kann GC auslösen
  3144.   local Values count_op (object* stackptr, up_function up_fun);
  3145.   local Values count_op(stackptr,up_fun)
  3146.     var reg1 object* stackptr;
  3147.     var reg2 up_function up_fun;
  3148.     { pushSTACK(*(stackptr STACKop 0)); # sequence
  3149.       pushSTACK(Fixnum_0); # total := 0
  3150.       # Stackaufbau: ..., typdescr, sequence, total.
  3151.       if (!(nullp(*(stackptr STACKop -1)))) # from-end abfragen
  3152.         # from-end ist angegeben
  3153.         { # Defaultwert für end ist die Länge der Sequence:
  3154.           if (nullp(*(stackptr STACKop -3)))
  3155.             { { var reg4 object old_subr_self = subr_self; # aktuelles SUBR, nicht GC-gefährdet!
  3156.                 pushSTACK(STACK_1); funcall(seq_length(STACK_(2+1)),1); # (SEQ-LENGTH sequence)
  3157.                 *(stackptr STACKop -3) = value1; # =: end
  3158.                 subr_self = old_subr_self;
  3159.               }
  3160.               # Dann nochmals start und end überprüfen:
  3161.               test_start_end(&O(kwpair_start),&*(stackptr STACKop -3));
  3162.             }
  3163.           {pushSTACK(STACK_1); pushSTACK(*(stackptr STACKop -3));
  3164.            funcall(seq_fe_init_end(STACK_(2+2)),2); # (SEQ-FE-INIT-END sequence end)
  3165.            pushSTACK(value1); # =: pointer
  3166.           }
  3167.           { # count := (- end start), ein Integer >=0 :
  3168.             pushSTACK(I_I_minus_I(*(stackptr STACKop -3),*(stackptr STACKop -2)));
  3169.           }
  3170.           # Stackaufbau: ..., typdescr, sequence, total, pointer, count.
  3171.           { until (eq(STACK_0,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  3172.               { # item herausgreifen:
  3173.                 pushSTACK(STACK_3); pushSTACK(STACK_(1+1));
  3174.                 funcall(seq_access(STACK_(4+2)),2); # (SEQ-ACCESS sequence pointer)
  3175.                 funcall_key(*(stackptr STACKop -4)); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  3176.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  3177.                   { # Test ist erfüllt -> total := total + 1 :
  3178.                     STACK_2 = fixnum_inc(STACK_2,1);
  3179.                   }
  3180.                 # pointer weiterrücken und count decrementieren:
  3181.                 # pointer := (SEQ-FE-UPD sequence pointer) :
  3182.                 pointer_fe_update(STACK_1,STACK_3,STACK_4);
  3183.                 decrement(STACK_0); # count := (1- count)
  3184.         } }   }
  3185.         else
  3186.         # from-end ist nicht angegeben
  3187.         { init_endvar(&*(stackptr STACKop -3)); # endvar := (and end (- end start)) auf den Stack
  3188.           # Stackaufbau: ..., typdescr, sequence, total, endvar.
  3189.           {pushSTACK(STACK_2); pushSTACK(*(stackptr STACKop -2));
  3190.            funcall(seq_init_start(STACK_(3+2)),2); # (SEQ-INIT-START sequence start)
  3191.            pushSTACK(value1); # =: pointer
  3192.           }
  3193.           # Stackaufbau: ... typdescr, sequence, total, endvar, pointer
  3194.           { until (eq(STACK_1,Fixnum_0)) # endvar = 0 ?
  3195.                 # (also end angegeben und (- end start) Elemente durchlaufen ?)
  3196.                 # ja -> fertig
  3197.               { pushSTACK(STACK_3); pushSTACK(STACK_(0+1));
  3198.                 funcall(seq_endtest(STACK_(4+2)),2); # (SEQ-ENDTEST sequence pointer)
  3199.                 if (!(nullp(value1))) break; # Pointer am Ende -> fertig
  3200.                 # item herausgreifen:
  3201.                 pushSTACK(STACK_3); pushSTACK(STACK_(0+1));
  3202.                 funcall(seq_access(STACK_(4+2)),2); # (SEQ-ACCESS sequence pointer)
  3203.                 funcall_key(*(stackptr STACKop -4)); # (FUNCALL key (SEQ-ACCESS sequence pointer))
  3204.                 if ((*up_fun)(stackptr,value1)) # Testroutine aufrufen
  3205.                   { # Test ist erfüllt -> total := total + 1 :
  3206.                     STACK_2 = fixnum_inc(STACK_2,1);
  3207.                   }
  3208.                 # pointer := (SEQ-UPD sequence pointer) :
  3209.                 pointer_update(STACK_0,STACK_3,STACK_4);
  3210.                 # endvar eventuell decrementieren:
  3211.                 decrement_endvar(STACK_1);
  3212.         } }   }
  3213.       value1 = STACK_2; mv_count=1; skipSTACK(4); # total als Wert
  3214.     }
  3215.  
  3216. LISPFUN(count,2,0,norest,key,6,\
  3217.         (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not)) )
  3218. # (COUNT item sequence [:from-end] [:start] [:end] [:key] [:test] [:test-not]),
  3219. # CLTL S. 257
  3220.   { var reg1 object* stackptr = &STACK_6;
  3221.     var reg2 up_function up_fun = test_test_args(stackptr); # Testfunktion
  3222.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3223.     count_op(stackptr,up_fun); # suchen
  3224.     skipSTACK(2+6+1);
  3225.   }
  3226.  
  3227. LISPFUN(count_if,2,0,norest,key,4,\
  3228.         (kw(from_end),kw(start),kw(end),kw(key)) )
  3229. # (COUNT-IF test sequence [:from-end] [:start] [:end] [:key]),
  3230. # CLTL S. 257
  3231.   { var reg1 object* stackptr = &STACK_4;
  3232.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3233.     count_op(stackptr,&up_if); # suchen
  3234.     skipSTACK(2+4+1);
  3235.   }
  3236.  
  3237. LISPFUN(count_if_not,2,0,norest,key,4,\
  3238.         (kw(from_end),kw(start),kw(end),kw(key)) )
  3239. # (COUNT-IF-NOT test sequence [:from-end] [:start] [:end] [:key]),
  3240. # CLTL S. 257
  3241.   { var reg1 object* stackptr = &STACK_4;
  3242.     seq_prepare_testop(stackptr); # Argumente aufbereiten, typdescr
  3243.     count_op(stackptr,&up_if_not); # suchen
  3244.     skipSTACK(2+4+1);
  3245.   }
  3246.  
  3247. LISPFUN(mismatch,2,0,norest,key,8,\
  3248.         (kw(start1),kw(end1),kw(start2),kw(end2),kw(from_end),\
  3249.          kw(key),kw(test),kw(test_not)) )
  3250. # (MISMATCH sequence1 sequence2
  3251. #           [:start1] [:end1] [:start2] [:end2] [:from-end] [:key] [:test] [:test-not]),
  3252. # CLTL S. 257
  3253.   { # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3254.     #              key, test, test-not.
  3255.     var reg2 object* stackptr = &STACK_6;
  3256.     # key überprüfen:
  3257.     test_key_arg(stackptr);
  3258.     # test, test-not überprüfen:
  3259.    {var reg1 up2_function up2_fun = test_test2_args(stackptr);
  3260.     # sequence1 überprüfen:
  3261.     pushSTACK(get_valid_seq_type(STACK_(6+3)));
  3262.     # sequence2 überprüfen:
  3263.     pushSTACK(get_valid_seq_type(STACK_(5+3+1)));
  3264.     # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3265.     #              key, test, test-not, typdescr1, typdescr2.
  3266.     default_NIL(STACK_(0+5)); # Defaultwert für from-end ist NIL
  3267.     start_default_0(STACK_(4+5)); # Defaultwert für start1 ist 0
  3268.     default_NIL(STACK_(3+5)); # Defaultwert für end1 ist NIL
  3269.     start_default_0(STACK_(2+5)); # Defaultwert für start2 ist 0
  3270.     default_NIL(STACK_(1+5)); # Defaultwert für end2 ist NIL
  3271.     # from-end abfragen:
  3272.     if (!(nullp(STACK_(0+5))))
  3273.       # from-end ist angegeben
  3274.       { # Defaultwert von end1 ist (SEQ-LENGTH seq1):
  3275.         end_default_len(STACK_(3+5),STACK_(6+5),STACK_1);
  3276.         # Defaultwert von end2 ist (SEQ-LENGTH seq2):
  3277.         end_default_len(STACK_(1+5),STACK_(5+5),STACK_0);
  3278.         # start- und end-Argumente überprüfen:
  3279.         subr_self = L(mismatch);
  3280.         test_start_end(&O(kwpair_start1),&STACK_(3+5));
  3281.         test_start_end(&O(kwpair_start2),&STACK_(1+5));
  3282.         # pointer1 und pointer2 ans Ende der Sequences setzen:
  3283.         { pushSTACK(STACK_(6+5)); pushSTACK(STACK_(3+5+1));
  3284.           funcall(seq_fe_init_end(STACK_(1+2)),2); # (SEQ-FE-INIT-END seq1 end1)
  3285.           pushSTACK(value1); # =: pointer1
  3286.         }
  3287.         { pushSTACK(STACK_(5+5+1)); pushSTACK(STACK_(1+5+1+1));
  3288.           funcall(seq_fe_init_end(STACK_(0+1+2)),2); # (SEQ-FE-INIT-END seq2 end2)
  3289.           pushSTACK(value1); # =: pointer2
  3290.         }
  3291.         { pushSTACK(STACK_(3+5+2)); } # index := end1
  3292.         { var reg1 object len1 = I_I_minus_I(STACK_(3+5+3),STACK_(4+5+3)); # (- end1 start1)
  3293.           pushSTACK(len1); # =: len1, ein Integer >=0
  3294.         }
  3295.         { var reg1 object len2 = I_I_minus_I(STACK_(1+5+4),STACK_(2+5+4)); # (- end2 start2)
  3296.           pushSTACK(len2); # =: len2, ein Integer >=0
  3297.         }
  3298.         { var reg1 object count = (I_I_comp(STACK_1,STACK_0)<0 ? STACK_1 : STACK_0); # (min len1 len2)
  3299.           pushSTACK(count); # =: count, ein Integer >=0
  3300.         }
  3301.         # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3302.         #              key, test, test-not, typdescr1, typdescr2,
  3303.         #              pointer1, pointer2, index, len1, len2, count.
  3304.         until (eq(STACK_0,Fixnum_0)) # count (ein Integer) = 0 ?
  3305.           { pushSTACK(STACK_(6+5+6)); pushSTACK(STACK_(5+1));
  3306.             funcall(seq_access(STACK_(1+6+2)),2); # (SEQ-ACCESS seq1 pointer1)
  3307.             funcall_key(STACK_(4+6)); # (FUNCALL key (SEQ-ACCESS seq1 pointer1))
  3308.             pushSTACK(value1); # =: item1, retten
  3309.             pushSTACK(STACK_(5+5+6+1)); pushSTACK(STACK_(4+1+1));
  3310.             funcall(seq_access(STACK_(0+6+1+2)),2); # (SEQ-ACCESS seq2 pointer2)
  3311.             funcall_key(STACK_(4+6+1)); # (FUNCALL key (SEQ-ACCESS seq2 pointer2))
  3312.             {var reg2 object item2 = value1;
  3313.              var reg3 object item1 = popSTACK();
  3314.              # beide vergleichen:
  3315.              if (!((*up2_fun)(&STACK_(8+6),item1,item2))) # Testroutine anwenden
  3316.                goto fe_found;
  3317.             }
  3318.             # Test erfüllt -> weitersuchen:
  3319.             # pointer1 := (SEQ-FE-UPD seq1 pointer1) :
  3320.             pointer_fe_update(STACK_5,STACK_(6+5+6),STACK_(1+6));
  3321.             # pointer2 := (SEQ-FE-UPD seq2 pointer2) :
  3322.             pointer_fe_update(STACK_4,STACK_(5+5+6),STACK_(0+6));
  3323.             # index decrementieren:
  3324.             decrement(STACK_3);
  3325.             # count decrementieren:
  3326.             decrement(STACK_0);
  3327.           }
  3328.         # Schleife erfolgreich.
  3329.         # Bei len1=len2 Ergebnis NIL, sonst index:
  3330.         if (I_I_comp(STACK_2,STACK_1)==0) # len1=len2 (Integers) ?
  3331.           # Beide Sequence-Stücke sind gleich -> NIL als Wert
  3332.           { value1 = NIL; mv_count=1; skipSTACK(7+5+6); return; }
  3333.         fe_found: # Es ist ein Unterschied gefunden -> index als Wert
  3334.         { value1 = STACK_3; mv_count=1; skipSTACK(7+5+6); return; }
  3335.       }
  3336.       else
  3337.       # from-end ist nicht angegeben
  3338.       { # start- und end-Argumente überprüfen:
  3339.         test_start_end_1(&O(kwpair_start1),&STACK_(3+5));
  3340.         test_start_end_1(&O(kwpair_start2),&STACK_(1+5));
  3341.         # pointer1 und pointer2 an den Anfang der Sequences setzen:
  3342.         { pushSTACK(STACK_(6+5)); pushSTACK(STACK_(4+5+1));
  3343.           funcall(seq_init_start(STACK_(1+2)),2); # (SEQ-INIT-START seq1 start1)
  3344.           pushSTACK(value1); # =: pointer1
  3345.         }
  3346.         { pushSTACK(STACK_(5+5+1)); pushSTACK(STACK_(2+5+1+1));
  3347.           funcall(seq_init_start(STACK_(0+1+2)),2); # (SEQ-INIT-START seq2 start2)
  3348.           pushSTACK(value1); # =: pointer2
  3349.         }
  3350.         { pushSTACK(STACK_(4+5+2)); } # index := start1
  3351.         init_endvar(&STACK_(3+5+3)); # endvar1 := (and end1 (- end1 start1))
  3352.         init_endvar(&STACK_(1+5+4)); # endvar2 := (and end2 (- end2 start2))
  3353.         # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3354.         #              key, test, test-not, typdescr1, typdescr2,
  3355.         #              pointer1, pointer2, index, endvar1, endvar2.
  3356.         { var reg3 boolean seq1_ended; # Flag, ob seq1-Teilstück zu Ende
  3357.           var reg4 boolean seq2_ended; # Flag, ob seq2-Teilstück zu Ende
  3358.           loop
  3359.             { # Teste, ob seq1-Teilstück zu Ende:
  3360.               if (eq(STACK_1,Fixnum_0)) # endvar1 = 0 (und damit end1 /= nil) ?
  3361.                 { seq1_ended = TRUE; }
  3362.                 else
  3363.                 { pushSTACK(STACK_(6+5+5)); pushSTACK(STACK_(4+1));
  3364.                   funcall(seq_endtest(STACK_(1+5+2)),2); # (SEQ-ENDTEST seq1 pointer1)
  3365.                   seq1_ended = !nullp(value1);
  3366.                 }
  3367.               # Teste, ob seq2-Teilstück zu Ende:
  3368.               if (eq(STACK_0,Fixnum_0)) # endvar2 = 0 (und damit end2 /= nil) ?
  3369.                 { seq2_ended = TRUE; }
  3370.                 else
  3371.                 { pushSTACK(STACK_(5+5+5)); pushSTACK(STACK_(3+1));
  3372.                   funcall(seq_endtest(STACK_(0+5+2)),2); # (SEQ-ENDTEST seq2 pointer2)
  3373.                   seq2_ended = !nullp(value1);
  3374.                 }
  3375.               # Flags abtesten:
  3376.               if (seq1_ended || seq2_ended) break;
  3377.               # keines der beiden Flags ist gesetzt
  3378.               pushSTACK(STACK_(6+5+5)); pushSTACK(STACK_(4+1));
  3379.               funcall(seq_access(STACK_(1+5+2)),2); # (SEQ-ACCESS seq1 pointer1)
  3380.               funcall_key(STACK_(4+5)); # (FUNCALL key (SEQ-ACCESS seq1 pointer1))
  3381.               pushSTACK(value1); # =: item1, retten
  3382.               pushSTACK(STACK_(5+5+5+1)); pushSTACK(STACK_(3+1+1));
  3383.               funcall(seq_access(STACK_(0+5+1+2)),2); # (SEQ-ACCESS seq2 pointer2)
  3384.               funcall_key(STACK_(4+5+1)); # (FUNCALL key (SEQ-ACCESS seq2 pointer2))
  3385.               {var reg2 object item2 = value1;
  3386.                var reg3 object item1 = popSTACK();
  3387.                # beide vergleichen:
  3388.                if (!((*up2_fun)(&STACK_(8+5),item1,item2))) # Testroutine anwenden
  3389.                  goto fs_found;
  3390.               }
  3391.               # Test erfüllt -> weitersuchen:
  3392.               # pointer1 := (SEQ-UPD seq1 pointer1) :
  3393.               pointer_update(STACK_4,STACK_(6+5+5),STACK_(1+5));
  3394.               # pointer2 := (SEQ-UPD seq2 pointer2) :
  3395.               pointer_update(STACK_3,STACK_(5+5+5),STACK_(0+5));
  3396.               # index incrementieren:
  3397.               increment(STACK_2);
  3398.               # endvar1 eventuell decrementieren:
  3399.               decrement_endvar(STACK_1);
  3400.               # endvar2 eventuell decrementieren:
  3401.               decrement_endvar(STACK_0);
  3402.             }
  3403.           # Falls beide Flags gesetzt sind, Ergebnis NIL, sonst index:
  3404.           if (seq1_ended && seq2_ended)
  3405.             # Beide Sequence-Stücke sind gleich -> NIL als Wert
  3406.             { value1 = NIL; mv_count=1; skipSTACK(7+5+5); return; }
  3407.           fs_found: # Es ist ein Unterschied gefunden -> index als Wert
  3408.           { value1 = STACK_2; mv_count=1; skipSTACK(7+5+5); return; }
  3409.       } }
  3410.   }}
  3411.  
  3412. LISPFUN(search,2,0,norest,key,8,\
  3413.         (kw(start1),kw(end1),kw(start2),kw(end2),kw(from_end),\
  3414.          kw(key),kw(test),kw(test_not)) )
  3415. # (SEARCH sequence1 sequence2
  3416. #         [:start1] [:end1] [:start2] [:end2] [:from-end] [:key] [:test] [:test-not]),
  3417. # CLTL S. 258
  3418.   # Primitiv-Algorithmus:
  3419.   #   Rücke immer in sequence2 um 1 weiter und teste, ob dann sequence1 kommt.
  3420.   # Knuth-Algorithmus:
  3421.   #   [Donald Ervin Knuth, James H. Morris, Vaughan R. Pratt:
  3422.   #    Fast pattern matching in string.
  3423.   #    SIAM J. Comput. 6(1977), 323-350.]
  3424.   #   Kann hier nicht verwendet werden, weil er die Kommutativität der
  3425.   #   Testfunktion erfordert, die nach CLTL S. 247 nicht notwendig gegeben ist.
  3426.   { # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3427.     #              key, test, test-not.
  3428.     var reg2 object* stackptr = &STACK_6;
  3429.     # key überprüfen:
  3430.     test_key_arg(stackptr);
  3431.     # test, test-not überprüfen:
  3432.    {var reg1 up2_function up2_fun = test_test2_args(stackptr);
  3433.     # sequence1 überprüfen:
  3434.     pushSTACK(get_valid_seq_type(STACK_(6+3)));
  3435.     # sequence2 überprüfen:
  3436.     pushSTACK(get_valid_seq_type(STACK_(5+3+1)));
  3437.     # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3438.     #              key, test, test-not, typdescr1, typdescr2.
  3439.     default_NIL(STACK_(0+5)); # Defaultwert für from-end ist NIL
  3440.     # Sonderfall für Strings: schnellere Routine aufrufen
  3441.     if (eq(seq_type(STACK_1),S(string)) && eq(seq_type(STACK_0),S(string)) # beides STRINGs ?
  3442.         && nullp(STACK_(0+5)) # und kein from-end ?
  3443.         && eq(STACK_4,L(identity)) # und key = #'identity ?
  3444.         && (up2_fun == &up2_test) # und test-not nicht angegeben ?
  3445.        )
  3446.       { var reg3 object test = STACK_3;
  3447.         if (eq(test,L(eq)) || eq(test,L(eql)) || eq(test,L(equal)) || eq(test,L(char_gleich)))
  3448.           { skipSTACK(6);
  3449.             C_search_string_gleich(); # SUBR sys::search-string= mit denselben Argumenten
  3450.             return;
  3451.           }
  3452.         if (eq(test,L(equalp)) || eq(test,L(char_equal)))
  3453.           { skipSTACK(6);
  3454.             C_search_string_equal(); # SUBR sys::search-string-equal mit denselben Argumenten
  3455.             return;
  3456.       }   }
  3457.     start_default_0(STACK_(4+5)); # Defaultwert für start1 ist 0
  3458.     default_NIL(STACK_(3+5)); # Defaultwert für end1 ist NIL
  3459.     start_default_0(STACK_(2+5)); # Defaultwert für start2 ist 0
  3460.     default_NIL(STACK_(1+5)); # Defaultwert für end2 ist NIL
  3461.     # from-end abfragen:
  3462.     if (!(nullp(STACK_(0+5))))
  3463.       # from-end ist angegeben
  3464.       { # Defaultwert von end1 ist (SEQ-LENGTH seq1):
  3465.         end_default_len(STACK_(3+5),STACK_(6+5),STACK_1);
  3466.         # Defaultwert von end2 ist (SEQ-LENGTH seq2):
  3467.         end_default_len(STACK_(1+5),STACK_(5+5),STACK_0);
  3468.         # start- und end-Argumente überprüfen:
  3469.         subr_self = L(search);
  3470.         test_start_end(&O(kwpair_start1),&STACK_(3+5));
  3471.         test_start_end(&O(kwpair_start2),&STACK_(1+5));
  3472.         # pointer10 und pointer20 ans Ende der Sequences setzen:
  3473.         { pushSTACK(STACK_(6+5)); pushSTACK(STACK_(3+5+1));
  3474.           funcall(seq_fe_init_end(STACK_(1+2)),2); # (SEQ-FE-INIT-END seq1 end1)
  3475.           pushSTACK(value1); # =: pointer10
  3476.         }
  3477.         { pushSTACK(STACK_(5+5+1)); pushSTACK(STACK_(1+5+1+1));
  3478.           funcall(seq_fe_init_end(STACK_(0+1+2)),2); # (SEQ-FE-INIT-END seq2 end2)
  3479.           pushSTACK(value1); # =: pointer20
  3480.         }
  3481.         { var reg1 object len1 = I_I_minus_I(STACK_(3+5+2),STACK_(4+5+2)); # (- end1 start1)
  3482.           pushSTACK(len1); # =: len1, ein Integer >=0
  3483.         }
  3484.         { var reg1 object len2 = I_I_minus_I(STACK_(1+5+3),STACK_(2+5+3)); # (- end2 start2)
  3485.           pushSTACK(len2); # =: len2, ein Integer >=0
  3486.         }
  3487.         { var reg1 object index = I_I_minus_I(STACK_(1+5+4),STACK_1); # (- end2 len1)
  3488.           pushSTACK(index); # =: index, ein Integer
  3489.         }
  3490.         # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3491.         #              key, test, test-not, typdescr1, typdescr2,
  3492.         #              pointer10, pointer20, len1, len2, index.
  3493.         loop
  3494.           { # pointer1 und pointer2 ab pointer10 bzw. pointer20 laufen lassen:
  3495.             { pushSTACK(STACK_4); funcall(seq_copy(STACK_(1+5+1)),1); # (SEQ-COPY pointer10)
  3496.               pushSTACK(value1); # =: pointer1
  3497.             }
  3498.             { pushSTACK(STACK_(3+1)); funcall(seq_copy(STACK_(0+5+1+1)),1); # (SEQ-COPY pointer20)
  3499.               pushSTACK(value1); # =: pointer2
  3500.             }
  3501.             pushSTACK(STACK_(2+2)); # count1 := len1
  3502.             pushSTACK(STACK_(1+3)); # count2 := len2
  3503.             # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3504.             #              key, test, test-not, typdescr1, typdescr2,
  3505.             #              pointer10, pointer20, len1, len2, index,
  3506.             #              pointer1, pointer2, count1, count2.
  3507.             loop
  3508.               { if (eq(STACK_1,Fixnum_0)) # count1 (ein Integer) = 0 ?
  3509.                   goto found; # ja -> seq1 zu Ende, gefunden
  3510.                 if (eq(STACK_0,Fixnum_0)) # count2 (ein Integer) = 0 ?
  3511.                   goto notfound; # ja -> seq2 zu Ende, nicht gefunden
  3512.                 pushSTACK(STACK_(6+5+5+4)); pushSTACK(STACK_(3+1));
  3513.                 funcall(seq_access(STACK_(1+5+4+2)),2); # (SEQ-ACCESS seq1 pointer1)
  3514.                 funcall_key(STACK_(4+5+4)); # (FUNCALL key (SEQ-ACCESS seq1 pointer1))
  3515.                 pushSTACK(value1); # =: item1, retten
  3516.                 pushSTACK(STACK_(5+5+5+4+1)); pushSTACK(STACK_(2+1+1));
  3517.                 funcall(seq_access(STACK_(0+5+4+1+2)),2); # (SEQ-ACCESS seq2 pointer2)
  3518.                 funcall_key(STACK_(4+5+4+1)); # (FUNCALL key (SEQ-ACCESS seq2 pointer2))
  3519.                 {var reg2 object item2 = value1;
  3520.                  var reg3 object item1 = popSTACK();
  3521.                  # beide vergleichen:
  3522.                  if (!((*up2_fun)(&STACK_(8+5+4),item1,item2))) # Testroutine anwenden
  3523.                    break;
  3524.                 }
  3525.                 # Test erfüllt -> weitervergleichen:
  3526.                 # pointer1 := (SEQ-FE-UPD seq1 pointer1) :
  3527.                 pointer_fe_update(STACK_3,STACK_(6+5+5+4),STACK_(1+5+4));
  3528.                 # pointer2 := (SEQ-FE-UPD seq2 pointer2) :
  3529.                 pointer_fe_update(STACK_2,STACK_(5+5+5+4),STACK_(0+5+4));
  3530.                 # count1 decrementieren:
  3531.                 decrement(STACK_1);
  3532.                 # count2 decrementieren:
  3533.                 decrement(STACK_0);
  3534.               }
  3535.             # Test nicht erfüllt -> weitersuchen
  3536.             skipSTACK(4); # pointer1, pointer2, count1, count2 vergessen
  3537.             # pointer20 weiterrücken, len2 und index decrementieren:
  3538.             pointer_fe_update(STACK_3,STACK_(6+5+5),STACK_(0+5));
  3539.             decrement(STACK_1); # len2 := (1- len2)
  3540.             decrement(STACK_0); # index := (1- index)
  3541.       }   }
  3542.       else
  3543.       # from-end ist nicht angegeben
  3544.       { # start- und end-Argumente überprüfen:
  3545.         test_start_end_1(&O(kwpair_start1),&STACK_(3+5));
  3546.         test_start_end_1(&O(kwpair_start2),&STACK_(1+5));
  3547.         # pointer10 und pointer20 an den Anfang der Sequences setzen:
  3548.         { pushSTACK(STACK_(6+5)); pushSTACK(STACK_(4+5+1));
  3549.           funcall(seq_init_start(STACK_(1+2)),2); # (SEQ-INIT-START seq1 start1)
  3550.           pushSTACK(value1); # =: pointer10
  3551.         }
  3552.         { pushSTACK(STACK_(5+5+1)); pushSTACK(STACK_(2+5+1+1));
  3553.           funcall(seq_init_start(STACK_(0+1+2)),2); # (SEQ-INIT-START seq2 start2)
  3554.           pushSTACK(value1); # =: pointer20
  3555.         }
  3556.         init_endvar(&STACK_(3+5+2)); # endvar10 := (and end1 (- end1 start1))
  3557.         init_endvar(&STACK_(1+5+3)); # endvar20 := (and end2 (- end2 start2))
  3558.         pushSTACK(STACK_(2+5+4)); # index := start2
  3559.         # Stackaufbau: seq1, seq2, start1, end1, start2, end2, from-end,
  3560.         #              key, test, test-not, typdescr1, typdescr2,
  3561.         #              pointer10, pointer20, endvar10, endvar20, index.
  3562.         loop
  3563.           { # pointer1 und pointer2 ab pointer10 bzw. pointer20 laufen lassen:
  3564.             { pushSTACK(STACK_4); funcall(seq_copy(STACK_(1+5+1)),1); # (SEQ-COPY pointer10)
  3565.               pushSTACK(value1); # =: pointer1
  3566.             }
  3567.             { pushSTACK(STACK_(3+1)); funcall(seq_copy(STACK_(0+5+1+1)),1); # (SEQ-COPY pointer20)
  3568.               pushSTACK(value1); # =: pointer2
  3569.             }
  3570.             pushSTACK(STACK_(2+2)); # endvar1 := endvar10
  3571.             pushSTACK(STACK_(1+3)); # endvar2 := endvar20
  3572.             # Stackaufbau: seq1, seq2, from-end, start1, end1, start2, end2,
  3573.             #              key, test, test-not, typdescr1, typdescr2,
  3574.             #              pointer10, pointer20, endvar10, endvar20, index,
  3575.             #              pointer1, pointer2, endvar1, endvar2.
  3576.             loop
  3577.               { # Teste, ob seq1-Teilstück zu Ende. Wenn ja: gefunden.
  3578.                 if (eq(STACK_1,Fixnum_0)) # endvar1 = 0 (und damit end1 /= nil) ?
  3579.                   { goto found; }
  3580.                   else
  3581.                   { pushSTACK(STACK_(6+5+5+4)); pushSTACK(STACK_(3+1));
  3582.                     funcall(seq_endtest(STACK_(1+5+4+2)),2); # (SEQ-ENDTEST seq1 pointer1)
  3583.                     if (!nullp(value1)) goto found;
  3584.                   }
  3585.                 # seq1 ist noch nicht am Ende.
  3586.                 # Teste, ob seq2-Teilstück zu Ende. Wenn ja: nicht gefunden.
  3587.                 if (eq(STACK_0,Fixnum_0)) # endvar2 = 0 (und damit end2 /= nil) ?
  3588.                   { goto notfound; }
  3589.                   else
  3590.                   { pushSTACK(STACK_(5+5+5+4)); pushSTACK(STACK_(2+1));
  3591.                     funcall(seq_endtest(STACK_(0+5+4+2)),2); # (SEQ-ENDTEST seq2 pointer2)
  3592.                     if (!nullp(value1)) goto notfound;
  3593.                   }
  3594.                 # seq2 ist noch nicht am Ende.
  3595.                 pushSTACK(STACK_(6+5+5+4)); pushSTACK(STACK_(3+1));
  3596.                 funcall(seq_access(STACK_(1+5+4+2)),2); # (SEQ-ACCESS seq1 pointer1)
  3597.                 funcall_key(STACK_(4+5+4)); # (FUNCALL key (SEQ-ACCESS seq1 pointer1))
  3598.                 pushSTACK(value1); # =: item1, retten
  3599.                 pushSTACK(STACK_(5+5+5+4+1)); pushSTACK(STACK_(2+1+1));
  3600.                 funcall(seq_access(STACK_(0+5+4+1+2)),2); # (SEQ-ACCESS seq2 pointer2)
  3601.                 funcall_key(STACK_(4+5+4+1)); # (FUNCALL key (SEQ-ACCESS seq2 pointer2))
  3602.                 {var reg2 object item2 = value1;
  3603.                  var reg3 object item1 = popSTACK();
  3604.                  # beide vergleichen:
  3605.                  if (!((*up2_fun)(&STACK_(8+5+4),item1,item2))) # Testroutine anwenden
  3606.                    break;
  3607.                 }
  3608.                 # Test erfüllt -> weitervergleichen:
  3609.                 # pointer1 := (SEQ-UPD seq1 pointer1) :
  3610.                 pointer_update(STACK_3,STACK_(6+5+5+4),STACK_(1+5+4));
  3611.                 # pointer2 := (SEQ-UPD seq2 pointer2) :
  3612.                 pointer_update(STACK_2,STACK_(5+5+5+4),STACK_(0+5+4));
  3613.                 # endvar1 eventuell decrementieren:
  3614.                 decrement_endvar(STACK_1);
  3615.                 # endvar2 eventuell decrementieren:
  3616.                 decrement_endvar(STACK_0);
  3617.               }
  3618.             # Test nicht erfüllt -> weitersuchen
  3619.             skipSTACK(4); # pointer1, pointer2, endvar1, endvar2 vergessen
  3620.             # pointer20 weiterrücken:
  3621.             pointer_update(STACK_3,STACK_(6+5+5),STACK_(0+5));
  3622.             # endvar20 eventuell decrementieren:
  3623.             decrement_endvar(STACK_1);
  3624.             # index incrementieren:
  3625.             increment(STACK_0);
  3626.       }   }
  3627.     /*NOTREACHED*/
  3628.     found: # index als Wert
  3629.       { value1 = STACK_4; mv_count=1; skipSTACK(7+5+5+4); return; }
  3630.     notfound: # NIL als Wert
  3631.       { value1 = NIL; mv_count=1; skipSTACK(7+5+5+4); return; }
  3632.   }}
  3633.  
  3634. # UP für SORT, STABLE-SORT und MERGE:
  3635. # merge(stackptr);
  3636. # sortiert zwei sortierte Sequence-Teile in eine dritte Sequence zusammen.
  3637. # > STACK_10: sequence1
  3638. # > STACK_9: typdescr1
  3639. # > STACK_8: sequence2
  3640. # > STACK_7: typdescr2
  3641. # > STACK_6: sequence3
  3642. # > STACK_5: typdescr3
  3643. # > STACK_4: count1 (ein Integer >=0)
  3644. # > STACK_3: count2 (ein Integer >=0)
  3645. # > STACK_2: pointer1
  3646. # > STACK_1: pointer2
  3647. # > STACK_0: pointer3
  3648. # > stackptr: Pointer in den Stack,
  3649. #     *(stackptr+0) = predicate, *(stackptr-1) = key
  3650. # count1+count2 Elemente aus sequence1 oder sequence2 werden nach sequence3
  3651. # übertragen (im Zweifelsfall die aus sequence1 zuerst).
  3652. # Dabei wird pointer1 genau  count1  mal weitergerückt (mit SEQ-UPD),
  3653. #            pointer2 genau  count2  mal weitergerückt (mit SEQ-UPD),
  3654. #            pointer3 genau  count1+count2  mal weitergerückt (mit SEQ-UPD).
  3655. # count1 und count2 werden auf 0 gesetzt.
  3656. # kann GC auslösen
  3657.   local void merge (object* stackptr);
  3658.   local void merge(stackptr)
  3659.     var reg1 object* stackptr;
  3660.     { loop
  3661.         { if (eq(STACK_4,Fixnum_0)) goto seq1_end; # count1 = 0 -> seq1 zu Ende
  3662.           if (eq(STACK_3,Fixnum_0)) goto seq2_end; # count1 = 0 -> seq2 zu Ende
  3663.           # item2 holen:
  3664.           { pushSTACK(STACK_8); pushSTACK(STACK_(1+1));
  3665.             funcall(seq_access(STACK_(7+2)),2); # (SEQ-ACCESS sequence2 pointer2)
  3666.             funcall_key(*(stackptr STACKop -1)); # (FUNCALL key (SEQ-ACCESS sequence2 pointer2))
  3667.             pushSTACK(value1); # =: item2
  3668.           }
  3669.           # item1 holen:
  3670.           { pushSTACK(STACK_(10+1)); pushSTACK(STACK_(2+1+1));
  3671.             funcall(seq_access(STACK_(9+1+2)),2); # (SEQ-ACCESS sequence1 pointer1)
  3672.             funcall_key(*(stackptr STACKop -1)); # (FUNCALL key (SEQ-ACCESS sequence1 pointer1))
  3673.             pushSTACK(value1); # =: item1
  3674.           }
  3675.           funcall(*(stackptr STACKop 0),2); # (FUNCALL predicate item2 item1)
  3676.           if (nullp(value1))
  3677.             # predicate lieferte NIL, item aus sequence1 übernehmen:
  3678.             { pushSTACK(STACK_(10)); pushSTACK(STACK_(2+1));
  3679.               funcall(seq_access(STACK_(9+2)),2); # (SEQ-ACCESS sequence1 pointer1)
  3680.               pushSTACK(value1); # auf den Stack
  3681.               # pointer1 := (SEQ-UPD sequence1 pointer1) :
  3682.               pointer_update(STACK_(2+1),STACK_(10+1),STACK_(9+1));
  3683.               # count1 := (1- count1) :
  3684.               decrement(STACK_(4+1));
  3685.             }
  3686.             else
  3687.             # predicate war erfüllt, item aus sequence2 übernehmen:
  3688.             { pushSTACK(STACK_(8)); pushSTACK(STACK_(1+1));
  3689.               funcall(seq_access(STACK_(7+2)),2); # (SEQ-ACCESS sequence2 pointer2)
  3690.               pushSTACK(value1); # auf den Stack
  3691.               # pointer2 := (SEQ-UPD sequence2 pointer2) :
  3692.               pointer_update(STACK_(1+1),STACK_(8+1),STACK_(7+1));
  3693.               # count2 := (1- count2) :
  3694.               decrement(STACK_(3+1));
  3695.             }
  3696.           {var reg2 object item = popSTACK(); # zu übernehmendes item
  3697.            pushSTACK(STACK_6); pushSTACK(STACK_(0+1)); pushSTACK(item);
  3698.            funcall(seq_access_set(STACK_(5+3)),3); # (SEQ-ACCESS-SET sequence3 pointer3 item)
  3699.           }
  3700.           # pointer3 := (SEQ-UPD sequence3 pointer3) :
  3701.           pointer_update(STACK_0,STACK_6,STACK_5);
  3702.         }
  3703.       /*NOTREACHED*/
  3704.       seq1_end:
  3705.         # sequence1 zu Ende. Rest aus sequence2 übernehmen:
  3706.         # Falls sequence2 und sequence3 EQ sind, liegt ein Aufruf
  3707.         # von SORT oder STABLE-SORT aus vor. Dort sind dann auch die
  3708.         # Pointer pointer2 und pointer3 gleich, also braucht gar nicht
  3709.         # mehr kopiert zu werden:
  3710.         if (eq(STACK_8,STACK_6)) # sequence2 = sequence3 ?
  3711.           { return; }
  3712.         until (eq(STACK_3,Fixnum_0)) # count2 = 0 ?
  3713.           { pushSTACK(STACK_(8)); pushSTACK(STACK_(1+1));
  3714.             funcall(seq_access(STACK_(7+2)),2); # (SEQ-ACCESS sequence2 pointer2)
  3715.             pushSTACK(STACK_6); pushSTACK(STACK_(0+1)); pushSTACK(value1);
  3716.             funcall(seq_access_set(STACK_(5+3)),3); # (SEQ-ACCESS-SET sequence3 pointer3 ...)
  3717.             # pointer2 := (SEQ-UPD sequence2 pointer2) :
  3718.             pointer_update(STACK_1,STACK_8,STACK_7);
  3719.             # count2 := (1- count2) :
  3720.             decrement(STACK_3);
  3721.             # pointer3 := (SEQ-UPD sequence3 pointer3) :
  3722.             pointer_update(STACK_0,STACK_6,STACK_5);
  3723.           }
  3724.         return;
  3725.       seq2_end:
  3726.         # sequence2 zu Ende, sequence1 nicht. Rest aus sequence1 nehmen:
  3727.         do { pushSTACK(STACK_(10)); pushSTACK(STACK_(2+1));
  3728.              funcall(seq_access(STACK_(9+2)),2); # (SEQ-ACCESS sequence1 pointer1)
  3729.              pushSTACK(STACK_6); pushSTACK(STACK_(0+1)); pushSTACK(value1);
  3730.              funcall(seq_access_set(STACK_(5+3)),3); # (SEQ-ACCESS-SET sequence3 pointer3 ...)
  3731.              # pointer1 := (SEQ-UPD sequence1 pointer1) :
  3732.              pointer_update(STACK_2,STACK_10,STACK_9);
  3733.              # count1 := (1- count1) :
  3734.              decrement(STACK_4);
  3735.              # pointer3 := (SEQ-UPD sequence3 pointer3) :
  3736.              pointer_update(STACK_0,STACK_6,STACK_5);
  3737.            }
  3738.            until (eq(STACK_4,Fixnum_0)); # count1 = 0 ?
  3739.         return;
  3740.     }
  3741.  
  3742. # UP: Sortiert in sequence ab pointer_left genau k Elemente (k >= 1)
  3743. # und liefert einen Pointer nach diesen k Elementen.
  3744. # sort_part(pointer_left,k,stackptr)
  3745. # pointer_left wird destruktiv verändert.
  3746. # > pointer_left
  3747. # > k
  3748. # > stackptr: Pointer in den Stack:
  3749. #       sequence, predicate [stackptr], key, start, end, typdescr, seq2
  3750. # < ergebnis: Pointer nach den k Elementen
  3751. # kann GC auslösen
  3752.   local object sort_part (object pointer_left, object k, object* stackptr);
  3753.   local object sort_part(pointer_left,k,stackptr)
  3754.     var reg4 object pointer_left;
  3755.     var reg3 object k;
  3756.     var reg1 object* stackptr;
  3757.     { if (eq(k,Fixnum_1))
  3758.         { # k=1. Fast nichts zu tun
  3759.           pushSTACK(*(stackptr STACKop 1)); pushSTACK(pointer_left);
  3760.           funcall(seq_upd(*(stackptr STACKop -4)),2); # (SEQ-UPD sequence pointer_left)
  3761.           return value1; # als Ergebnis
  3762.         }
  3763.         else
  3764.         { # k>1.
  3765.           pushSTACK(pointer_left);
  3766.           pushSTACK(k);
  3767.           pushSTACK(I_I_ash_I(k,Fixnum_minus1)); # (ASH k -1) = (FLOOR k 2) =: kl
  3768.           STACK_1 = I_I_minus_I(STACK_1,STACK_0); # (- k (FLOOR k 2)) = (CEILING k 2) =: kr
  3769.           # Stackaufbau: pointer_left, kr, kl.
  3770.           # mit kl = (floor k 2) und kr = (ceiling k 2), also k = (+ kl kr).
  3771.           # rekursiv die linke Hälfte sortieren:
  3772.           { pushSTACK(STACK_2); # pointer_left
  3773.             funcall(seq_copy(*(stackptr STACKop -4)),1); # (SEQ-COPY pointer_left)
  3774.            {var reg2 object pointer_mid = sort_part(value1,STACK_0,stackptr);
  3775.             pushSTACK(pointer_mid);
  3776.           }}
  3777.           # Stackaufbau: pointer_left, kr, kl, pointer_mid.
  3778.           # rekursiv die rechte Hälfte sortieren:
  3779.           { pushSTACK(STACK_0); # pointer_mid
  3780.             funcall(seq_copy(*(stackptr STACKop -4)),1); # (SEQ-COPY pointer_mid)
  3781.            {var reg2 object pointer_right = sort_part(value1,STACK_2,stackptr);
  3782.             pushSTACK(pointer_right);
  3783.           }}
  3784.           # Stackaufbau: pointer_left, kr, kl, pointer_mid, pointer_right.
  3785.           # Linke Hälfte (sortiert) nach seq2 kopieren:
  3786.           { var reg2 object typdescr = *(stackptr STACKop -4);
  3787.             pushSTACK(*(stackptr STACKop 1)); # sequence
  3788.             pushSTACK(typdescr); # typdescr
  3789.             pushSTACK(*(stackptr STACKop -5)); # seq2
  3790.             pushSTACK(typdescr); # typdescr
  3791.             pushSTACK(STACK_(2+4)); # kl
  3792.             { pushSTACK(STACK_(4+5)); # pointer_left
  3793.               funcall(seq_copy(typdescr),1); # (SEQ-COPY pointer_left)
  3794.               pushSTACK(value1); # =: pointer1
  3795.             }
  3796.             typdescr = STACK_2;
  3797.             { pushSTACK(STACK_3); # seq2
  3798.               funcall(seq_init(typdescr),1); # (SEQ-INIT seq2)
  3799.               pushSTACK(value1); # =: pointer2
  3800.             }
  3801.             # Stackaufbau: pointer_left, kr, kl, pointer_mid, pointer_right,
  3802.             #              sequence, typdescr, seq2, typdescr, kl, pointer1, pointer2.
  3803.             copy_seqpart_into(); # kopieren
  3804.             skipSTACK(3);
  3805.           }
  3806.           # Stackaufbau: pointer_left, kr, kl, pointer_mid, pointer_right,
  3807.           #              sequence, typdescr, seq2, typdescr.
  3808.           { pushSTACK(STACK_3); # sequence
  3809.             pushSTACK(STACK_(2+1)); # typdescr
  3810.             pushSTACK(STACK_(3+2)); # sequence
  3811.             pushSTACK(STACK_(2+3)); # typdescr
  3812.             pushSTACK(STACK_(2+4+4)); # kl
  3813.             pushSTACK(STACK_(3+4+5)); # kr
  3814.             { pushSTACK(STACK_(1+6)); # seq2
  3815.               funcall(seq_init(STACK_(0+6+1)),1); # (SEQ-INIT seq2)
  3816.               pushSTACK(value1); # als Source-Pointer in seq2
  3817.             }
  3818.             pushSTACK(STACK_(1+4+7)); # pointer_mid als Source in sequence
  3819.             pushSTACK(STACK_(4+4+8)); # pointer_left als Destination in sequence
  3820.             merge(stackptr); # von seq2 nach sequence hineinmergen
  3821.             { var reg2 object pointer_right = STACK_(0+4+9); # pointer_right
  3822.               skipSTACK(5+4+9);
  3823.               return pointer_right; # als Ergebnis
  3824.         } } }
  3825.     }
  3826.  
  3827. # UP für SORT und STABLE-SORT: Sortiert einen Teil einer Sequence.
  3828. # stable_sort();
  3829. # > Stackaufbau: sequence, predicate, key, start, end
  3830. # < mv_space/mv_count: Werte
  3831. # kann GC auslösen
  3832.   local Values stable_sort (void);
  3833.   local Values stable_sort()
  3834.     { # Stackaufbau: sequence, predicate, key, start, end.
  3835.       # sequence überprüfen:
  3836.       pushSTACK(get_valid_seq_type(STACK_4)); # typdescr
  3837.       # Stackaufbau: sequence, predicate, key, start, end, typdescr.
  3838.       # Defaultwert für start ist 0 :
  3839.       start_default_0(STACK_2);
  3840.       # Defaultwert für end:
  3841.       end_default_len(STACK_1,STACK_5,STACK_0);
  3842.       # Argumente start und end überprüfen:
  3843.       test_start_end(&O(kwpair_start),&STACK_1);
  3844.       # key überprüfen:
  3845.       test_key_arg(&STACK_7);
  3846.       # l := (- end start), ein Integer >=0
  3847.      {var reg2 object l = I_I_minus_I(STACK_1,STACK_2);
  3848.       pushSTACK(l);
  3849.       # Stackaufbau: sequence, predicate, key, start, end, typdescr, l.
  3850.       if (!(eq(l,Fixnum_0))) # Bei l=0 ist nichts zu tun
  3851.         { # Hilfssequence der Länge (floor l 2) erzeugen:
  3852.           { pushSTACK(I_I_ash_I(l,Fixnum_minus1)); # (ASH l -1) = (FLOOR l 2)
  3853.             funcall(seq_make(STACK_(1+1)),1); # (SEQ-MAKE (FLOOR l 2))
  3854.             pushSTACK(value1); # =: seq2
  3855.           }
  3856.           # Stackaufbau: sequence, predicate, key, start, end, typdescr, l,
  3857.           #              seq2.
  3858.           pushSTACK(STACK_(6+1)); pushSTACK(STACK_(3+1+1));
  3859.           funcall(seq_init_start(STACK_(1+1+2)),2); # (SEQ-INIT-START sequence start)
  3860.           l = STACK_(0+1); STACK_(0+1) = STACK_0; skipSTACK(1); # seq2 ersetzt l im Stack
  3861.           sort_part(value1,l,&STACK_5); # Stück der Länge l ab start sortieren
  3862.         }
  3863.       skipSTACK(6); value1 = popSTACK(); mv_count=1; # sortierte sequence als Wert
  3864.     }}
  3865.  
  3866. LISPFUN(sort,2,0,norest,key,3, (kw(key),kw(start),kw(end)) )
  3867. # (SORT sequence predicate [:key] [:start] [:end]), CLTL S. 258
  3868.   { return_Values stable_sort(); }
  3869.  
  3870. LISPFUN(stable_sort,2,0,norest,key,3, (kw(key),kw(start),kw(end)) )
  3871. # (STABLE-SORT sequence predicate [:key] [:start] [:end]), CLTL S. 258
  3872.   { return_Values stable_sort(); }
  3873.  
  3874. LISPFUN(merge,4,0,norest,key,1, (kw(key)) )
  3875. # (MERGE result-type sequence1 sequence2 predicate [:key]), CLTL S. 260
  3876.   { # Stackaufbau: result-type, sequence1, sequence2, predicate, key.
  3877.     # key-Argument überprüfen:
  3878.     test_key_arg(&STACK_4);
  3879.     # sequence1 überprüfen:
  3880.     {var reg1 object seq1 = STACK_3;
  3881.      pushSTACK(seq1);
  3882.      pushSTACK(get_valid_seq_type(seq1));
  3883.     }
  3884.     # sequence2 überprüfen:
  3885.     {var reg1 object seq2 = STACK_(2+2);
  3886.      pushSTACK(seq2);
  3887.      pushSTACK(get_valid_seq_type(seq2));
  3888.     }
  3889.     # result-type überprüfen:
  3890.     {var reg1 object typdescr3 = valid_type(STACK_(4+4));
  3891.      pushSTACK(NIL); # Dummy
  3892.      pushSTACK(typdescr3);
  3893.     }
  3894.     # Stackaufbau: result-type, sequence1, sequence2, predicate, key,
  3895.     #              sequence1, typdescr1, sequence2, typdescr2, dummy, typdescr3.
  3896.     # Längen von sequence1 und sequence2 bestimmen:
  3897.     { pushSTACK(STACK_5); funcall(seq_length(STACK_(4+1)),1); # (SEQ-LENGTH sequence1)
  3898.       pushSTACK(value1); # =: len1
  3899.     }
  3900.     { pushSTACK(STACK_(3+1)); funcall(seq_length(STACK_(2+1+1)),1); # (SEQ-LENGTH sequence2)
  3901.       pushSTACK(value1); # =: len2
  3902.     }
  3903.     # beide Längen addieren und neue Sequence der Gesamtlänge bilden:
  3904.     { pushSTACK(I_I_plus_I(STACK_1,STACK_0)); # (+ len1 len2)
  3905.       funcall(seq_make(STACK_(0+2+1)),1); # (SEQ-MAKE (+ len1 len2))
  3906.       STACK_(1+2) = value1; # ersetzt Dummy im Stack
  3907.     }
  3908.     # Stackaufbau: result-type, sequence1, sequence2, predicate, key,
  3909.     #              sequence1, typdescr1, sequence2, typdescr2, sequence3, typdescr3,
  3910.     #              len1, len2.
  3911.     # Pointer an den Anfang der Sequences bestimmen:
  3912.     { pushSTACK(STACK_(5+2)); funcall(seq_init(STACK_(4+2+1)),1); # (SEQ-INIT sequence1)
  3913.       pushSTACK(value1); # =: pointer1
  3914.     }
  3915.     { pushSTACK(STACK_(3+2+1)); funcall(seq_init(STACK_(2+2+1+1)),1); # (SEQ-INIT sequence2)
  3916.       pushSTACK(value1); # =: pointer2
  3917.     }
  3918.     { pushSTACK(STACK_(1+2+2)); funcall(seq_init(STACK_(0+2+2+1)),1); # (SEQ-INIT sequence3)
  3919.       pushSTACK(value1); # =: pointer3
  3920.     }
  3921.     # Stackaufbau: result-type, sequence1, sequence2, predicate, key,
  3922.     #              sequence1, typdescr1, sequence2, typdescr2, sequence3, typdescr3,
  3923.     #              len1, len2, pointer1, pointer2, pointer3.
  3924.     # Merge-Operation durchführen:
  3925.     merge(&STACK_(1+6+5));
  3926.     value1 = STACK_(1+5); mv_count=1; # sequence3 als Wert
  3927.     skipSTACK(5+6+5);
  3928.   }
  3929.  
  3930. LISPFUN(read_char_sequence,2,0,norest,key,2, (kw(start),kw(end)) )
  3931. # (READ-CHAR-SEQUENCE sequence stream [:start] [:end]), cf. dpANS S. 21-26
  3932.   { # Stackaufbau: sequence, stream, start, end.
  3933.     # sequence überprüfen:
  3934.     pushSTACK(get_valid_seq_type(STACK_3));
  3935.     # Stackaufbau: sequence, stream, start, end, typdescr.
  3936.     # Stream überprüfen:
  3937.     if (!mstreamp(STACK_3)) { fehler_stream(STACK_3); }
  3938.     # Defaultwert für start ist 0:
  3939.     start_default_0(STACK_2);
  3940.     # Defaultwert für end ist die Länge der Sequence:
  3941.     end_default_len(STACK_1,STACK_4,STACK_0);
  3942.     # start- und end-Argumente überprüfen:
  3943.     test_start_end(&O(kwpair_start),&STACK_1);
  3944.     if (eq(seq_type(STACK_0),S(string))) # Typname = STRING ?
  3945.       { var uintL len;
  3946.         var reg2 uintB* charptr = unpack_string(STACK_4,&len);
  3947.         # Ab charptr kommen len Zeichen.
  3948.         var reg3 uintL start = posfixnum_to_L(STACK_2);
  3949.         var reg4 uintL end = posfixnum_to_L(STACK_1);
  3950.         # Versuche, eine optimierte Lese-Routine aufzurufen:
  3951.         var reg1 uintB* endptr = read_schar_array(STACK_3,&charptr[start],end-start);
  3952.         if (!(endptr==NULL))
  3953.           { value1 = fixnum(endptr-charptr); mv_count=1;
  3954.             skipSTACK(5);
  3955.             return;
  3956.       }   }
  3957.     # Durchlauf-Pointer bestimmen:
  3958.     pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  3959.     funcall(seq_init_start(STACK_(0+2)),2); # (SEQ-INIT-START sequence start)
  3960.     pushSTACK(value1); # =: pointer
  3961.     # Stackaufbau: sequence, stream, index, end, typdescr, pointer.
  3962.     until (eql(STACK_3,STACK_2)) # index = end (beides Integers) -> fertig
  3963.       { var reg1 object item = read_char(&STACK_4); # ein Element lesen
  3964.         if (eq(item,eof_value)) break; # EOF -> fertig
  3965.         pushSTACK(STACK_5); pushSTACK(STACK_(0+1)); pushSTACK(item);
  3966.         funcall(seq_access_set(STACK_(1+3)),3); # (SEQ-ACCESS-SET sequence pointer item)
  3967.         # pointer := (SEQ-UPD sequence pointer) :
  3968.         pointer_update(STACK_0,STACK_5,STACK_1);
  3969.         # index := (1+ index) :
  3970.         increment(STACK_3);
  3971.       }
  3972.     value1 = STACK_3; mv_count=1; # index als Wert
  3973.     skipSTACK(6);
  3974.   }
  3975.  
  3976. LISPFUN(write_char_sequence,2,0,norest,key,2, (kw(start),kw(end)) )
  3977. # (WRITE-CHAR-SEQUENCE sequence stream [:start] [:end]), cf. dpANS S. 21-27
  3978.   { # Stackaufbau: sequence, stream, start, end.
  3979.     # sequence überprüfen:
  3980.     pushSTACK(get_valid_seq_type(STACK_3));
  3981.     # Stackaufbau: sequence, stream, start, end, typdescr.
  3982.     # Stream überprüfen:
  3983.     if (!mstreamp(STACK_3)) { fehler_stream(STACK_3); }
  3984.     # Defaultwert für start ist 0:
  3985.     start_default_0(STACK_2);
  3986.     # Defaultwert für end ist die Länge der Sequence:
  3987.     end_default_len(STACK_1,STACK_4,STACK_0);
  3988.     # start- und end-Argumente überprüfen:
  3989.     test_start_end(&O(kwpair_start),&STACK_1);
  3990.     if (eq(seq_type(STACK_0),S(string))) # Typname = STRING ?
  3991.       { var uintL len;
  3992.         var reg2 uintB* charptr = unpack_string(STACK_4,&len);
  3993.         # Ab charptr kommen len Zeichen.
  3994.         var reg3 uintL start = posfixnum_to_L(STACK_2);
  3995.         var reg4 uintL end = posfixnum_to_L(STACK_1);
  3996.         # Versuche, eine optimierte Schreib-Routine aufzurufen:
  3997.         var reg1 uintB* endptr = write_schar_array(STACK_3,&charptr[start],end-start);
  3998.         if (!(endptr==NULL)) goto done;
  3999.       }
  4000.     # start- und end-Argumente subtrahieren:
  4001.     STACK_1 = I_I_minus_I(STACK_1,STACK_2); # (- end start), ein Integer >=0
  4002.     # Stackaufbau: sequence, item, start, count, typdescr.
  4003.     # Durchlauf-Pointer bestimmen:
  4004.     pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  4005.     funcall(seq_init_start(STACK_(0+2)),2); # (SEQ-INIT-START sequence start)
  4006.     STACK_2 = value1; # =: pointer
  4007.     # Stackaufbau: sequence, stream, pointer, count, typdescr.
  4008.     until (eq(STACK_1,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  4009.       { pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  4010.         funcall(seq_access(STACK_(0+2)),2); # (SEQ-ACCESS sequence pointer)
  4011.         write_char(&STACK_3,value1); # ein Element ausgeben
  4012.         # pointer := (SEQ-UPD sequence pointer) :
  4013.         pointer_update(STACK_2,STACK_4,STACK_0);
  4014.         # count := (1- count) :
  4015.         decrement(STACK_1);
  4016.       }
  4017.     done:
  4018.     skipSTACK(4);
  4019.     value1 = popSTACK(); mv_count=1; # sequence als Wert
  4020.   }
  4021.  
  4022. LISPFUN(read_byte_sequence,2,0,norest,key,2, (kw(start),kw(end)) )
  4023. # (READ-BYTE-SEQUENCE sequence stream [:start] [:end]), cf. dpANS S. 21-26
  4024.   { # Stackaufbau: sequence, stream, start, end.
  4025.     # sequence überprüfen:
  4026.     pushSTACK(get_valid_seq_type(STACK_3));
  4027.     # Stackaufbau: sequence, stream, start, end, typdescr.
  4028.     # Stream überprüfen:
  4029.     if (!mstreamp(STACK_3)) { fehler_stream(STACK_3); }
  4030.     # Defaultwert für start ist 0:
  4031.     start_default_0(STACK_2);
  4032.     # Defaultwert für end ist die Länge der Sequence:
  4033.     end_default_len(STACK_1,STACK_4,STACK_0);
  4034.     # start- und end-Argumente überprüfen:
  4035.     test_start_end(&O(kwpair_start),&STACK_1);
  4036.     if (eq(seq_type(STACK_0),fixnum(8))) # Typname = (VECTOR (UNSIGNED-BYTE 8)) ?
  4037.       { var reg3 uintL start = posfixnum_to_L(STACK_2);
  4038.         var reg4 uintL end = posfixnum_to_L(STACK_1);
  4039.         var uintL index = 0;
  4040.         var reg5 object dv = array1_displace_check(STACK_4,end,&index);
  4041.         var reg2 uintB* byteptr = &TheSbvector(TheArray(dv)->data)->data[index];
  4042.         # Ab byteptr kommen end Bytes.
  4043.         # Versuche, eine optimierte Lese-Routine aufzurufen:
  4044.         var reg1 uintB* endptr = read_byte_array(STACK_3,&byteptr[start],end-start);
  4045.         if (!(endptr==NULL))
  4046.           { value1 = fixnum(endptr-byteptr); mv_count=1;
  4047.             skipSTACK(5);
  4048.             return;
  4049.       }   }
  4050.     # Durchlauf-Pointer bestimmen:
  4051.     pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  4052.     funcall(seq_init_start(STACK_(0+2)),2); # (SEQ-INIT-START sequence start)
  4053.     pushSTACK(value1); # =: pointer
  4054.     # Stackaufbau: sequence, stream, index, end, typdescr, pointer.
  4055.     until (eql(STACK_3,STACK_2)) # index = end (beides Integers) -> fertig
  4056.       { var reg1 object item = read_byte(STACK_4); # ein Element lesen
  4057.         if (eq(item,eof_value)) break; # EOF -> fertig
  4058.         pushSTACK(STACK_5); pushSTACK(STACK_(0+1)); pushSTACK(item);
  4059.         funcall(seq_access_set(STACK_(1+3)),3); # (SEQ-ACCESS-SET sequence pointer item)
  4060.         # pointer := (SEQ-UPD sequence pointer) :
  4061.         pointer_update(STACK_0,STACK_5,STACK_1);
  4062.         # index := (1+ index) :
  4063.         increment(STACK_3);
  4064.       }
  4065.     value1 = STACK_3; mv_count=1; # index als Wert
  4066.     skipSTACK(6);
  4067.   }
  4068.  
  4069. LISPFUN(write_byte_sequence,2,0,norest,key,2, (kw(start),kw(end)) )
  4070. # (WRITE-BYTE-SEQUENCE sequence stream [:start] [:end]), cf. dpANS S. 21-27
  4071.   { # Stackaufbau: sequence, stream, start, end.
  4072.     # sequence überprüfen:
  4073.     pushSTACK(get_valid_seq_type(STACK_3));
  4074.     # Stackaufbau: sequence, stream, start, end, typdescr.
  4075.     # Stream überprüfen:
  4076.     if (!mstreamp(STACK_3)) { fehler_stream(STACK_3); }
  4077.     # Defaultwert für start ist 0:
  4078.     start_default_0(STACK_2);
  4079.     # Defaultwert für end ist die Länge der Sequence:
  4080.     end_default_len(STACK_1,STACK_4,STACK_0);
  4081.     # start- und end-Argumente überprüfen:
  4082.     test_start_end(&O(kwpair_start),&STACK_1);
  4083.     if (eq(seq_type(STACK_0),fixnum(8))) # Typname = (VECTOR (UNSIGNED-BYTE 8)) ?
  4084.       { var reg3 uintL start = posfixnum_to_L(STACK_2);
  4085.         var reg4 uintL end = posfixnum_to_L(STACK_1);
  4086.         var uintL index = 0;
  4087.         var reg5 object dv = array1_displace_check(STACK_4,end,&index);
  4088.         var reg2 uintB* byteptr = &TheSbvector(TheArray(dv)->data)->data[index];
  4089.         # Ab byteptr kommen end Bytes.
  4090.         # Versuche, eine optimierte Schreib-Routine aufzurufen:
  4091.         var reg1 uintB* endptr = write_byte_array(STACK_3,&byteptr[start],end-start);
  4092.         if (!(endptr==NULL)) goto done;
  4093.       }
  4094.     # start- und end-Argumente subtrahieren:
  4095.     STACK_1 = I_I_minus_I(STACK_1,STACK_2); # (- end start), ein Integer >=0
  4096.     # Stackaufbau: sequence, item, start, count, typdescr.
  4097.     # Durchlauf-Pointer bestimmen:
  4098.     pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  4099.     funcall(seq_init_start(STACK_(0+2)),2); # (SEQ-INIT-START sequence start)
  4100.     STACK_2 = value1; # =: pointer
  4101.     # Stackaufbau: sequence, stream, pointer, count, typdescr.
  4102.     until (eq(STACK_1,Fixnum_0)) # count (ein Integer) = 0 -> fertig
  4103.       { pushSTACK(STACK_4); pushSTACK(STACK_(2+1));
  4104.         funcall(seq_access(STACK_(0+2)),2); # (SEQ-ACCESS sequence pointer)
  4105.         write_byte(STACK_3,value1); # ein Element ausgeben
  4106.         # pointer := (SEQ-UPD sequence pointer) :
  4107.         pointer_update(STACK_2,STACK_4,STACK_0);
  4108.         # count := (1- count) :
  4109.         decrement(STACK_1);
  4110.       }
  4111.     done:
  4112.     skipSTACK(4);
  4113.     value1 = popSTACK(); mv_count=1; # sequence als Wert
  4114.   }
  4115.  
  4116.