home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / list.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  69.2 KB  |  1,880 lines
  1. # Listenfunktionen von CLISP
  2. # Bruno Haible 23.5.1995
  3. # Marcus Daniels 8.4.1994
  4.  
  5. #include "lispbibl.c"
  6.  
  7. # UP: Kopiert eine Liste
  8. # copy_list(list)
  9. # > list: Liste
  10. # < ergebnis: Kopie der Liste
  11. # kann GC auslösen
  12.   global object copy_list (object list);
  13.   global object copy_list(old_list)
  14.     var reg3 object old_list;
  15.     { # Methode: (copy-list l) = (mapcar #'identity l), mapcar vorwärts
  16.       if (atomp(old_list))
  17.         return old_list;
  18.         else # Liste mit mindestens einem Element
  19.         { var reg1 object lauf;
  20.           pushSTACK(old_list);
  21.           #define old_list  STACK_0
  22.           { var reg2 object new_list = allocate_cons();
  23.             lauf = old_list; # lauf läuft durch die alte Liste durch
  24.             #undef old_list
  25.             Car(new_list) = Car(lauf);
  26.             STACK_0 = new_list;
  27.             pushSTACK(new_list);
  28.           }
  29.           # Schleife: STACK_1 ist die Gesamtkopie, STACK_0 = LAST davon,
  30.           # lauf = das entsprechende Cons der Original-Liste.
  31.           while ( lauf=Cdr(lauf), consp(lauf) )
  32.             { # es kommt noch ein Cons
  33.               pushSTACK(lauf); # lauf retten
  34.              {var reg1 object new_cons = allocate_cons(); # neues Cons allozieren
  35.               lauf = popSTACK(); # lauf zurück
  36.               Cdr(STACK_0) = new_cons; # und als CDR des LAST einhängen
  37.               Car(new_cons) = Car(lauf); # CAR kopieren
  38.               STACK_0 = new_cons; # das ist nun das neue LAST
  39.             }}
  40.           Cdr(popSTACK()) = lauf; # selben (CDR (LAST old_list)) beibehalten
  41.           return popSTACK();
  42.     }   }
  43.  
  44. # UP: Dreht eine Liste konstruktiv um.
  45. # reverse(list)
  46. # > list: Liste (x1 ... xm)
  47. # < ergebnis: umgedrehte Liste (xm ... x1)
  48. # kann GC auslösen
  49.   global object reverse (object list);
  50.   global object reverse(list)
  51.     var reg2 object list;
  52.     { pushSTACK(list); pushSTACK(NIL);
  53.       loop
  54.         { # Hier ist für r=0,1,...,m
  55.             # STACK_0 = (xr ... x1), STACK_1 = list = (xr+1 ... xm)
  56.           if atomp(list) break;
  57.           # Hier ist für r=1,...,m:
  58.             # STACK_0 = (xr-1 ... x1), list = (xr ... xm)
  59.           STACK_1 = Cdr(list);
  60.           # Hier ist für r=1,...,m:
  61.             # STACK_0 = (xr-1 ... x1), STACK_1 = (xr+1 ... xm)
  62.           pushSTACK(Car(list));
  63.          {var reg1 object new_cons = allocate_cons();
  64.           Car(new_cons) = popSTACK(); # = xr
  65.           Cdr(new_cons) = STACK_0; # = (xr-1 ... x1)
  66.           STACK_0 = new_cons; # = (xr ... x1)
  67.          }
  68.           list = STACK_1; # list := (xr+1 ... xm)
  69.         }
  70.       list = popSTACK(); skipSTACK(1); return(list);
  71.     }
  72. #if 0
  73. # andere Möglichkeit:
  74.   global object reverse(list)
  75.     var reg2 object list;
  76.     { pushSTACK(list); pushSTACK(NIL);
  77.       while (mconsp(STACK_1))
  78.         { var reg1 object new_cons = allocate_cons();
  79.           var reg1 object old_cons = STACK_1;
  80.           STACK_1 = Cdr(old_cons);
  81.           Car(new_cons) = Car(old_cons);
  82.           Cdr(new_cons) = STACK_0;
  83.           STACK_0 = new_cons;
  84.         }
  85.       list = popSTACK(); skipSTACK(1); return(list);
  86.     }
  87. #endif
  88.  
  89. # UP: Bestimmt die Länge einer Liste
  90. # llength(obj)
  91. # > obj: Objekt
  92. # < uintL ergebnis: Länge von obj, als Liste aufgefaßt
  93. # Testet nicht auf zyklische Listen.
  94.   global uintL llength (object obj);
  95.   global uintL llength(list)
  96.     var reg1 object list;
  97.     { var reg2 uintL count = 0;
  98.       while (consp(list)) { count++; list=Cdr(list); }
  99.       return count;
  100.     }
  101.  
  102. # UP: Bildet eine Liste mit genau len Elementen
  103. # make_list(len)
  104. # > (STACK): Initialisierungswert für die Elemente
  105. # > uintL len: gewünschte Listenlänge
  106. # < ergebnis: Liste mit D1.L Elementen
  107. # kann GC auslösen
  108.   global object make_list (uintL len);
  109.   global object make_list(len)
  110.     var reg2 uintL len;
  111.     { pushSTACK(NIL);
  112.       dotimesL(len,len,
  113.         { # STACK_0 = bisherige Liste, STACK_1 = Initialisierungswert
  114.           var reg1 object new_cons = allocate_cons();
  115.           Car(new_cons) = STACK_1; Cdr(new_cons) = STACK_0;
  116.           STACK_0 = new_cons;
  117.         });
  118.       return popSTACK();
  119.     }
  120.  
  121. # UP: Dreht eine Liste destruktiv um.
  122. # nreverse(list)
  123. # > list: Liste (x1 ... xm)
  124. # < ergebnis: Liste (xm ... x1), EQ zur alten
  125.   global object nreverse (object list);
  126.   global object nreverse(list)
  127.     var reg5 object list;
  128.     # Methode:
  129.     # (lambda (L)
  130.     #   (cond ((atom L) L)
  131.     #         ((atom (cdr L)) L)
  132.     #         ((atom (cddr L)) (rotatef (car L) (cadr L)) L)
  133.     #         (t (let ((L1 (cdr L)))
  134.     #              (do ((L3 L1 (cdr L3))
  135.     #                   (L2 nil (rplacd L3 L2)))
  136.     #                  ((atom (cdr L3))
  137.     #                   (setf (cdr L) L2)
  138.     #                   (setf (cdr L1) L3)
  139.     #                   (rotatef (car L) (car L3))
  140.     #              )   )
  141.     #              L
  142.     # ) )     )  )
  143.     { if (consp(list)) # (atom L) -> L
  144.         { var reg1 object list3 = Cdr(list); # L3 := (cdr L)
  145.           if (consp(list3)) # (atom (cdr L)) -> L
  146.             { if (mconsp(Cdr(list3)))
  147.                 { var reg4 object list1 = list3; # mit L1 = L3 = (cdr L)
  148.                   var reg2 object list2 = NIL; # und L2 = NIL anfangen
  149.                   do { var reg3 object h = Cdr(list3); # (cdr L3) retten,
  150.                        Cdr(list3) = list2; # durch L2 ersetzen,
  151.                        list2 = list3; # L2 := altes L3
  152.                        list3 = h; # L3 := altes (cdr L3)
  153.                      }
  154.                      while (mconsp(Cdr(list3))); # (atom (cdr L3)) -> beenden
  155.                   # L3 ist das letzte und L2 das vorletzte Listen-Cons.
  156.                   Cdr(list) = list2; # (setf (cdr L) L2)
  157.                   Cdr(list1) = list3; # (setf (cdr L1) L3)
  158.                 }
  159.               # vertausche (car list) und (car list3):
  160.               { var reg2 object h = Car(list);
  161.                 Car(list) = Car(list3);
  162.                 Car(list3) = h;
  163.         }   } }
  164.       return list;
  165.     }
  166.  
  167. # UP: A0 := (nreconc A0 A1)
  168. # nreconc(list,obj)
  169. # > list: Liste
  170. # > obj: Objekt
  171. # < ergebnis: (nreconc A0 A1)
  172.   global object nreconc (object list, object obj);
  173.   global object nreconc(list,obj)
  174.     var reg1 object list;
  175.     var reg2 object obj;
  176.     { until (atomp(list))
  177.         { var reg3 object h = Cdr(list); # (cdr L) ist nächstes L
  178.           Cdr(list) = obj; # (setq O (rplacd L O))
  179.           obj = list;
  180.           list = h;
  181.         }
  182.       return obj;
  183.     }
  184.  
  185. # UP: Bilde (delete obj (the list list) :test #'EQ)
  186. # deleteq(list,obj)
  187. # Entferne aus der Liste list alle Elemente, die EQ zu obj sind.
  188. # > obj: zu streichendes Element
  189. # > list: Liste
  190. # < ergebnis: modifizierte Liste
  191.   global object deleteq (object list, object obj);
  192.   global object deleteq(list,obj)
  193.     var reg1 object list;
  194.     var reg1 object obj;
  195.     { var reg1 object list1 = list;
  196.       var reg1 object list2 = list;
  197.       loop
  198.         { # Hier ist entweder list1=list2=list oder (cdr list1) = list2.
  199.           if (atomp(list2)) break;
  200.           if (eq(Car(list2),obj))
  201.             # Streiche (car list2):
  202.             if (eq(list2,list))
  203.               # noch am Listenanfang
  204.               { list2 = list1 = list = Cdr(list2); }
  205.               else
  206.               # weiter hinten in der Liste
  207.               { Cdr(list1) = list2 = Cdr(list2); }
  208.             else
  209.             # Nichts streichen, weiterrücken:
  210.             { list1 = list2; list2 = Cdr(list2); }
  211.         }
  212.       return list;
  213.     }
  214.  
  215. # UP: Liefert (car obj), mit Typprüfung
  216. # > subr_self: Aufrufer (ein SUBR)
  217.   local object car (object obj);
  218.   local object car(obj)
  219.     var reg1 object obj;
  220.     { if (consp(obj)) return Car(obj);
  221.       else if (nullp(obj)) return obj;
  222.            else fehler_list(obj);
  223.     }
  224.  
  225. # UP: Liefert (cdr obj), mit Typprüfung
  226. # > subr_self: Aufrufer (ein SUBR)
  227.   local object cdr (object obj);
  228.   local object cdr(obj)
  229.     var reg1 object obj;
  230.     { if (consp(obj)) return Cdr(obj);
  231.       else if (nullp(obj)) return obj;
  232.            else fehler_list(obj);
  233.     }
  234.  
  235. LISPFUNN(car,1) # (CAR list), CLTL S. 262
  236.   { value1 = car(popSTACK()); mv_count=1; }
  237.  
  238. LISPFUNN(cdr,1) # (CDR list), CLTL S. 262
  239.   { value1 = cdr(popSTACK()); mv_count=1; }
  240.  
  241. LISPFUNN(caar,1) # (CAAR list), CLTL S. 263
  242.   { value1 = car(car(popSTACK())); mv_count=1; }
  243.  
  244. LISPFUNN(cadr,1) # (CADR list), CLTL S. 263
  245.   { value1 = car(cdr(popSTACK())); mv_count=1; }
  246.  
  247. LISPFUNN(cdar,1) # (CDAR list), CLTL S. 263
  248.   { value1 = cdr(car(popSTACK())); mv_count=1; }
  249.  
  250. LISPFUNN(cddr,1) # (CDDR list), CLTL S. 263
  251.   { value1 = cdr(cdr(popSTACK())); mv_count=1; }
  252.  
  253. LISPFUNN(caaar,1) # (CAAAR list), CLTL S. 263
  254.   { value1 = car(car(car(popSTACK()))); mv_count=1; }
  255.  
  256. LISPFUNN(caadr,1) # (CAADR list), CLTL S. 263
  257.   { value1 = car(car(cdr(popSTACK()))); mv_count=1; }
  258.  
  259. LISPFUNN(cadar,1) # (CADAR list), CLTL S. 263
  260.   { value1 = car(cdr(car(popSTACK()))); mv_count=1; }
  261.  
  262. LISPFUNN(caddr,1) # (CADDR list), CLTL S. 263
  263.   { value1 = car(cdr(cdr(popSTACK()))); mv_count=1; }
  264.  
  265. LISPFUNN(cdaar,1) # (CDAAR list), CLTL S. 263
  266.   { value1 = cdr(car(car(popSTACK()))); mv_count=1; }
  267.  
  268. LISPFUNN(cdadr,1) # (CDADR list), CLTL S. 263
  269.   { value1 = cdr(car(cdr(popSTACK()))); mv_count=1; }
  270.  
  271. LISPFUNN(cddar,1) # (CDDAR list), CLTL S. 263
  272.   { value1 = cdr(cdr(car(popSTACK()))); mv_count=1; }
  273.  
  274. LISPFUNN(cdddr,1) # (CDDDR list), CLTL S. 263
  275.   { value1 = cdr(cdr(cdr(popSTACK()))); mv_count=1; }
  276.  
  277. LISPFUNN(caaaar,1) # (CAAAAR list), CLTL S. 263
  278.   { value1 = car(car(car(car(popSTACK())))); mv_count=1; }
  279.  
  280. LISPFUNN(caaadr,1) # (CAAADR list), CLTL S. 263
  281.   { value1 = car(car(car(cdr(popSTACK())))); mv_count=1; }
  282.  
  283. LISPFUNN(caadar,1) # (CAADAR list), CLTL S. 263
  284.   { value1 = car(car(cdr(car(popSTACK())))); mv_count=1; }
  285.  
  286. LISPFUNN(caaddr,1) # (CAADDR list), CLTL S. 263
  287.   { value1 = car(car(cdr(cdr(popSTACK())))); mv_count=1; }
  288.  
  289. LISPFUNN(cadaar,1) # (CADAAR list), CLTL S. 263
  290.   { value1 = car(cdr(car(car(popSTACK())))); mv_count=1; }
  291.  
  292. LISPFUNN(cadadr,1) # (CADADR list), CLTL S. 263
  293.   { value1 = car(cdr(car(cdr(popSTACK())))); mv_count=1; }
  294.  
  295. LISPFUNN(caddar,1) # (CADDAR list), CLTL S. 263
  296.   { value1 = car(cdr(cdr(car(popSTACK())))); mv_count=1; }
  297.  
  298. LISPFUNN(cadddr,1) # (CADDDR list), CLTL S. 263
  299.   { value1 = car(cdr(cdr(cdr(popSTACK())))); mv_count=1; }
  300.  
  301. LISPFUNN(cdaaar,1) # (CDAAAR list), CLTL S. 263
  302.   { value1 = cdr(car(car(car(popSTACK())))); mv_count=1; }
  303.  
  304. LISPFUNN(cdaadr,1) # (CDAADR list), CLTL S. 263
  305.   { value1 = cdr(car(car(cdr(popSTACK())))); mv_count=1; }
  306.  
  307. LISPFUNN(cdadar,1) # (CDADAR list), CLTL S. 263
  308.   { value1 = cdr(car(cdr(car(popSTACK())))); mv_count=1; }
  309.  
  310. LISPFUNN(cdaddr,1) # (CDADDR list), CLTL S. 263
  311.   { value1 = cdr(car(cdr(cdr(popSTACK())))); mv_count=1; }
  312.  
  313. LISPFUNN(cddaar,1) # (CDDAAR list), CLTL S. 263
  314.   { value1 = cdr(cdr(car(car(popSTACK())))); mv_count=1; }
  315.  
  316. LISPFUNN(cddadr,1) # (CDDADR list), CLTL S. 263
  317.   { value1 = cdr(cdr(car(cdr(popSTACK())))); mv_count=1; }
  318.  
  319. LISPFUNN(cdddar,1) # (CDDDAR list), CLTL S. 263
  320.   { value1 = cdr(cdr(cdr(car(popSTACK())))); mv_count=1; }
  321.  
  322. LISPFUNN(cddddr,1) # (CDDDDR list), CLTL S. 263
  323.   { value1 = cdr(cdr(cdr(cdr(popSTACK())))); mv_count=1; }
  324.  
  325. LISPFUNN(cons,2) # (CONS obj1 obj2), CLTL S. 264
  326.   { var reg1 object new_cons = allocate_cons();
  327.     Cdr(new_cons) = popSTACK();
  328.     Car(new_cons) = popSTACK();
  329.     value1 = new_cons; mv_count=1;
  330.   }
  331.  
  332. # Unterprogramm zum Ausführen des Tests :TEST
  333. # up2_test(stackptr,arg1,arg2)
  334. # > *(stackptr+1): die Testfunktion
  335. # > arg1,arg2: Argumente
  336. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  337. # kann GC auslösen
  338.   local boolean up2_test (object* stackptr, object arg1, object arg2);
  339.   local boolean up2_test(stackptr,arg1,arg2)
  340.     var object* stackptr;
  341.     var object arg1;
  342.     var object arg2;
  343.     { pushSTACK(arg1); pushSTACK(arg2); funcall(*(stackptr STACKop 1),2);
  344.       if (nullp(value1)) return FALSE; else return TRUE;
  345.     }
  346.  
  347. # Unterprogramm zum Ausführen des Tests :TEST-NOT
  348. # up2_test_not(stackptr,arg1,arg2)
  349. # > *(stackptr+0): die Testfunktion
  350. # > arg1,arg2: Argumente
  351. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  352. # kann GC auslösen
  353.   local boolean up2_test_not (object* stackptr, object arg1, object arg2);
  354.   local boolean up2_test_not(stackptr,arg1,arg2)
  355.     var object* stackptr;
  356.     var object arg1;
  357.     var object arg2;
  358.     { pushSTACK(arg1); pushSTACK(arg2); funcall(*(stackptr STACKop 0),2);
  359.       if (nullp(value1)) return TRUE; else return FALSE;
  360.     }
  361.  
  362. # UP: Überprüft die :TEST, :TEST-NOT - Argumente
  363. # test_test2_args(stackptr)
  364. # > stackptr: Pointer in den STACK
  365. # > *(stackptr+1): :TEST-Argument
  366. # > *(stackptr+0): :TEST-NOT-Argument
  367. # > subr_self: Aufrufer (ein SUBR)
  368. # < *(stackptr+1): verarbeitetes :TEST-Argument
  369. # < *(stackptr+0): verarbeitetes :TEST-NOT-Argument
  370. # < up2_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  371. #       > stackptr: derselbe Pointer in den Stack, arg1, arg2: Argumente
  372. #       < TRUE, falls der Test erfüllt ist, FALSE sonst.
  373.   # up2_function sei der Typ der Adresse einer solchen Testfunktion:
  374.   typedef boolean (*up2_function) (object* stackptr, object arg1, object arg2);
  375.   local up2_function test_test2_args (object* stackptr);
  376.   local up2_function test_test2_args(stackptr)
  377.     var reg1 object* stackptr;
  378.     { var reg1 object test_arg = *(stackptr STACKop 1);
  379.       if (eq(test_arg,unbound)) { test_arg=NIL; }
  380.       # test_arg ist das :TEST-Argument
  381.      {var reg1 object test_not_arg = *(stackptr STACKop 0);
  382.       if (eq(test_not_arg,unbound)) { test_not_arg=NIL; }
  383.       # test_not_arg ist das :TEST-NOT-Argument
  384.       if (nullp(test_not_arg))
  385.         # :TEST-NOT wurde nicht angegeben
  386.         { if (nullp(test_arg))
  387.             *(stackptr STACKop 1) = L(eql); # #'EQL als Default für :TEST
  388.           return(&up2_test);
  389.         }
  390.         # :TEST-NOT wurde angegeben
  391.         { if (nullp(test_arg))
  392.             return(&up2_test_not);
  393.           else
  394.             fehler_both_tests();
  395.     }}  }
  396.  
  397. # UP: Testet, ob zwei Bäume gleich sind.
  398. # tree_equal(stackptr,up2_fun,arg1,arg2)
  399. # > arg1,arg2: Bäume
  400. # > stackptr: Pointer in den Stack
  401. # > A5: Adresse einer Testfunktion, die arg1 und arg2 vergleicht und dabei auf
  402. #       die :TEST/:TEST-NOT-Argumente in *(stackptr+1).L bzw.
  403. #       *(stackprt+0).L zugreifen kann.
  404. # < ergebnis: TRUE, falls gleich, FALSE sonst
  405. # kann GC auslösen
  406.   local boolean tree_equal (object* stackptr, up2_function up2_fun, object arg1, object arg2);
  407.   local boolean tree_equal(stackptr,up2_fun,arg1,arg2)
  408.     var object* stackptr;
  409.     var up2_function up2_fun;
  410.     var reg1 object arg1;
  411.     var reg1 object arg2;
  412.     { start:
  413.       if (atomp(arg1))
  414.         if (atomp(arg2))
  415.           # arg1 und arg2 sind beide Atome
  416.           return(up2_fun(stackptr,arg1,arg2));
  417.           else
  418.           return FALSE;
  419.         else
  420.         if (atomp(arg2))
  421.           return FALSE;
  422.           else
  423.           # arg1 und arg2 sind beides Conses
  424.           { check_STACK(); check_SP();
  425.             pushSTACK(Cdr(arg1)); pushSTACK(Cdr(arg2));
  426.             if (tree_equal(stackptr,up2_fun,Car(arg1),Car(arg2))) # rekursiv die CARs vergleichen
  427.               # falls gleich, tail-end-rekursiv die CDRs vergleichen
  428.               { arg2=popSTACK(); arg1=popSTACK(); goto start; }
  429.               else
  430.               { skipSTACK(2); return FALSE; }
  431.     }     }
  432.  
  433. LISPFUN(tree_equal,2,0,norest,key,2, (kw(test),kw(test_not)) )
  434.   # (TREE-EQUAL x y :test :test-not), CLTL S. 264
  435.   { var reg1 object* stackptr = &STACK_0;
  436.     var reg2 up2_function up2_fun = test_test2_args(stackptr); # :TEST/:TEST-NOT-Argumente überprüfen
  437.     value1 = tree_equal(stackptr,up2_fun,STACK_3,STACK_2) ? T : NIL;
  438.     mv_count=1;
  439.     skipSTACK(4);
  440.   }
  441.  
  442. # UP: Testet auf Listenende
  443. # endp(obj)
  444. # > obj: Objekt
  445. # > subr_self: Aufrufer (ein SUBR)
  446. # < ergebnis: TRUE falls obj ein Listenende NIL ist,
  447. #             FALSE falls obj ein Cons ist.
  448.   local boolean endp (object obj);
  449.   local boolean endp(obj)
  450.     var reg1 object obj;
  451.     { if (consp(obj)) return FALSE;
  452.       else if (nullp(obj)) return TRUE;
  453.            else { pushSTACK(obj); pushSTACK(TheSubr(subr_self)->name);
  454.                   //: DEUTSCH "~: Eine echte Liste darf nicht mit ~ aufhören."
  455.                   //: ENGLISH "~: A true list must not end with ~"
  456.                   //: FRANCAIS "~ : Une vraie liste ne peut pas se terminer en ~."
  457.                   fehler(error, GETTEXT("~: A true list must not end with ~"));
  458.     }           }
  459.  
  460. LISPFUNN(endp,1) # (ENDP object), CLTL S. 264
  461.   { value1 = endp(popSTACK()) ? T : NIL;
  462.     mv_count=1;
  463.   }
  464.  
  465. LISPFUNN(list_length,1) # (LIST-LENGTH list), CLTL S. 265
  466.   # (defun list-length (list)  ; vgl. CLTL, S. 265
  467.   #   (do ((n 0 (+ n 2))
  468.   #        (fast list (cddr fast))
  469.   #        (slow list (cdr slow))
  470.   #       )
  471.   #       (nil)
  472.   #     (when (endp fast) (return n))
  473.   #     (when (endp (cdr fast)) (return (1+ n)))
  474.   #     (when (eq (cdr fast) slow) (return nil))
  475.   # ) )
  476.   { var reg1 object fast = popSTACK();
  477.     var reg2 object slow = fast;
  478.     var reg3 uintL n = 0;
  479.     loop
  480.       { if (endp(fast)) break;
  481.         fast = Cdr(fast); n++;
  482.         if (endp(fast)) break;
  483.         if (eq(fast,slow)) # (eq (cdr fast) slow)
  484.           { value1=NIL; mv_count=1; return; }
  485.         fast = Cdr(fast); n++;
  486.         slow = Cdr(slow);
  487.       }
  488.     value1 = fixnum(n); # n als Fixnum
  489.     mv_count=1;
  490.   }
  491.  
  492. # Fehlermeldung für NTH und NTHCDR
  493. # fehler_nth()
  494. # > STACK_0: fehlerhafter Index
  495. # > subr_self: Aufrufer (ein SUBR)
  496.   nonreturning_function(local, fehler_nth, (void));
  497.   local void fehler_nth()
  498.     { pushSTACK(STACK_0); # Wert für Slot DATUM von TYPE-ERROR
  499.       pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  500.       pushSTACK(STACK_(0+2));
  501.       pushSTACK(TheSubr(subr_self)->name);
  502.       //: DEUTSCH "~: ~ ist kein erlaubter Index, da kein Fixnum>=0."
  503.       //: ENGLISH "~: ~ is not a nonnegative fixnum and therefore not a valid index"
  504.       //: FRANCAIS "~ : ~, n'étant pas de type FIXNUM positif ou zéro, n'est pas un index valide."
  505.       fehler(type_error, GETTEXT("~: ~ is not a nonnegative fixnum and therefore not a valid index"));
  506.     }
  507.  
  508. LISPFUNN(nth,2) # (NTH integer list), CLTL S. 265
  509.   { var reg1 object list = popSTACK();
  510.     if (mposfixnump(STACK_0)) # integer muß ein Fixnum >=0 sein
  511.       { var reg2 uintL count = posfixnum_to_L(popSTACK()); # Wert des Fixnum
  512.         # count mal den CDR von list nehmen:
  513.         dotimesL(count,count, { list = cdr(list); } );
  514.         # 1 mal den CAR nehmen:
  515.         value1 = car(list); mv_count=1;
  516.       }
  517.       else
  518.       fehler_nth();
  519.   }
  520.  
  521. LISPFUNN(first,1) # (FIRST list), CLTL S. 266
  522.   { value1 = car(popSTACK()); mv_count=1; }
  523.  
  524. LISPFUNN(second,1) # (SECOND list), CLTL S. 266
  525.   { value1 = car(cdr(popSTACK())); mv_count=1; }
  526.  
  527. LISPFUNN(third,1) # (THIRD list), CLTL S. 266
  528.   { value1 = car(cdr(cdr(popSTACK()))); mv_count=1; }
  529.  
  530. LISPFUNN(fourth,1) # (FOURTH list), CLTL S. 266
  531.   { value1 = car(cdr(cdr(cdr(popSTACK())))); mv_count=1; }
  532.  
  533. LISPFUNN(fifth,1) # (FIFTH list), CLTL S. 266
  534.   { value1 = car(cdr(cdr(cdr(cdr(popSTACK()))))); mv_count=1; }
  535.  
  536. LISPFUNN(sixth,1) # (SIXTH list), CLTL S. 266
  537.   { value1 = car(cdr(cdr(cdr(cdr(cdr(popSTACK())))))); mv_count=1; }
  538.  
  539. LISPFUNN(seventh,1) # (SEVENTH list), CLTL S. 266
  540.   { value1 = car(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK()))))))); mv_count=1; }
  541.  
  542. LISPFUNN(eighth,1) # (EIGHTH list), CLTL S. 266
  543.   { value1 = car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK())))))))); mv_count=1; }
  544.  
  545. LISPFUNN(ninth,1) # (NINTH list), CLTL S. 266
  546.   { value1 = car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK()))))))))); mv_count=1; }
  547.  
  548. LISPFUNN(tenth,1) # (TENTH list), CLTL S. 266
  549.   { value1 = car(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(cdr(popSTACK())))))))))); mv_count=1; }
  550.  
  551. LISPFUNN(rest,1) # (REST list), CLTL S. 266
  552.   { value1 = cdr(popSTACK()); mv_count=1; }
  553.  
  554. LISPFUNN(nthcdr,2) # (NTHCDR integer list), CLTL S. 267
  555.   { var reg1 object list = popSTACK();
  556.     if (mposfixnump(STACK_0)) # integer muß ein Fixnum >=0 sein
  557.       { var reg2 uintL count = posfixnum_to_L(popSTACK()); # Wert des Fixnum
  558.         # count mal den CDR von list nehmen:
  559.         dotimesL(count,count, { list = cdr(list); } );
  560.         value1 = list; mv_count=1;
  561.       }
  562.       else
  563.       fehler_nth();
  564.   }
  565.  
  566. # Fehlermeldung für LAST, BUTLAST und NBUTLAST
  567. # fehler_butlast(badindex)
  568. # > badindex: fehlerhaftes 2. Argument
  569. # > subr_self: Aufrufer (ein SUBR)
  570.   nonreturning_function(local, fehler_butlast, (object badindex));
  571.   local void fehler_butlast(badindex)
  572.     var object badindex;
  573.     { pushSTACK(badindex); # Wert für Slot DATUM von TYPE-ERROR
  574.       pushSTACK(O(type_posinteger)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  575.       pushSTACK(badindex); pushSTACK(TheSubr(subr_self)->name);
  576.       //: DEUTSCH "~: ~ ist keine erlaubte Abschnittlänge, da kein Integer >=0."
  577.       //: ENGLISH "~: ~ is not a nonnegative integer and therefore not a valid argument"
  578.       //: FRANCAIS "~ : ~, n'etant pas un nombre entier positif ou zéro, ne désigne pas une bonne longueur."
  579.       fehler(type_error, GETTEXT("~: ~ is not a nonnegative integer and therefore not a valid argument"));
  580.     }
  581.  
  582. LISPFUN(last,1,1,norest,nokey,0,NIL) # (LAST list [n]), CLtL2 S. 416-417, dpANS p. 14-34
  583.   # (defun last (list &optional (n 1))
  584.   #   (check-type n (integer 0 *))
  585.   #   (do ((l list (cdr l))
  586.   #        (r list)
  587.   #        (i 0 (+ i 1)))
  588.   #       ((atom l) r)
  589.   #     (when (>= i n) (pop r))
  590.   # ) )
  591.   { var reg3 object intarg = popSTACK();
  592.     # optionales Integer-Argument überprüfen:
  593.     var reg2 uintL count; # Anzahl der zu kopierenden Elemente
  594.     if (eq(intarg,unbound))
  595.       { count = 1; }
  596.       else
  597.       { if (!(integerp(intarg) && positivep(intarg))) fehler_butlast(intarg);
  598.         count = (posfixnump(intarg) ? posfixnum_to_L(intarg) : ~(uintL)0);
  599.       }
  600.    {var reg2 object list = popSTACK();
  601.     # Optimierung der beiden häufigsten Fälle count=1 und count=0:
  602.     switch (count)
  603.       { case 0:
  604.           while (consp(list)) { list = Cdr(list); }
  605.           break;
  606.         case 1:
  607.           { var reg1 object list2;
  608.             if (consp(list))
  609.               { loop
  610.                   { # Hier ist list ein Cons.
  611.                     list2 = Cdr(list);
  612.                     if (atomp(list2)) break;
  613.                     list = list2;
  614.               }   }
  615.           }
  616.           break;
  617.         default:
  618.           { var reg1 object list2 = list;
  619.             dotimespL(count,count,
  620.               { if (atomp(list2)) goto done;
  621.                 list2 = Cdr(list2);
  622.               });
  623.             while (consp(list2)) { list2 = Cdr(list2); list = Cdr(list); }
  624.             done: ;
  625.           }
  626.           break;
  627.       }
  628.     value1 = list; mv_count=1;
  629.   }}
  630.  
  631. # UP: Bildet eine Liste mit gegebenen Elementen.
  632. # listof(len)
  633. # > uintC len: gewünschte Listenlänge
  634. # > auf STACK: len Objekte, erstes zuoberst
  635. # < ergebnis: Liste dieser Objekte
  636. # Erhöht STACK
  637. # verändert STACK, kann GC auslösen
  638.   global object listof (uintC len);
  639.   global object listof(len)
  640.     var reg2 uintC len;
  641.     { pushSTACK(NIL); # bisherige Gesamtliste
  642.       # die len Argumente vor diese Liste consen:
  643.       dotimesC(len,len,
  644.         { var reg1 object new_cons = allocate_cons();
  645.           Cdr(new_cons) = popSTACK();
  646.           Car(new_cons) = STACK_0;
  647.           STACK_0 = new_cons;
  648.         });
  649.       return popSTACK();
  650.     }
  651.  
  652. LISPFUN(list,0,0,rest,nokey,0,NIL)
  653.   # (LIST {object}), CLTL S. 267
  654.   { pushSTACK(NIL); # bisherige Gesamtliste
  655.     # die argcount Argumente vor diese Liste consen:
  656.     dotimesC(argcount,argcount,
  657.       { var reg1 object new_cons = allocate_cons();
  658.         Cdr(new_cons) = popSTACK(); # nächstes Argument davor
  659.         Car(new_cons) = STACK_0;
  660.         STACK_0 = new_cons;
  661.       });
  662.     value1 = popSTACK(); mv_count=1;
  663.   }
  664.  
  665. LISPFUN(liststern,1,0,rest,nokey,0,NIL)
  666.   # (LIST* obj1 {object}), CLTL S. 267
  667.   { # bisherige Gesamtliste bereits im Stack
  668.     # die argcount restlichen Argumente vor diese Liste consen:
  669.     dotimesC(argcount,argcount,
  670.       { var reg1 object new_cons = allocate_cons();
  671.         Cdr(new_cons) = popSTACK(); # nächstes Argument davor
  672.         Car(new_cons) = STACK_0;
  673.         STACK_0 = new_cons;
  674.       });
  675.     value1 = popSTACK(); mv_count=1;
  676.   }
  677.  
  678. LISPFUN(make_list,1,0,norest,key,1, (kw(initial_element)) )
  679.   # (MAKE-LIST size :initial-element), CLTL S. 268
  680.   { # :initial-element überprüfen:
  681.     if (eq(STACK_0,unbound))
  682.       STACK_0 = NIL; # Default-Initialisierung für initial-element
  683.     # :size überprüfen:
  684.     if (mposfixnump(STACK_1))
  685.       { value1 = make_list(posfixnum_to_L(STACK_1)); mv_count=1;
  686.         skipSTACK(2);
  687.       }
  688.       else
  689.       { # size in STACK_1
  690.         pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  691.         pushSTACK(O(type_posfixnum)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  692.         pushSTACK(STACK_(1+2)); # size
  693.         pushSTACK(TheSubr(subr_self)->name);
  694.         //: DEUTSCH "~: ~ ist als Listengröße nicht geeignet, da kein Fixnum >= 0"
  695.         //: ENGLISH "~: ~ is not a nonnegative fixnum and therefore not a valid list length"
  696.         //: FRANCAIS "~ : ~, n'étant pas de type FIXNUM positif ou zéro, n'est pas acceptable comme longueur de liste."
  697.         fehler(type_error, GETTEXT("~: ~ is not a nonnegative fixnum and therefore not a valid list length"));
  698.   }   }
  699.  
  700. LISPFUN(append,0,0,rest,nokey,0,NIL) # (APPEND {list}), CLTL S. 268
  701.   { if (argcount==0)
  702.       { value1=NIL; mv_count=1; } # keine Argumente -> NIL als Ergebnis
  703.       else
  704.       # Argumente aneinanderhängen. Dazu Schleife argcount-1 mal durchlaufen:
  705.       { dotimesC(argcount,argcount-1,
  706.           # STACK_0 = bisherige Gesamtliste von rechts.
  707.           # STACK_1 := (append STACK_1 STACK_0), STACK um 1 erhöhen:
  708.           { var reg3 object list1;
  709.            {var reg1 object list2 = popSTACK(); # bisherige Gesamtliste (von rechts)
  710.             list1 = STACK_0; # vorne anzuhängendes Argument
  711.             STACK_0 = list2; # bisherige Gesamtliste wieder stacken
  712.            }
  713.             # list1 muß Liste sein:
  714.             if (atomp(list1))
  715.               if (nullp(list1))
  716.                 ; # falls list1=NIL: (append nil x) = x, nichts tun
  717.                 else
  718.                 fehler_list(list1);
  719.               else
  720.               # (append list1 STACK_0), wobei list1 ein Cons ist:
  721.               # Kopiere list1 und halte das letzte Cons fest:
  722.               { var reg1 object lauf;
  723.                 pushSTACK(list1);
  724.                 { var reg2 object new_list = allocate_cons();
  725.                   lauf = STACK_0; # lauf läuft durch die alte Liste list1 durch
  726.                   Car(new_list) = Car(lauf);
  727.                   STACK_0 = new_list;
  728.                   pushSTACK(new_list);
  729.                 }
  730.                 # Schleife: STACK_1 ist die Gesamtkopie, STACK_0 = LAST davon,
  731.                 # lauf = das entsprechende Cons der Original-Liste list1.
  732.                 while ( lauf=Cdr(lauf), consp(lauf) )
  733.                   { # es kommt noch ein Cons
  734.                     pushSTACK(lauf); # lauf retten
  735.                    {var reg1 object new_cons = allocate_cons(); # neues Cons allozieren
  736.                     lauf = popSTACK(); # lauf zurück
  737.                     Cdr(STACK_0) = new_cons; # und als CDR des LAST einhängen
  738.                     Car(new_cons) = Car(lauf); # CAR kopieren
  739.                     STACK_0 = new_cons; # das ist nun das neue LAST
  740.                   }}
  741.                 # Kopie fertig. STACK_2 = bisherige Gesamtliste,
  742.                 # STACK_1 = Kopie von list1, STACK_0 = LAST davon.
  743.                 lauf = popSTACK(); # Ende der Kopie
  744.                 list1 = popSTACK(); # ganze Kopie
  745.                 Cdr(lauf) = STACK_0; # bisherige Gesamtkopie einhängen
  746.                 STACK_0 = list1; # und die Kopie ist die neue Gesamtliste
  747.               }
  748.           });
  749.         value1 = popSTACK(); mv_count=1; # Gesamtliste als Wert
  750.   }   }
  751.  
  752. LISPFUNN(copy_list,1) # (COPY-LIST list), CLTL S. 268
  753.   { var reg1 object list = popSTACK();
  754.     if (listp(list))
  755.       { value1 = copy_list(list); mv_count=1; }
  756.       else
  757.       { fehler_list(list); }
  758.   }
  759.  
  760. # UP: Kopiert eine Aliste
  761. # copy_alist(alist)
  762. # > alist: Aliste
  763. # < ergebnis: Kopie der Aliste
  764. # kann GC auslösen
  765.   local object copy_alist (object alist);
  766. # Methode:
  767. # Statt
  768. #   (mapcar #'(lambda (x) (if (consp x) (cons (car x) (cdr x)) x)) l)
  769. # wird die Liste erst kopiert mit copy-list, dann die Top-Level-Elemente
  770. # der Kopie, die Conses sind, durch neue Conses mit selbem CAR und CDR
  771. # ersetzt.
  772.   local object copy_alist(alist)
  773.     var reg3 object alist;
  774.     { alist = copy_list(alist);
  775.       pushSTACK(alist); # Gesamtliste retten
  776.       # alist läuft durch die Gesamtliste
  777.       until (atomp(alist))
  778.         { if (mconsp(Car(alist)))
  779.             { pushSTACK(alist); # alist retten
  780.              {var reg1 object new_cons = allocate_cons(); # neues Cons
  781.               alist = popSTACK(); # alist zurück
  782.               {var reg2 object old_cons = Car(alist);
  783.                Car(new_cons) = Car(old_cons); Cdr(new_cons) = Cdr(old_cons);
  784.               }
  785.               Car(alist) = new_cons;
  786.             }}
  787.           alist = Cdr(alist);
  788.         }
  789.       return popSTACK();
  790.     }
  791.  
  792. LISPFUNN(copy_alist,1) # (COPY-ALIST alist), CLTL S. 268
  793.   { value1 = copy_alist(popSTACK()); mv_count=1; }
  794.  
  795. # UP: Kopiert einen Baum.
  796.   local object copy_tree (object tree);
  797.   local object copy_tree(tree)
  798.     var reg2 object tree;
  799.     { if (atomp(tree))
  800.         return tree; # Atome unverändert zurückgeben
  801.         else
  802.         { check_STACK(); check_SP();
  803.           pushSTACK(Cdr(tree)); # CDR retten
  804.          {var reg1 object temp = copy_tree(Car(tree)); # den CAR rekursiv kopieren
  805.           tree = STACK_0;
  806.           STACK_0 = temp; # CAR-Kopie retten
  807.           temp = copy_tree(tree); # den CDR rekursiv kopieren
  808.           pushSTACK(temp); # CDR-Kopie retten
  809.          }
  810.          {var reg1 object new_cons = allocate_cons(); # neues Cons
  811.           Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK(); # füllen
  812.           return new_cons;
  813.     }   }}
  814.  
  815. LISPFUNN(copy_tree,1) # (COPY-TREE tree), CLTL S. 269
  816.   { value1 = copy_tree(popSTACK()); mv_count=1; }
  817.  
  818. LISPFUNN(revappend,2) # (REVAPPEND list object), CLTL S. 269
  819.   { until (matomp(STACK_1))
  820.       { var reg1 object new_cons = allocate_cons(); # neues Cons
  821.         Car(new_cons) = Car(STACK_1); Cdr(new_cons) = STACK_0; # (cons (car list) object)
  822.         STACK_0 = new_cons; # das ist das neue, verlängerte object
  823.         STACK_1 = Cdr(STACK_1); # list verkürzen
  824.       }
  825.     value1 = popSTACK(); mv_count=1;
  826.     skipSTACK(1);
  827.   }
  828.  
  829. LISPFUN(nconc,0,0,rest,nokey,0,NIL) # (NCONC {list}), CLTL S. 269
  830.   { if (argcount==0)
  831.       { value1=NIL; mv_count=1; } # keine Argumente -> NIL als Ergebnis
  832.       else
  833.       # Argumente aneinanderhängen. Dazu Schleife argcount-1 mal durchlaufen:
  834.       { dotimesC(argcount,argcount-1,
  835.           # STACK_0 = bisherige Gesamtliste von rechts.
  836.           # STACK_1 := (nconc STACK_1 STACK_0), STACK um 1 erhöhen:
  837.           { if (matomp(STACK_1))
  838.               if (nullp(STACK_1))
  839.                 { STACK_1 = STACK_0; skipSTACK(1); } # Gesamtliste bleibt, Argument vergessen
  840.                 else
  841.                 fehler_list(STACK_1);
  842.               else
  843.                 { # Gesamtliste in (cdr (last STACK_1)) einhängen:
  844.                   var reg2 object list1 = STACK_1;
  845.                   var reg1 object list2;
  846.                   loop
  847.                     { # Hier ist list1 ein Cons.
  848.                       list2 = Cdr(list1);
  849.                       if (atomp(list2)) break;
  850.                       list1 = list2;
  851.                     }
  852.                   # list1 ist das letzte Cons des Arguments STACK_1
  853.                   Cdr(list1) = popSTACK(); # bisherige Gesamtliste einhängen
  854.                   # STACK_0 = neue Gesamtliste
  855.                 }
  856.           });
  857.         value1 = popSTACK(); mv_count=1;
  858.   }   }
  859.  
  860. LISPFUNN(nreconc,2) # (NRECONC list1 list2), CLTL S. 269
  861.   { var reg2 object list2 = popSTACK();
  862.     var reg1 object list1 = popSTACK();
  863.     if (listp(list1))
  864.       { value1 = nreconc(list1,list2); mv_count=1; }
  865.       else
  866.       fehler_list(list1);
  867.   }
  868.  
  869. LISPFUNN(list_nreverse,1) # (SYS::LIST-NREVERSE list)
  870. # wie (NREVERSE list), wenn list eine Liste ist.
  871.   { value1 = nreverse(popSTACK()); mv_count=1; }
  872.  
  873. LISPFUN(butlast,1,1,norest,nokey,0,NIL)
  874.   # (BUTLAST list [integer]), CLTL S. 271
  875.   { var reg2 object intarg = popSTACK();
  876.     # optionales Integer-Argument überprüfen:
  877.     var reg2 uintL count; # Anzahl der zu entfernenden Elemente
  878.     if (eq(intarg,unbound))
  879.       { count = 1; }
  880.       else
  881.       { if (!(integerp(intarg) && positivep(intarg))) fehler_butlast(intarg);
  882.         count = (posfixnump(intarg) ? posfixnum_to_L(intarg) : ~(uintL)0);
  883.       }
  884.    {var reg2 uintL len = llength(STACK_0); # Anzahl der Elemente der Liste
  885.     if (len<=count)
  886.       { value1=NIL; mv_count=1; skipSTACK(1); } # Länge(list)<=count -> NIL als Wert
  887.       else
  888.       { var reg4 uintL new_len = len - count; # >0
  889.         # Liefere eine Kopie der ersten new_len Conses der Liste STACK_0:
  890.         var reg3 object new_list = make_list(new_len); # neue Liste allozieren
  891.         # Listenelemente einzeln kopieren, bis new_list voll ist:
  892.         var reg1 object new_lauf = new_list; # läuft durch die neue Liste
  893.         var reg2 object old_lauf = popSTACK(); # läuft durch die alte Liste
  894.         do { Car(new_lauf) = Car(old_lauf);
  895.              old_lauf = Cdr(old_lauf); new_lauf = Cdr(new_lauf);
  896.            }
  897.            until (atomp(new_lauf));
  898.         value1 = new_list; mv_count=1;
  899.   }}  }
  900.  
  901. LISPFUN(nbutlast,1,1,norest,nokey,0,NIL)
  902.   # (NBUTLAST list [integer]), CLTL S. 271
  903.   { var reg2 object intarg = popSTACK();
  904.     # optionales Integer-Argument überprüfen:
  905.     var reg2 uintL count; # Anzahl der zu entfernenden Elemente
  906.     if (eq(intarg,unbound))
  907.       { count = 1; }
  908.       else
  909.       { if (!(integerp(intarg) && positivep(intarg))) fehler_butlast(intarg);
  910.         count = (posfixnump(intarg) ? posfixnum_to_L(intarg) : ~(uintL)0);
  911.       }
  912.    {var reg2 uintL len = llength(STACK_0); # Anzahl der Elemente der Liste
  913.     if (len<=count)
  914.       { value1=NIL; mv_count=1; skipSTACK(1); } # Länge(list)<=count -> NIL als Wert
  915.       else
  916.       { var reg2 uintL new_len = len - count; # >0
  917.         var reg1 object lauf = STACK_0; # läuft durch die Liste
  918.         # new_len-1 mal den CDR nehmen und dann den CDR auf NIL setzen:
  919.         dotimesL(new_len,new_len-1, { lauf = Cdr(lauf); } );
  920.         Cdr(lauf) = NIL;
  921.         value1 = popSTACK(); mv_count=1; # Liste als Wert
  922.   }}  }
  923.  
  924. LISPFUNN(ldiff,2) # (LDIFF list sublist), CLTL S. 272
  925.   { var reg3 object sublist = popSTACK();
  926.     # Suche, wo sublist in list beginnt:
  927.     var reg2 uintL new_len = 0;
  928.    {var reg1 object listr = STACK_0;
  929.     until (endp(listr) || eq(listr,sublist)) { listr = Cdr(listr); new_len++; }
  930.    }
  931.     # Liefere eine Kopie der ersten new_len Conses der Liste STACK_0:
  932.    {var reg3 object new_list = make_list(new_len); # neue Liste allozieren
  933.     # Listenelemente einzeln kopieren, bis new_list voll ist:
  934.     var reg1 object new_lauf = new_list; # läuft durch die neue Liste
  935.     var reg2 object old_lauf = popSTACK(); # läuft durch die alte Liste
  936.     until (atomp(new_lauf))
  937.       { Car(new_lauf) = Car(old_lauf);
  938.         old_lauf = Cdr(old_lauf); new_lauf = Cdr(new_lauf);
  939.       }
  940.     value1 = new_list; mv_count=1;
  941.   }}
  942.  
  943. # Fehlermeldung für RPLACA und RPLACD u.ä.
  944. # fehler_cons(badobject)
  945. # > badobject: Nicht-Cons
  946. # > subr_self: Aufrufer (ein SUBR)
  947.   nonreturning_function(local, fehler_cons, (object badobject));
  948.   local void fehler_cons(badobject)
  949.     object badobject;
  950.     { pushSTACK(badobject); # Wert für Slot DATUM von TYPE-ERROR
  951.       pushSTACK(S(cons)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  952.       pushSTACK(badobject); pushSTACK(TheSubr(subr_self)->name);
  953.       //: DEUTSCH "~: ~ ist kein Paar."
  954.       //: ENGLISH "~: ~ is not a pair"
  955.       //: FRANCAIS "~ : ~ n'est pas une paire."
  956.       fehler(type_error, GETTEXT("~: ~ is not a pair"));
  957.     }
  958.  
  959. LISPFUNN(rplaca,2) # (RPLACA cons object), CLTL S. 272
  960.   { if (matomp(STACK_1))
  961.       fehler_cons(STACK_1);
  962.       else
  963.       { var reg2 object arg2 = popSTACK();
  964.         var reg1 object arg1 = popSTACK();
  965.         Car(arg1) = arg2;
  966.         value1 = arg1; mv_count=1;
  967.   }   }
  968.  
  969. LISPFUNN(prplaca,2) # (SYS::%RPLACA cons object)
  970.   # Wie (RPLACA cons object), hier jedoch object als Wert
  971.   { if (matomp(STACK_1))
  972.       fehler_cons(STACK_1);
  973.       else
  974.       { var reg2 object arg2 = popSTACK();
  975.         var reg1 object arg1 = popSTACK();
  976.         Car(arg1) = arg2;
  977.         value1 = arg2; mv_count=1;
  978.   }   }
  979.  
  980. LISPFUNN(rplacd,2) # (RPLACD cons object), CLTL S. 272
  981.   { if (matomp(STACK_1))
  982.       fehler_cons(STACK_1);
  983.       else
  984.       { var reg2 object arg2 = popSTACK();
  985.         var reg1 object arg1 = popSTACK();
  986.         Cdr(arg1) = arg2;
  987.         value1 = arg1; mv_count=1;
  988.   }   }
  989.  
  990. LISPFUNN(prplacd,2) # (SYS::%RPLACD cons object)
  991.   # Wie (RPLACD cons object), hier jedoch object als Wert
  992.   { if (matomp(STACK_1))
  993.       fehler_cons(STACK_1);
  994.       else
  995.       { var reg2 object arg2 = popSTACK();
  996.         var reg1 object arg1 = popSTACK();
  997.         Cdr(arg1) = arg2;
  998.         value1 = arg2; mv_count=1;
  999.   }   }
  1000.  
  1001. # Unterprogramm zum Ausführen des Tests :TEST
  1002. # up_test(stackptr,x)
  1003. # > *(stackptr+1): die Testfunktion
  1004. # > *(stackptr+3): das zu vergleichende Item
  1005. # > x: Argument
  1006. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1007. # kann GC auslösen
  1008.   local boolean up_test (object* stackptr, object x);
  1009.   local boolean up_test(stackptr,x)
  1010.     var object* stackptr;
  1011.     var object x;
  1012.     { # nach CLTL S. 247 ein (funcall testfun item x) ausführen:
  1013.       pushSTACK(*(stackptr STACKop 3)); # item
  1014.       pushSTACK(x); # x
  1015.       funcall(*(stackptr STACKop 1),2);
  1016.       if (nullp(value1)) return FALSE; else return TRUE;
  1017.     }
  1018.  
  1019. # Unterprogramm zum Ausführen des Tests :TEST-NOT
  1020. # up_test_not(stackptr,x)
  1021. # > *(stackptr+0): die Testfunktion
  1022. # > *(stackptr+3): das zu vergleichende Item
  1023. # > x: Argument
  1024. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1025. # kann GC auslösen
  1026.   local boolean up_test_not (object* stackptr, object x);
  1027.   local boolean up_test_not(stackptr,x)
  1028.     var object* stackptr;
  1029.     var object x;
  1030.     { # nach CLTL S. 247 ein (not (funcall testfun item x)) ausführen:
  1031.       pushSTACK(*(stackptr STACKop 3)); # item
  1032.       pushSTACK(x); # x
  1033.       funcall(*(stackptr STACKop 0),2);
  1034.       if (nullp(value1)) return TRUE; else return FALSE;
  1035.     }
  1036.  
  1037. # Unterprogramm zum Ausführen des Tests -IF
  1038. # up_if(stackptr,x)
  1039. # > *(stackptr+1): das Testprädikat
  1040. # > x: Argument
  1041. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1042. # kann GC auslösen
  1043.   local boolean up_if (object* stackptr, object x);
  1044.   local boolean up_if(stackptr,x)
  1045.     var object* stackptr;
  1046.     var object x;
  1047.     { # nach CLTL S. 247 ein (funcall predicate x) ausführen:
  1048.       pushSTACK(x); funcall(*(stackptr STACKop 1),1);
  1049.       if (nullp(value1)) return FALSE; else return TRUE;
  1050.     }
  1051.  
  1052. # Unterprogramm zum Ausführen des Tests -IF-NOT
  1053. # up_if_not(stackptr,x)
  1054. # > *(stackptr+1): das Testprädikat
  1055. # > x: Argument
  1056. # < ergebnis: TRUE falls der Test erfüllt ist, FALSE sonst
  1057. # kann GC auslösen
  1058.   local boolean up_if_not (object* stackptr, object x);
  1059.   local boolean up_if_not(stackptr,x)
  1060.     var object* stackptr;
  1061.     var object x;
  1062.     { # nach CLTL S. 247 ein (not (funcall predicate x)) ausführen:
  1063.       pushSTACK(x); funcall(*(stackptr STACKop 1),1);
  1064.       if (nullp(value1)) return TRUE; else return FALSE;
  1065.     }
  1066.  
  1067. # UP: Überprüft das :KEY-Argument
  1068. # test_key_arg()
  1069. # > STACK_0: optionales Argument
  1070. # < STACK_0: korrekte KEY-Funktion
  1071.   local void test_key_arg (void);
  1072.   local void test_key_arg()
  1073.     { var reg1 object key_arg = STACK_0;
  1074.       if (eq(key_arg,unbound) || nullp(key_arg))
  1075.         STACK_0 = L(identity); # #'IDENTITY als Default für :KEY
  1076.     }
  1077.  
  1078. # UP: Überprüft die :TEST, :TEST-NOT - Argumente
  1079. # test_test_args()
  1080. # > stackptr:=&STACK_1 : Pointer in den STACK
  1081. # > STACK_2: :TEST-Argument
  1082. # > STACK_1: :TEST-NOT-Argument
  1083. # > subr_self: Aufrufer (ein SUBR)
  1084. # < STACK_2: verarbeitetes :TEST-Argument
  1085. # < STACK_1: verarbeitetes :TEST-NOT-Argument
  1086. # < up_fun: Adresse einer Testfunktion, die wie folgt spezifiziert ist:
  1087. #       > stackptr: derselbe Pointer in den Stack, *(stackptr+3) = item,
  1088. #         *(stackptr+1) = :test-Argument, *(stackptr+0) = :test-not-Argument,
  1089. #       > x: Argument
  1090. #       < TRUE, falls der Test erfüllt ist, FALSE sonst.
  1091.   # up_function sei der Typ der Adresse einer solchen Testfunktion:
  1092.   typedef boolean (*up_function) (object* stackptr, object x);
  1093.   local up_function test_test_args (void);
  1094.   local up_function test_test_args()
  1095.     { var reg2 object test_arg = STACK_2;
  1096.       if (eq(test_arg,unbound)) { test_arg=NIL; }
  1097.       # test_arg ist das :TEST-Argument
  1098.      {var reg1 object test_not_arg = STACK_1;
  1099.       if (eq(test_not_arg,unbound)) { test_not_arg=NIL; }
  1100.       # test_not_arg ist das :TEST-NOT-Argument
  1101.       if (nullp(test_not_arg))
  1102.         # :TEST-NOT wurde nicht angegeben
  1103.         { if (nullp(test_arg))
  1104.             STACK_2 = L(eql); # #'EQL als Default für :TEST
  1105.           return(&up_test);
  1106.         }
  1107.         # :TEST-NOT wurde angegeben
  1108.         { if (nullp(test_arg))
  1109.             return(&up_test_not);
  1110.           else
  1111.             fehler_both_tests();
  1112.     }}  }
  1113.  
  1114. # UP: Ersetzt im Baum tree alle x, deren KEY der TESTFUNktion genügen,
  1115. # durch NEW. Konstruktiv.
  1116. # subst(tree,stackptr,up_fun)
  1117. # > tree: Baum
  1118. # > stackptr: *(stackptr-2) = NEW, *(stackptr-1) = KEY
  1119. # > up_fun: TESTFUN = Adresse der Testfunktion,
  1120. #       wird selbem stackptr und mit (KEY x) als Argument angesprungen.
  1121. #       Sie liefert TRUE, falls der Test erfüllt ist, FALSE sonst.
  1122. # < ergebnis: (evtl. neuer) Baum
  1123. # kann GC auslösen
  1124.   local object subst (object tree, object* stackptr, up_function up_fun);
  1125.   local object subst(tree,stackptr,up_fun)
  1126.     var reg3 object tree;
  1127.     var reg2 object* stackptr;
  1128.     var up_function up_fun;
  1129.     { # erst (KEY tree) berechnen und TESTFUN aufrufen:
  1130.       pushSTACK(tree); # tree retten
  1131.       pushSTACK(tree); funcall(*(stackptr STACKop -1),1); # (KEY tree)
  1132.       if (up_fun(stackptr,value1)) # TESTFUN aufrufen
  1133.         # Test erfüllt
  1134.         { skipSTACK(1); return *(stackptr STACKop -2); } # NEW als Wert
  1135.         else
  1136.         # Test nicht erfüllt
  1137.         if (matomp(STACK_0))
  1138.           # Argument Atom -> unverändert lassen
  1139.           { return popSTACK(); }
  1140.           else
  1141.           # Argument ist ein Cons -> SUBST rekursiv aufrufen:
  1142.           {  check_STACK(); check_SP();
  1143.            { # rekursiv für den CDR aufrufen:
  1144.              var reg4 object new_cdr = subst(Cdr(STACK_0),stackptr,up_fun);
  1145.              pushSTACK(new_cdr); # CDR-Ergebnis retten
  1146.             {# rekursiv für den CAR aufrufen:
  1147.              var reg3 object new_car = subst(Car(STACK_1),stackptr,up_fun);
  1148.              if (eq(new_car,Car(STACK_1)) && eq(STACK_0,Cdr(STACK_1)))
  1149.                # beides unverändert
  1150.                { skipSTACK(1); # CDR-Ergebnis vergessen
  1151.                  return popSTACK();
  1152.                }
  1153.                else
  1154.                { STACK_1 = new_car; # CAR-Ergebnis retten
  1155.                 {var reg1 object new_cons = allocate_cons(); # neue Cons-Zelle
  1156.                  Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
  1157.                  return new_cons;
  1158.     }     }}}  }}
  1159.  
  1160. LISPFUN(subst,3,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1161.   # (SUBST new old tree :test :test-not :key), CLTL S. 273
  1162.   { test_key_arg(); # :KEY-Argument in STACK_0
  1163.    {var reg2 up_function up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1164.     {var reg1 object new = STACK_5; pushSTACK(new); }
  1165.     # Stackaufbau: new, old, tree, test, test_not, key, new.
  1166.     value1 = subst(STACK_4,&STACK_2,up_fun); # Ersetzung durchführen
  1167.     mv_count=1;
  1168.     skipSTACK(7);
  1169.   }}
  1170.  
  1171. LISPFUN(subst_if,3,0,norest,key,1, (kw(key)) )
  1172.   # (SUBST-IF new pred tree :key), CLTL S. 273
  1173.   { test_key_arg(); # :KEY-Argument in STACK_0
  1174.     {var reg1 object new = STACK_3; pushSTACK(new); }
  1175.     # Stackaufbau: new, pred, tree, key, new.
  1176.     value1 = subst(STACK_2,&STACK_2,&up_if); # Ersetzung durchführen
  1177.     mv_count=1;
  1178.     skipSTACK(5);
  1179.   }
  1180.  
  1181. LISPFUN(subst_if_not,3,0,norest,key,1, (kw(key)) )
  1182.   # (SUBST-IF-NOT new pred tree :key), CLTL S. 273
  1183.   { test_key_arg(); # :KEY-Argument in STACK_0
  1184.     {var reg1 object new = STACK_3; pushSTACK(new); }
  1185.     # Stackaufbau: new, pred, tree, key, new.
  1186.     value1 = subst(STACK_2,&STACK_2,&up_if_not); # Ersetzung durchführen
  1187.     mv_count=1;
  1188.     skipSTACK(5);
  1189.   }
  1190.  
  1191. # UP: Ersetzt im Baum tree alle x, deren KEY der TESTFUNktion genügen,
  1192. # durch NEW. Destruktiv.
  1193. # nsubst(tree,stackptr,up_fun)
  1194. # > tree: Baum
  1195. # > stackptr: *(stackptr-2) = NEW, *(stackptr-1) = KEY
  1196. # > up_fun: TESTFUN = Adresse der Testfunktion,
  1197. #       wird selbem stackptr und mit (KEY x) als Argument angesprungen.
  1198. #       Sie liefert TRUE, falls der Test erfüllt ist, FALSE sonst.
  1199. # < ergebnis: Baum
  1200. # kann GC auslösen
  1201.   local object nsubst (object tree, object* stackptr, up_function up_fun);
  1202.   local object nsubst(tree,stackptr,up_fun)
  1203.     var reg3 object tree;
  1204.     var reg1 object* stackptr;
  1205.     var up_function up_fun;
  1206.     { # erst (KEY tree) berechnen und TESTFUN aufrufen:
  1207.       pushSTACK(tree); # tree retten
  1208.       pushSTACK(tree); funcall(*(stackptr STACKop -1),1); # (KEY tree)
  1209.       if (up_fun(stackptr,value1)) # TESTFUN aufrufen
  1210.         # Test erfüllt
  1211.         { skipSTACK(1); return *(stackptr STACKop -2); } # NEW als Wert
  1212.         else
  1213.         # Test nicht erfüllt
  1214.         { if (mconsp(STACK_0))
  1215.             # Argument ist ein Cons -> NSUBST rekursiv aufrufen:
  1216.             { check_STACK(); check_SP();
  1217.               # rekursiv für den CDR aufrufen:
  1218.               {var reg2 object modified_cdr = nsubst(Cdr(STACK_0),stackptr,up_fun);
  1219.                #ifdef IMMUTABLE_CONS
  1220.                if (!eq(Cdr(STACK_0),modified_cdr))
  1221.                #endif
  1222.                Cdr(STACK_0) = modified_cdr;
  1223.               }
  1224.               # rekursiv für den CAR aufrufen:
  1225.               {var reg2 object modified_car = nsubst(Car(STACK_0),stackptr,up_fun);
  1226.                #ifdef IMMUTABLE_CONS
  1227.                if (!eq(Car(STACK_0),modified_car))
  1228.                #endif
  1229.                Car(STACK_0) = modified_car;
  1230.             } }
  1231.           return popSTACK(); # ursprünglicher Baum zurück
  1232.     }   }
  1233.  
  1234. LISPFUN(nsubst,3,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1235.   # (NSUBST new old tree :test :test-not :key), CLTL S. 274
  1236.   { test_key_arg(); # :KEY-Argument in STACK_0
  1237.    {var reg2 up_function up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1238.     {var reg1 object new = STACK_5; pushSTACK(new); }
  1239.     # Stackaufbau: new, old, tree, test, test_not, key, new.
  1240.     value1 = nsubst(STACK_4,&STACK_2,up_fun); # Ersetzung durchführen
  1241.     mv_count=1;
  1242.     skipSTACK(7);
  1243.   }}
  1244.  
  1245. LISPFUN(nsubst_if,3,0,norest,key,1, (kw(key)) )
  1246.   # (NSUBST-IF new pred tree :key), CLTL S. 274
  1247.   { test_key_arg(); # :KEY-Argument in STACK_0
  1248.     {var reg1 object new = STACK_3; pushSTACK(new); }
  1249.     # Stackaufbau: new, pred, tree, key, new.
  1250.     value1 = nsubst(STACK_2,&STACK_2,&up_if); # Ersetzung durchführen
  1251.     mv_count=1;
  1252.     skipSTACK(5);
  1253.   }
  1254.  
  1255. LISPFUN(nsubst_if_not,3,0,norest,key,1, (kw(key)) )
  1256.   # (NSUBST-IF-NOT new pred tree :key), CLTL S. 274
  1257.   { test_key_arg(); # :KEY-Argument in STACK_0
  1258.     {var reg1 object new = STACK_3; pushSTACK(new); }
  1259.     # Stackaufbau: new, pred, tree, key, new.
  1260.     value1 = nsubst(STACK_2,&STACK_2,&up_if_not); # Ersetzung durchführen
  1261.     mv_count=1;
  1262.     skipSTACK(5);
  1263.   }
  1264.  
  1265. # UP: Liefert das erste Listenelement, dessen CAR der TESTFUNktion genügt.
  1266. # sublis_assoc(stackptr)
  1267. # > *(stackptr+3) = alist: Aliste
  1268. # > stackptr: *(stackptr-1) = KEY
  1269. # > *(stackptr-3) = TESTFUN = Testfunktion, wird für alle Listenelemente
  1270. #       (u . v) mit selbem stackptr und mit (KEY x) und u als Argumenten angesprungen.
  1271. #       Sie liefert TRUE, falls der Test erfüllt ist, FALSE sonst.
  1272. # < ergebnis: Listenelement (ein Cons) oder NIL
  1273. # kann GC auslösen
  1274.   local object sublis_assoc (object* stackptr);
  1275.   local object sublis_assoc(stackptr)
  1276.     var reg3 object* stackptr;
  1277.     { var reg2 object alist = *(stackptr STACKop 3);
  1278.       while (consp(alist))
  1279.         { if (mconsp(Car(alist))) # atomare Listenelemente überspringen
  1280.             { pushSTACK(alist); # Listenrest ((u . v) ...) retten
  1281.               # Testen, ob die zweiargumentige Testfunktion
  1282.               # *(stackptr-3) (eine Adresse!), angewandt auf u und das
  1283.               # vorher in *(stackptr-2) abgelegte Argument, erfüllt ist:
  1284.              {var reg1 boolean erg =
  1285.                 (*(up2_function)TheMachine(*(stackptr STACKop -3))) # zweiargumentige Testfunktion, wurde abgelegt
  1286.                   ( stackptr, *(stackptr STACKop -2), Car(Car(alist)) ); # auf (KEY x) und u anwenden
  1287.               alist = popSTACK();
  1288.               if (erg)
  1289.                 # Test erfüllt -> x = (u . v) = (CAR alist) als Ergebnis
  1290.                 return Car(alist);
  1291.               # Test nicht erfüllt
  1292.             }}
  1293.           alist = Cdr(alist); # Tail-End-Rekursion
  1294.         }
  1295.       # Listenende erreicht -> ergibt Ergebnis NIL
  1296.       return NIL;
  1297.     }
  1298.  
  1299. # UP: Ersetzt im Baum tree alle x durch ihr ALIST-Abbild (mittels ASSOC):
  1300. # x wird durch das erste v ersetzt, so daß (u . v) in ALIST vorkommt und
  1301. # (KEY x) und u der TESTFUNktion genügen. Konstruktiv.
  1302. # sublis(tree,stackptr)
  1303. # > tree: Baum
  1304. # > stackptr: *(stackptr-1) = KEY, *(stackptr+3) = ALIST,
  1305. #             *(stackptr-2) ist frei für (KEY x)
  1306. # < ergebnis: (evtl. neuer) Baum
  1307. # kann GC auslösen
  1308.   local object sublis (object tree, object* stackptr);
  1309.   local object sublis(tree,stackptr)
  1310.     var reg3 object tree;
  1311.     var reg1 object* stackptr;
  1312.     { # erst (KEY tree) berechnen und ASSOC aufrufen:
  1313.       pushSTACK(tree); # tree retten
  1314.       pushSTACK(tree); funcall(*(stackptr STACKop -1),1); # (KEY tree)
  1315.       *(stackptr STACKop -2) = value1; # retten für sublis_assoc
  1316.      {var reg2 object assoc_erg = sublis_assoc(stackptr);
  1317.       if (consp(assoc_erg))
  1318.         # Test erfüllt
  1319.         { skipSTACK(1); return Cdr(assoc_erg); } # (CDR (ASSOC ...)) als Wert
  1320.         else
  1321.         # Test nicht erfüllt
  1322.         if (matomp(STACK_0))
  1323.           # Argument Atom -> unverändert lassen
  1324.           { return popSTACK(); }
  1325.           else
  1326.           # Argument ist ein Cons -> SUBLIS rekursiv aufrufen:
  1327.           {  check_STACK(); check_SP();
  1328.            { # rekursiv für den CDR aufrufen:
  1329.              var reg4 object new_cdr = sublis(Cdr(STACK_0),stackptr);
  1330.              pushSTACK(new_cdr); # CDR-Ergebnis retten
  1331.             {# rekursiv für den CAR aufrufen:
  1332.              var reg3 object new_car = sublis(Car(STACK_1),stackptr);
  1333.              if (eq(new_car,Car(STACK_1)) && eq(STACK_0,Cdr(STACK_1)))
  1334.                # beides unverändert
  1335.                { skipSTACK(1); # CDR-Ergebnis vergessen
  1336.                  return popSTACK();
  1337.                }
  1338.                else
  1339.                { STACK_1 = new_car; # CAR-Ergebnis retten
  1340.                 {var reg1 object new_cons = allocate_cons(); # neue Cons-Zelle
  1341.                  Cdr(new_cons) = popSTACK(); Car(new_cons) = popSTACK();
  1342.                  return new_cons;
  1343.     }}    }}}  }}
  1344.  
  1345. LISPFUN(sublis,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1346.   # (SUBLIS alist tree :test :test-not :key), CLTL S. 274
  1347.   { test_key_arg(); # :KEY-Argument in STACK_0
  1348.    {var reg1 object* stackptr = &STACK_1;
  1349.     var reg2 up2_function up2_fun = test_test2_args(stackptr); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1350.     # up2_fun = Testfunktion, wird mit stackptr und (KEY x) und u als
  1351.     # Argumenten angesprungen. Sie liefert TRUE, falls der Test erfüllt ist.
  1352.     if (nullp(STACK_4)) # shortcut: nothing to do if alist = ()
  1353.       { value1 = STACK_3; mv_count=1;
  1354.         skipSTACK(5);
  1355.       }
  1356.       else
  1357.       { pushSTACK(NIL); # Dummy
  1358.         pushSTACK(type_pointer_object(machine_type,up2_fun)); # Testfunktion, wegen Typinfo=machine_type GC-sicher!
  1359.         # Stackaufbau: alist, tree, test, test_not, key, dummy, up2_fun.
  1360.         value1 = sublis(STACK_5,stackptr); # Ersetzung durchführen
  1361.         mv_count=1;
  1362.         skipSTACK(7);
  1363.   }}  }
  1364.  
  1365. # UP: Ersetzt im Baum tree alle x durch ihr ALIST-Abbild (mittels ASSOC):
  1366. # x wird durch das erste v ersetzt, so daß (u . v) in ALIST vorkommt und
  1367. # (KEY x) und u der TESTFUNktion genügen. Destruktiv.
  1368. # nsublis(tree,stackptr)
  1369. # > tree: Baum
  1370. # > stackptr: *(stackptr-1) = KEY, *(stackptr+3) = ALIST,
  1371. #             *(stackptr-2) ist frei für (KEY x)
  1372. # < ergebnis: Baum
  1373. # kann GC auslösen
  1374.   local object nsublis (object tree, object* stackptr);
  1375.   local object nsublis(tree,stackptr)
  1376.     var reg3 object tree;
  1377.     var reg1 object* stackptr;
  1378.     { # erst (KEY tree) berechnen und ASSOC aufrufen:
  1379.       pushSTACK(tree); # tree retten
  1380.       pushSTACK(tree); funcall(*(stackptr STACKop -1),1); # (KEY tree)
  1381.       *(stackptr STACKop -2) = value1; # retten für sublis_assoc
  1382.      {var reg2 object assoc_erg = sublis_assoc(stackptr);
  1383.       if (consp(assoc_erg))
  1384.         # Test erfüllt
  1385.         { skipSTACK(1); return Cdr(assoc_erg); } # (CDR (ASSOC ...)) als Wert
  1386.         else
  1387.         # Test nicht erfüllt
  1388.         { if (mconsp(STACK_0))
  1389.             # Argument ist ein Cons -> NSUBLIS rekursiv aufrufen:
  1390.             { check_STACK(); check_SP();
  1391.               # rekursiv für den CDR aufrufen:
  1392.               {var reg2 object modified_cdr = nsublis(Cdr(STACK_0),stackptr);
  1393.                #ifdef IMMUTABLE_CONS
  1394.                if (!eq(Cdr(STACK_0),modified_cdr))
  1395.                #endif
  1396.                Cdr(STACK_0) = modified_cdr;
  1397.               }
  1398.               # rekursiv für den CAR aufrufen:
  1399.               {var reg2 object modified_car = nsublis(Car(STACK_0),stackptr);
  1400.                #ifdef IMMUTABLE_CONS
  1401.                if (!eq(Car(STACK_0),modified_car))
  1402.                #endif
  1403.                Car(STACK_0) = modified_car;
  1404.             } }
  1405.           return popSTACK(); # ursprünglicher Baum zurück
  1406.     }}  }
  1407.  
  1408. LISPFUN(nsublis,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1409.   # (NSUBLIS alist tree :test :test-not :key), CLTL S. 275
  1410.   { test_key_arg(); # :KEY-Argument in STACK_0
  1411.    {var reg1 object* stackptr = &STACK_1;
  1412.     var reg2 up2_function up2_fun = test_test2_args(stackptr); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1413.     # up2_fun = Testfunktion, wird mit stackptr und (KEY x) und u als
  1414.     # Argumenten angesprungen. Sie liefert TRUE, falls der Test erfüllt ist.
  1415.     if (nullp(STACK_4)) # shortcut: nothing to do if alist = ()
  1416.       { value1 = STACK_3; mv_count=1;
  1417.         skipSTACK(5);
  1418.       }
  1419.       else
  1420.       { pushSTACK(NIL); # Dummy
  1421.         pushSTACK(type_pointer_object(machine_type,up2_fun)); # Testfunktion, wegen Typinfo=machine_type GC-sicher!
  1422.         # Stackaufbau: alist, tree, test, test_not, key, dummy, up2_fun.
  1423.         value1 = nsublis(STACK_5,stackptr); # Ersetzung durchführen
  1424.         mv_count=1;
  1425.         skipSTACK(7);
  1426.   }}  }
  1427.  
  1428. # UP: Liefert den Listenrest ab dem Listenelement, das der TESTFUNktion
  1429. # genügt.
  1430. # member(list,stackptr,up_fun)
  1431. # > list: Liste
  1432. # > STACK_0: Aufrufer (ein SUBR)
  1433. # > stackptr: *(stackptr-1) = KEY
  1434. # > up_fun: TESTFUN = Adresse der Testfunktion,
  1435. #       wird selbem stackptr und mit (KEY x) als Argument angesprungen.
  1436. #       Sie liefert TRUE, falls der Test erfüllt ist, FALSE sonst.
  1437. # < ergebnis: Listenrest
  1438. # kann GC auslösen
  1439.   local object member (object list, object* stackptr, up_function up_fun);
  1440.   local object member(list,stackptr,up_fun)
  1441.     var reg1 object list;
  1442.     var reg2 object* stackptr;
  1443.     var reg4 up_function up_fun;
  1444.     { until ((
  1445.               subr_self = STACK_0, # Aufrufer (für Fehlermeldung bei ENDP)
  1446.               endp(list) # Listenende erreicht?
  1447.             ))
  1448.         { pushSTACK(list); # Listenrest retten
  1449.           pushSTACK(Car(list)); funcall(*(stackptr STACKop -1),1); # (KEY x)
  1450.          {var reg3 boolean erg = up_fun(stackptr,value1); # TESTFUN aufrufen
  1451.           list = popSTACK();
  1452.           if (erg) { return list; } # Test erfüllt -> list als Ergebnis
  1453.          }
  1454.           # Test nicht erfüllt -> (member ... (cdr list)) aufrufen:
  1455.           list = Cdr(list); # tail-end-rekursiv
  1456.         }
  1457.       return list; # NIL als Ergebnis
  1458.     }
  1459.  
  1460. LISPFUN(member,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1461.   # (MEMBER item list :test :test-not :key), CLTL S. 275
  1462.   { test_key_arg(); # :KEY-Argument in STACK_0
  1463.    {var reg2 up_function up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1464.     pushSTACK(L(member)); # Aufrufer
  1465.     value1 = member(STACK_4,&STACK_2,up_fun); # Suche durchführen
  1466.     mv_count=1;
  1467.     skipSTACK(6);
  1468.   }}
  1469.  
  1470. LISPFUN(member_if,2,0,norest,key,1, (kw(key)) )
  1471.   # (MEMBER-IF pred list :key), CLTL S. 275
  1472.   { test_key_arg(); # :KEY-Argument in STACK_0
  1473.     pushSTACK(L(member_if)); # Aufrufer
  1474.     value1 = member(STACK_2,&STACK_2,&up_if); # Suche durchführen
  1475.     mv_count=1;
  1476.     skipSTACK(4);
  1477.   }
  1478.  
  1479. LISPFUN(member_if_not,2,0,norest,key,1, (kw(key)) )
  1480.   # (MEMBER-IF-NOT pred list :key), CLTL S. 275
  1481.   { test_key_arg(); # :KEY-Argument in STACK_0
  1482.     pushSTACK(L(member_if_not)); # Aufrufer
  1483.     value1 = member(STACK_2,&STACK_2,&up_if_not); # Suche durchführen
  1484.     mv_count=1;
  1485.     skipSTACK(4);
  1486.   }
  1487.  
  1488. LISPFUNN(tailp,2) # (TAILP sublist list), CLTL S. 275
  1489.   #ifndef X3J13_175
  1490.   # (defun tailp (sublist list)
  1491.   #   (do ((l list (rest l)))
  1492.   #       ((endp l) (null sublist))
  1493.   #     (when (eq l sublist) (return t))
  1494.   # ) )
  1495.   #else
  1496.   # (defun tailp (sublist list)
  1497.   #   (loop
  1498.   #     (when (eq sublist list) (return t))
  1499.   #     (when (atom list) (return nil))
  1500.   #     (setq list (cdr list))
  1501.   # ) )
  1502.   #endif
  1503.   { var reg1 object list = popSTACK();
  1504.     var reg2 object sublist = popSTACK();
  1505.     #ifndef X3J13_175
  1506.     loop
  1507.       { if (endp(list)) goto end;
  1508.         if (eq(list,sublist)) goto yes;
  1509.         list = Cdr(list);
  1510.       }
  1511.     end:
  1512.       if (nullp(sublist)) goto yes;
  1513.     #else
  1514.     loop
  1515.       { if (eq(list,sublist)) goto yes;
  1516.         if (atomp(list)) break;
  1517.         list = Cdr(list);
  1518.       }
  1519.     #endif
  1520.       value1 = NIL; mv_count=1; return; # NIL als Wert
  1521.     yes:
  1522.       value1 = T; mv_count=1; return; # T als Wert
  1523.   }
  1524.  
  1525. LISPFUN(adjoin,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1526.   # (ADJOIN item list :test :test-not :key), CLTL S. 276
  1527.   { # erst Test auf (MEMBER (key item) list :test :test-not :key):
  1528.     test_key_arg(); # :KEY-Argument in STACK_0
  1529.    {var reg2 up_function up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1530.     {var reg1 object item = STACK_4;
  1531.      pushSTACK(item); # item retten
  1532.      pushSTACK(item); funcall(STACK_2,1); STACK_5 = value1; # item := (funcall key item)
  1533.     }
  1534.     pushSTACK(L(adjoin)); # Aufrufer
  1535.     # Stackaufbau: (key item), list, test, test-not, key, item, #'adjoin.
  1536.     if (nullp(member(STACK_5,&STACK_3,up_fun))) # Suche durchführen
  1537.       # item noch nicht in list gefunden: muß consen
  1538.       { var reg1 object new_cons = allocate_cons();
  1539.         Cdr(new_cons) = STACK_5; # = list
  1540.         Car(new_cons) = STACK_1; # = item
  1541.         value1 = new_cons;
  1542.       }
  1543.       else
  1544.       { value1 = STACK_5; } # list als Wert
  1545.     mv_count=1; skipSTACK(7); return;
  1546.   }}
  1547.  
  1548. LISPFUNN(acons,3)
  1549.   # (ACONS key val alist) = (CONS (CONS key val) alist), CLTL S. 279
  1550.   {{var reg1 object new_cons = allocate_cons();
  1551.     Car(new_cons) = STACK_2; # key
  1552.     Cdr(new_cons) = STACK_1; # value
  1553.     STACK_1 = new_cons;
  1554.    }
  1555.    {var reg1 object new_cons = allocate_cons();
  1556.     Cdr(new_cons) = popSTACK(); # alist
  1557.     Car(new_cons) = popSTACK(); # (key . val)
  1558.     value1 = new_cons; mv_count=1;
  1559.     skipSTACK(1);
  1560.   }}
  1561.  
  1562. LISPFUN(pairlis,2,1,norest,nokey,0,NIL)
  1563.   # (PAIRLIS keys data [alist]), CLTL S. 280
  1564.   { if (eq(STACK_0,unbound)) { STACK_0=NIL; } # NIL als Default für alist
  1565.    {var reg1 object keys_list = STACK_2;
  1566.     var reg2 object data_list = STACK_1;
  1567.     pushSTACK(keys_list);
  1568.     pushSTACK(data_list);
  1569.    }
  1570.     loop # Stackaufbau: keys, data, alist, keysr, datar.
  1571.       { if (matomp(STACK_0)) # data-Liste zu Ende?
  1572.           # ja
  1573.           if (matomp(STACK_1)) # keys-Liste auch zu Ende?
  1574.             goto end;
  1575.             else
  1576.             goto fehler_lengths;
  1577.           # nein
  1578.           else
  1579.           if (matomp(STACK_1)) # aber keys-Liste zu Ende?
  1580.             goto fehler_lengths;
  1581.             else
  1582.             { var reg1 object new_cons = allocate_cons();
  1583.               Car(new_cons) = Car(STACK_1); # nächstes key als CAR
  1584.               Cdr(new_cons) = Car(STACK_0); # nächstes data als CDR
  1585.               STACK_1 = Cdr(STACK_1); # keys verkürzen
  1586.               STACK_0 = Cdr(STACK_0); # data verkürzen
  1587.               pushSTACK(new_cons);
  1588.               new_cons = allocate_cons(); # weiteres neues Cons
  1589.               Car(new_cons) = popSTACK(); # mit (key . data) als CAR
  1590.               Cdr(new_cons) = STACK_2; # und alist als CDR
  1591.               STACK_2 = new_cons; # ergibt neues alist
  1592.       }     }
  1593.     fehler_lengths:
  1594.       skipSTACK(3);
  1595.       { var reg2 object data_list = popSTACK();
  1596.         var reg1 object keys_list = popSTACK();
  1597.         pushSTACK(data_list); pushSTACK(keys_list); pushSTACK(TheSubr(subr_self)->name);
  1598.         //: DEUTSCH "~: Listen ~ und ~ sind verschieden lang."
  1599.         //: ENGLISH "~: lists ~ and ~ are not of same length"
  1600.         //: FRANCAIS "~ : Les listes ~ et ~ sont de longueurs distinctes."
  1601.         fehler(error, GETTEXT("~: lists ~ and ~ are not of same length"));
  1602.       }
  1603.     end: value1 = STACK_2; mv_count=1; skipSTACK(5); # alist als Wert
  1604.   }
  1605.  
  1606. # UP: Liefert das erste Listenelement, dessen CAR der TESTFUNktion genügt.
  1607. # assoc(alist,stackptr)
  1608. # > alist: Aliste
  1609. # > stackptr: *(stackptr-1) = KEY
  1610. # > up_fun: TESTFUN = Adresse der Testfunktion, wird für alle Listenelemente
  1611. #       (u . v) mit selbem stackptr und mit (KEY u) als Argument angesprungen.
  1612. #       Sie liefert TRUE, falls der Test erfüllt ist, FALSE sonst.
  1613. # < ergebnis: Listenelement (ein Cons) oder NIL
  1614. # kann GC auslösen
  1615.   local object assoc (object alist, object* stackptr, up_function up_fun);
  1616.   local object assoc(alist,stackptr,up_fun)
  1617.     var reg2 object alist;
  1618.     var reg3 object* stackptr;
  1619.     var reg4 up_function up_fun;
  1620.     { start:
  1621.       if (atomp(alist))
  1622.         # Listenende erreicht -> ergibt Ergebnis NIL
  1623.         return NIL;
  1624.         else
  1625.         { if (mconsp(Car(alist))) # atomare Listenelemente überspringen
  1626.             { pushSTACK(alist); # Listenrest ((u . v) ...) retten
  1627.               pushSTACK(Car(Car(alist))); funcall(*(stackptr STACKop -1),1); # (KEY u)
  1628.              {var reg1 boolean erg = up_fun(stackptr,value1); # TESTFUN aufrufen
  1629.               alist = popSTACK();
  1630.               if (erg)
  1631.                 # Test erfüllt -> x = (u . v) = (CAR alist) als Ergebnis
  1632.                 return Car(alist);
  1633.               # Test nicht erfüllt
  1634.             }}
  1635.           # tail-end-rekursiv (assoc ... (cdr alist)) aufrufen:
  1636.           alist = Cdr(alist); goto start;
  1637.     }   }
  1638.  
  1639. LISPFUN(assoc,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1640.   # (ASSOC item alist :test :test-not :key), CLTL S. 280
  1641.   { test_key_arg(); # :KEY-Argument in STACK_0
  1642.    {var reg2 up_function up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1643.     value1 = assoc(STACK_3,&STACK_1,up_fun); # Suche durchführen
  1644.     mv_count=1;
  1645.     skipSTACK(5);
  1646.   }}
  1647.  
  1648. LISPFUN(assoc_if,2,0,norest,key,1, (kw(key)) )
  1649.   # (ASSOC-IF pred alist :key), CLTL S. 280
  1650.   { test_key_arg(); # :KEY-Argument in STACK_0
  1651.     value1 = assoc(STACK_1,&STACK_1,&up_if); # Suche durchführen
  1652.     mv_count=1;
  1653.     skipSTACK(3);
  1654.   }
  1655.  
  1656. LISPFUN(assoc_if_not,2,0,norest,key,1, (kw(key)) )
  1657.   # (ASSOC-IF-NOT pred alist :key), CLTL S. 280
  1658.   { test_key_arg(); # :KEY-Argument in STACK_0
  1659.     value1 = assoc(STACK_1,&STACK_1,&up_if_not); # Suche durchführen
  1660.     mv_count=1;
  1661.     skipSTACK(3);
  1662.   }
  1663.  
  1664. # UP: Liefert das erste Listenelement, dessen CDR der TESTFUNktion genügt.
  1665. # rassoc(alist,stackptr)
  1666. # > alist: Aliste
  1667. # > stackptr: *(stackptr-1) = KEY
  1668. # > up_fun: TESTFUN = Adresse der Testfunktion, wird für alle Listenelemente
  1669. #       (u . v) mit selbem stackptr und mit (KEY v) als Argument angesprungen.
  1670. #       Sie liefert TRUE, falls der Test erfüllt ist, FALSE sonst.
  1671. # < ergebnis: Listenelement (ein Cons) oder NIL
  1672. # kann GC auslösen
  1673.   local object rassoc (object alist, object* stackptr, up_function up_fun);
  1674.   local object rassoc(alist,stackptr,up_fun)
  1675.     var reg2 object alist;
  1676.     var reg3 object* stackptr;
  1677.     var reg4 up_function up_fun;
  1678.     { start:
  1679.       if (atomp(alist))
  1680.         # Listenende erreicht -> ergibt Ergebnis NIL
  1681.         return NIL;
  1682.         else
  1683.         { if (mconsp(Car(alist))) # atomare Listenelemente überspringen
  1684.             { pushSTACK(alist); # Listenrest ((u . v) ...) retten
  1685.               pushSTACK(Cdr(Car(alist))); funcall(*(stackptr STACKop -1),1); # (KEY v)
  1686.              {var reg1 boolean erg = up_fun(stackptr,value1); # TESTFUN aufrufen
  1687.               alist = popSTACK();
  1688.               if (erg)
  1689.                 # Test erfüllt -> x = (u . v) = (CAR alist) als Ergebnis
  1690.                 return Car(alist);
  1691.               # Test nicht erfüllt
  1692.             }}
  1693.           # tail-end-rekursiv (rassoc ... (cdr alist)) aufrufen:
  1694.           alist = Cdr(alist); goto start;
  1695.     }   }
  1696.  
  1697. LISPFUN(rassoc,2,0,norest,key,3, (kw(test),kw(test_not),kw(key)) )
  1698.   # (RASSOC item alist :test :test-not :key), CLTL S. 281
  1699.   { test_key_arg(); # :KEY-Argument in STACK_0
  1700.    {var reg2 up_function up_fun = test_test_args(); # :TEST/:TEST-NOT-Argumente in STACK_2,STACK_1
  1701.     value1 = rassoc(STACK_3,&STACK_1,up_fun); # Suche durchführen
  1702.     mv_count=1;
  1703.     skipSTACK(5);
  1704.   }}
  1705.  
  1706. LISPFUN(rassoc_if,2,0,norest,key,1, (kw(key)) )
  1707.   # (RASSOC-IF pred alist :key), CLTL S. 281
  1708.   { test_key_arg(); # :KEY-Argument in STACK_0
  1709.     value1 = rassoc(STACK_1,&STACK_1,&up_if); # Suche durchführen
  1710.     mv_count=1;
  1711.     skipSTACK(3);
  1712.   }
  1713.  
  1714. LISPFUN(rassoc_if_not,2,0,norest,key,1, (kw(key)) )
  1715.   # (RASSOC-IF-NOT pred alist :key), CLTL S. 281
  1716.   { test_key_arg(); # :KEY-Argument in STACK_0
  1717.     value1 = rassoc(STACK_1,&STACK_1,&up_if_not); # Suche durchführen
  1718.     mv_count=1;
  1719.     skipSTACK(3);
  1720.   }
  1721.  
  1722. # Funktionen, die Listen zu Sequences machen:
  1723.  
  1724. LISPFUNN(list_upd,2)
  1725.   # #'(lambda (seq pointer) (cdr pointer))
  1726.   { value1 = cdr(popSTACK()); mv_count=1; skipSTACK(1); }
  1727.  
  1728. LISPFUNN(list_endtest,2)
  1729.   # #'(lambda (seq pointer) (atom pointer))
  1730.   { value1 = (matomp(STACK_0) ? T : NIL); mv_count=1; skipSTACK(2); }
  1731.  
  1732. LISPFUNN(list_fe_init,1)
  1733.   # #'(lambda (seq) (revappend seq nil))
  1734.   { pushSTACK(NIL); C_revappend(); }
  1735.  
  1736. LISPFUNN(list_access,2)
  1737.   # #'(lambda (seq pointer) (car pointer))
  1738.   { var reg1 object pointer = popSTACK();
  1739.     if (atomp(pointer)) fehler_cons(pointer);
  1740.     value1 = Car(pointer); mv_count=1;
  1741.     skipSTACK(1);
  1742.   }
  1743.  
  1744. LISPFUNN(list_access_set,3)
  1745.   # #'(lambda (seq pointer value) (rplaca pointer value))
  1746.   { if (matomp(STACK_1)) fehler_cons(STACK_1);
  1747.    {var reg2 object value = popSTACK();
  1748.     var reg1 object pointer = popSTACK();
  1749.     Car(pointer) = value;
  1750.     value1 = value; mv_count=1;
  1751.     skipSTACK(1);
  1752.   }}
  1753.  
  1754. LISPFUNN(list_llength,1)
  1755.   # #'(lambda (seq) (do ((L seq (cdr L)) (N 0 (1+ N))) ((atom L) N)))
  1756.   { value1 = fixnum(llength(popSTACK())); mv_count=1; }
  1757.  
  1758. # UP: Läuft bis zum Element index in einer Liste.
  1759. # elt_up(seq,index)
  1760. # > seq
  1761. # > index
  1762. # > subr_self: Aufrufer (ein SUBR)
  1763. # < ergebnis: Listenendstück ab diesem Index
  1764.   local object elt_up (object seq, object index);
  1765.   local object elt_up(seq,index)
  1766.     var reg4 object seq;
  1767.     var reg3 object index;
  1768.     # (do ((L seq (cdr L)) (N 0 (1+ N)))
  1769.     #     (nil)
  1770.     #   (if (atom L) (error "Zu großer Index in ELT: ~S" index))
  1771.     #   (if (= N index) (return L))
  1772.     # )
  1773.     { var reg1 object l = seq;
  1774.       var reg2 object n = Fixnum_0;
  1775.       loop
  1776.         { if (atomp(l)) goto index_too_large;
  1777.           if (eq(n,index)) break;
  1778.           l = Cdr(l);
  1779.           n = fixnum_inc(n,1);
  1780.         }
  1781.       return l;
  1782.       index_too_large:
  1783.         pushSTACK(seq); pushSTACK(index); pushSTACK(TheSubr(subr_self)->name);
  1784.         //: DEUTSCH "~: Index ~ zu groß für ~"
  1785.         //: ENGLISH "~: index ~ too large for ~"
  1786.         //: FRANCAIS "~ : L'index ~ est trop grand pour ~."
  1787.         fehler(error, GETTEXT("~: index ~ too large for ~"));
  1788.     }
  1789.  
  1790. LISPFUNN(list_elt,2)
  1791.   # #'(lambda (seq index)
  1792.   #     (do ((L seq (cdr L)) (N 0 (1+ N)))
  1793.   #         (nil)
  1794.   #       (if (atom L) (error "Zu großer Index in ELT: ~S" index))
  1795.   #       (if (= N index) (return (car L)))
  1796.   #   ) )
  1797.   { var reg2 object index = popSTACK();
  1798.     var reg1 object seq = popSTACK();
  1799.     value1 = Car(elt_up(seq,index)); mv_count=1;
  1800.   }
  1801.  
  1802. LISPFUNN(list_set_elt,3)
  1803.   # #'(lambda (seq index value)
  1804.   #     (do ((L seq (cdr L)) (N 0 (1+ N)))
  1805.   #         (nil)
  1806.   #       (if (atom L) (error "Zu großer Index in ELT: ~S" index))
  1807.   #       (if (= N index) (return (rplaca L value)))
  1808.   #   ) )
  1809.   { var reg1 object nthcdr = elt_up(STACK_2,STACK_1);
  1810.     value1 = Car(nthcdr) = popSTACK(); mv_count=1;
  1811.     skipSTACK(2);
  1812.   }
  1813.  
  1814. LISPFUNN(list_init_start,2)
  1815.   # #'(lambda (seq index)
  1816.   #     (do ((L seq (cdr L)) (N 0 (1+ N)))
  1817.   #         ((= N index) (return L))
  1818.   #       (if (atom L) (error "Unzulässiger :START - Index : ~S" index))
  1819.   #   ) )
  1820.     { var reg3 object index = popSTACK();
  1821.       var reg4 object seq = popSTACK();
  1822.      {var reg1 object l = seq;
  1823.       var reg2 object n = Fixnum_0;
  1824.       loop
  1825.         { if (eq(n,index)) break;
  1826.           if (atomp(l)) goto index_too_large;
  1827.           l = Cdr(l);
  1828.           n = fixnum_inc(n,1);
  1829.         }
  1830.       value1 = l; mv_count=1; return;
  1831.       index_too_large:
  1832.         pushSTACK(seq); pushSTACK(index); pushSTACK(S(list_init_start));
  1833.         //: DEUTSCH "~: START-Index ~ zu groß für ~"
  1834.         //: ENGLISH "~: start index ~ too large for ~"
  1835.         //: FRANCAIS "~ : L'index :START ~ est trop grand pour ~"
  1836.         fehler(error, GETTEXT("~: start index ~ too large for ~"));
  1837.     }}
  1838.  
  1839. LISPFUNN(list_fe_init_end,2)
  1840.   # #'(lambda (seq index)
  1841.   #     (if (<= 0 index)
  1842.   #       (do* ((L1 nil (cons (car L2) L1))
  1843.   #             (L2 seq (cdr L2))
  1844.   #             (i index (1- i)))
  1845.   #            ((zerop i) L1)
  1846.   #         (if (atom L2)
  1847.   #           (error "Unzulässiger :END - Index : ~S" index)
  1848.   #       ) )
  1849.   #       (error "Unzulässiger :END - Index : ~S" index)
  1850.   #   ) )
  1851.   { # index ist sowieso ein Integer >=0.
  1852.     pushSTACK(NIL); # L1 := nil
  1853.     {var reg1 object seq = STACK_2; pushSTACK(seq); } # L2 := seq
  1854.     pushSTACK(Fixnum_0); # i := 0
  1855.     loop
  1856.       { # Stackaufbau: seq, index, L1, L2, i
  1857.         if (eq(STACK_0,STACK_3)) # i=index ?
  1858.           goto end;
  1859.         if (matomp(STACK_1)) # (atom L2) ?
  1860.           goto index_too_large;
  1861.        {var reg1 object new_cons = allocate_cons(); # neues Cons
  1862.         var reg2 object L2 = STACK_1; STACK_1 = Cdr(L2); # (pop L2)
  1863.         Car(new_cons) = Car(L2); # als CAR
  1864.         Cdr(new_cons) = STACK_2; # L1 als CDR
  1865.         STACK_2 = new_cons; # L1 := neues Cons
  1866.         STACK_0 = fixnum_inc(STACK_0,1); # i := i+1
  1867.       }}
  1868.     index_too_large:
  1869.       skipSTACK(3); # Stackaufbau: seq, index
  1870.       pushSTACK(S(list_fe_init_end));
  1871.       //: DEUTSCH "~: END-Index ~ zu groß für ~"
  1872.       //: ENGLISH "~: end index ~ too large for ~"
  1873.       //: FRANCAIS "~ : L'index :END ~ est trop grand pour ~."
  1874.       fehler(error, GETTEXT("~: end index ~ too large for ~"));
  1875.     end:
  1876.       value1 = STACK_2; mv_count=1; # L1 als Wert
  1877.       skipSTACK(5);
  1878.   }
  1879.  
  1880.