home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / control.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  97.6 KB  |  2,321 lines
  1. # Special-Forms, Kontrollstrukturen, Evaluator-Nahes für CLISP
  2. # Bruno Haible 22.4.1995
  3.  
  4. #include "lispbibl.c"
  5.  
  6.  
  7. LISPFUN(exit,0,1,norest,nokey,0,NIL)
  8. # (SYSTEM::%EXIT [errorp]) verläßt das System
  9.   { var reg1 object errorp = STACK_0;
  10.     final_exitcode = ((eq(errorp,unbound) || nullp(errorp)) ? 0 : 1);
  11.     quit();
  12.   }
  13.  
  14. LISPSPECFORM(eval_when, 1,0,body)
  15. # (EVAL-WHEN ({situation}) {form}), CLTL S. 69
  16.   { var reg1 object situations = STACK_1; # Liste der Situationen
  17.     # Symbol EVAL oder Liste (NOT COMPILE) darin suchen:
  18.     while (consp(situations))
  19.       { var reg2 object situation = Car(situations);
  20.         if (eq(situation,S(eval))) # Symbol EVAL gefunden?
  21.           goto found;
  22.         if (consp(situation) && eq(Car(situation),S(not)))
  23.           { situation = Cdr(situation);
  24.             if (consp(situation) && nullp(Cdr(situation))
  25.                 && eq(Car(situation),S(compile)) # Liste (NOT COMPILE) gefunden?
  26.                )
  27.               goto found;
  28.           }
  29.         situations = Cdr(situations);
  30.       }
  31.     # Symbol EVAL nicht gefunden
  32.     value1 = NIL; mv_count=1; # Wert NIL
  33.     skipSTACK(2);
  34.     return;
  35.     found: # Symbol EVAL gefunden
  36.    {var reg2 object body = popSTACK();
  37.     skipSTACK(1);
  38.     implicit_progn(body,NIL); # body auswerten
  39.     return;
  40.   }}
  41.  
  42. LISPSPECFORM(quote, 1,0,nobody)
  43. # (QUOTE object) == 'object, CLTL S. 86
  44.   { value1 = popSTACK(); mv_count=1; } # Argument als Wert
  45.  
  46. # Fehlermeldung bei FUNCTION/FLET/LABELS, wenn kein Funktionssymbol vorliegt.
  47. # > caller: Aufrufer, ein Symbol
  48. # > obj: fehlerhaftes Funktionssymbol
  49.   nonreturning_function(local, fehler_funsymbol, (object caller, object obj));
  50.   local void fehler_funsymbol(caller,obj)
  51.     var reg2 object caller;
  52.     var reg1 object obj;
  53.     { pushSTACK(obj);
  54.       pushSTACK(caller);
  55.       //: DEUTSCH "~: Funktionsname ~ ist kein Symbol."
  56.       //: ENGLISH "~: function name ~ should be a symbol"
  57.       //: FRANCAIS "~: Le nom de fonction ~ n'est pas un symbôle."
  58.       fehler(program_error,GETTEXT("~: function name ~ should be a symbol"));
  59.     }
  60.  
  61. LISPSPECFORM(function, 1,1,nobody)
  62. # (FUNCTION funname), CLTL. S. 87
  63. # entweder (FUNCTION symbol)
  64. #     oder (FUNCTION (LAMBDA . lambdabody))
  65. #     oder (FUNCTION name (LAMBDA . lambdabody))
  66.   { var reg1 object funname; # Funktionsname (Symbol oder Lambdabody)
  67.     var reg2 object name; # Name (Symbol)
  68.     if (eq(STACK_0,unbound))
  69.       # 1 Argument
  70.       { funname = STACK_1;
  71.         if (funnamep(funname))
  72.           # (FUNCTION symbol) - Syntax
  73.           { # Symbol im aktuellen Funktions-Environment suchen:
  74.             var reg3 object fun = sym_function(funname,aktenv.fun_env);
  75.             # SUBR oder Closure oder Foreign-Function zurückgeben, sonst Fehler:
  76.             if (!(subrp(fun) || closurep(fun) || ffunctionp(fun)))
  77.               { pushSTACK(funname); # Wert für Slot NAME von CELL-ERROR
  78.                 pushSTACK(funname);
  79.                 pushSTACK(S(function));
  80.                 //: DEUTSCH "~: Die Funktion ~ ist nicht definiert."
  81.                 //: ENGLISH "~: undefined function ~"
  82.                 //: FRANCAIS "~: La fonction ~ n'est pas définie."
  83.                 fehler(undefined_function,GETTEXT("~: undefined function ~"));
  84.               }
  85.             value1 = fun; mv_count=1; skipSTACK(2); return;
  86.           }
  87.         name = S(Klambda); # :LAMBDA als Default-Name
  88.       }
  89.       else
  90.       # 2 Argumente
  91.       { name = STACK_1; # 1. Argument
  92.         if (!funnamep(name)) { fehler_funsymbol(S(function),name); }
  93.         funname = STACK_0; # 2. Argument, hoffentlich Lambdaausdruck
  94.       }
  95.     if (!(consp(funname) && eq(Car(funname),S(lambda)))) # Cons (LAMBDA . ...) ?
  96.       { pushSTACK(funname);
  97.         pushSTACK(S(function));
  98.         //: DEUTSCH "~: ~ ist keine Funktionsbezeichnung."
  99.         //: ENGLISH "~: ~ is not a function name"
  100.         //: FRANCAIS "~: ~ n'est pas un nom de fonction."
  101.         fehler(program_error,GETTEXT("~: ~ is not a function name"));
  102.       }
  103.     # Lambdaausdruck
  104.     # im aktuellen Environment in eine Closure umwandeln:
  105.     value1 = get_closure(Cdr(funname),name,&aktenv); mv_count=1;
  106.     skipSTACK(2); return;
  107.   }
  108.  
  109. # Fehler, wenn ein Symbol keinen Wert hat.
  110. # > symbol: Symbol
  111. # > subr_self: Aufrufer (ein SUBR)
  112.   nonreturning_function(local, fehler_no_value, (object symbol));
  113.   local void fehler_no_value(symbol)
  114.     var reg1 object symbol;
  115.     { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
  116.       pushSTACK(symbol);
  117.       pushSTACK(TheSubr(subr_self)->name);
  118.       //: DEUTSCH "~: ~ hat keinen dynamischen Wert."
  119.       //: ENGLISH "~: ~ has no dynamic value"
  120.       //: FRANCAIS "~: ~ n'a pas de valeur dynamique."
  121.       fehler(unbound_variable,GETTEXT("~: ~ has no dynamic value"));
  122.     }
  123.  
  124. LISPFUNN(psymbol_value,1)
  125. # (SYS::%SYMBOL-VALUE symbol), CLTL S. 90
  126.   { var reg1 object symbol = popSTACK();
  127.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  128.    {var reg2 object val = Symbol_value(symbol);
  129.     if (eq(val,unbound)) { fehler_no_value(symbol); }
  130.     value1 = val; mv_count=1;
  131.   }}
  132.  
  133. LISPFUNN(symbol_value,1)
  134. # (SYMBOL-VALUE symbol), CLTL S. 90
  135.   { var reg1 object symbol = popSTACK();
  136.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  137.    {var reg2 object val = Symbol_value(symbol);
  138.     if (eq(val,unbound)) { fehler_no_value(symbol); }
  139.     if (symbolmacrop(val)) # Symbol-Macro?
  140.       # ja -> expandieren und evaluieren:
  141.       { eval_noenv(TheSymbolmacro(val)->symbolmacro_expansion); mv_count=1; }
  142.       else
  143.       { value1 = val; mv_count=1; }
  144.   }}
  145.  
  146. # Fehlermeldung wegen undefinierter Funktion.
  147. # fehler_undef_function(caller,symbol);
  148. # > caller: Aufrufer (ein Symbol)
  149. # > symbol: Symbol oder (SETF symbol)
  150.   nonreturning_function(global, fehler_undef_function, (object caller, object symbol));
  151.   global void fehler_undef_function(caller,symbol)
  152.     var reg2 object caller;
  153.     var reg1 object symbol;
  154.     { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
  155.       pushSTACK(symbol);
  156.       pushSTACK(caller);
  157.       //: DEUTSCH "~: ~ hat keine globale Funktionsdefinition."
  158.       //: ENGLISH "~: ~ has no global function definition"
  159.       //: FRANCAIS "~: ~ n'as pas de définition de fonction globale."
  160.       fehler(undefined_function,GETTEXT("~: ~ has no global function definition"));
  161.     }
  162.  
  163. LISPFUNN(symbol_function,1)
  164. # (SYMBOL-FUNCTION symbol), CLTL S. 90
  165.   { var reg1 object symbol = popSTACK();
  166.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  167.    {var reg2 object val = Symbol_function(symbol);
  168.     if (eq(val,unbound)) { fehler_undef_function(S(symbol_value),symbol); }
  169.     value1 = val; mv_count=1;
  170.   }}
  171.  
  172. LISPFUNN(fdefinition,1)
  173. # (FDEFINITION funname), CLTL2 S. 120
  174.   { var reg3 object funname = popSTACK();
  175.     var reg1 object symbol = funname;
  176.     if (!funnamep(symbol)) { fehler_symbol(symbol); }
  177.     if (!symbolp(symbol))
  178.       { symbol = get(Car(Cdr(symbol)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
  179.         if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
  180.           { fehler_undef_function(S(fdefinition),funname); } # sonst undefiniert
  181.       }
  182.    {var reg2 object val = Symbol_function(symbol);
  183.     if (eq(val,unbound))
  184.       { fehler_undef_function(S(fdefinition),funname); }
  185.     value1 = val; mv_count=1;
  186.   }}
  187.  
  188. LISPFUNN(boundp,1)
  189. # (BOUNDP symbol), CLTL S. 90
  190.   { var reg1 object symbol = popSTACK();
  191.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  192.     value1 = (eq(Symbol_value(symbol),unbound) ? NIL : T); mv_count=1;
  193.   }
  194.  
  195. LISPFUNN(fboundp,1)
  196. # (FBOUNDP symbol), CLTL S. 90, CLTL2 S. 120
  197.   { var reg1 object symbol = popSTACK();
  198.     if (!funnamep(symbol)) { fehler_symbol(symbol); }
  199.     if (!symbolp(symbol))
  200.       { symbol = get(Car(Cdr(symbol)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
  201.         if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
  202.           goto undef; # sonst undefiniert
  203.       }
  204.     if (eq(Symbol_function(symbol),unbound))
  205.       { undef: value1 = NIL; }
  206.       else
  207.       { value1 = T; }
  208.     mv_count=1;
  209.   }
  210.  
  211. LISPFUNN(special_form_p,1)
  212. # (SPECIAL-FORM-P symbol), CLTL S. 91
  213.   { var reg1 object symbol = popSTACK();
  214.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  215.    {var reg2 object obj = Symbol_function(symbol);
  216.     value1 = (fsubrp(obj) ? T : NIL); mv_count=1;
  217.   }}
  218.  
  219. # Fehlermeldung bei Zuweisung, wenn ein Symbol eine Konstante ist.
  220. # (Einer Konstante kann nicht zugewiesen werden.)
  221. # fehler_symbol_constant(caller,symbol);
  222. # > caller: Aufrufer (ein Symbol)
  223. # > symbol: konstantes Symbol
  224.   nonreturning_function(local, fehler_symbol_constant, (object caller, object symbol));
  225.   local void fehler_symbol_constant(caller,symbol)
  226.     var reg2 object caller;
  227.     var reg1 object symbol;
  228.     { pushSTACK(symbol);
  229.       pushSTACK(caller);
  230.       //: DEUTSCH "~: Der Konstanten ~ kann kein Wert zugewiesen werden."
  231.       //: ENGLISH "~: the value of the constant ~ may not be altered"
  232.       //: FRANCAIS "~: Aucune valeur ne peut être assignée à la constante ~."
  233.       fehler(error,GETTEXT("~: the value of the constant ~ may not be altered"));
  234.     }
  235.  
  236. # UP: überprüft den Body einer SETQ- oder PSETQ-Form.
  237. # > caller: Aufrufer (ein Symbol)
  238. # > STACK_0: Body
  239. # < ergebnis: TRUE falls Symbol-Macros zu expandieren sind.
  240.   local boolean check_setq_body (object caller);
  241.   local boolean check_setq_body(caller)
  242.     var reg3 object caller;
  243.     { var reg1 object body = STACK_0;
  244.       while (consp(body))
  245.         { var reg2 object symbol = Car(body); # Variable
  246.           if (!symbolp(symbol)) { fehler_kein_symbol(caller,symbol); }
  247.           if (constantp(TheSymbol(symbol)))
  248.             { fehler_symbol_constant(caller,symbol); }
  249.           if (sym_macrop(symbol))
  250.             { return TRUE; }
  251.           body = Cdr(body);
  252.           if (atomp(body))
  253.             { if (!nullp(body)) goto fehler_dotted;
  254.               # Der ganze Body noch in STACK_0.
  255.               pushSTACK(caller);
  256.               //: DEUTSCH "~ mit ungerader Anzahl von Argumenten: ~"
  257.               //: ENGLISH "~ called with odd number of arguments: ~"
  258.               //: FRANCAIS "~ appelé avec un nombre impair d'arguments : ~"
  259.               fehler(program_error,GETTEXT("~ called with odd number of arguments: ~"));
  260.             }
  261.           body = Cdr(body);
  262.         }
  263.       # body ist zu Ende.
  264.       if (!nullp(body))
  265.         { fehler_dotted: # Der ganze Body noch in STACK_0.
  266.           pushSTACK(caller);
  267.           //: DEUTSCH "Dotted List als Argumentliste an ~ : ~"
  268.           //: ENGLISH "dotted list given to ~ : ~"
  269.           //: FRANCAIS "Liste pointée d'arguments fournie à ~ : ~"
  270.           fehler(program_error,GETTEXT("dotted list given to ~ : ~"));
  271.         }
  272.       return FALSE;
  273.     }
  274.  
  275. LISPSPECFORM(setq, 0,0,body)
  276. # (SETQ {var form}), CLTL S. 91
  277.   { if (check_setq_body(S(setq)))
  278.       { var reg1 object form = allocate_cons();
  279.         Car(form) = S(setf); Cdr(form) = popSTACK(); # aus SETQ mache SETF
  280.         eval(form);
  281.       }
  282.       else
  283.       { var reg1 object body = popSTACK();
  284.         if (consp(body))
  285.           { do { var reg2 object symbol = Car(body); # Variable
  286.                  body = Cdr(body);
  287.                  pushSTACK(Cdr(body)); # Restliste retten
  288.                  pushSTACK(symbol); # Symbol retten
  289.                  eval(Car(body)); # nächste Form auswerten
  290.                  symbol = popSTACK();
  291.                  setq(symbol,value1); # Zuweisung durchführen
  292.                  body = popSTACK();
  293.                }
  294.                while (consp(body));
  295.             # value1 ist noch das letzte Auswertungs-Ergebnis.
  296.           }
  297.           else
  298.           { value1 = NIL; } # Defaultwert bei (SETQ)
  299.         mv_count=1;
  300.   }   }
  301.  
  302. LISPSPECFORM(psetq, 0,0,body)
  303. # (PSETQ {var form}), CLTL S. 92
  304.   { if (check_setq_body(S(psetq)))
  305.       { var reg1 object form = allocate_cons();
  306.         Car(form) = S(psetf); Cdr(form) = popSTACK(); # aus PSETQ mache PSETF
  307.         eval(form);
  308.       }
  309.       else
  310.       { var reg1 object body = popSTACK();
  311.         var reg4 uintL body_length = llength(body)/2; # Anzahl der Paare (var form)
  312.         get_space_on_STACK(body_length*2*sizeof(object)); # Platz im STACK belegen
  313.         { var reg2 uintL count;
  314.           dotimesL(count,body_length,
  315.             { pushSTACK(Car(body)); # Variable auf den Stack
  316.               body = Cdr(body);
  317.               pushSTACK(Cdr(body)); # Restliche Liste auf den Stack
  318.               eval(Car(body)); # nächste Form auswerten
  319.               body = STACK_0;
  320.               STACK_0 = value1; # ihr Ergebnis in den Stack
  321.             });
  322.         }
  323.         { var reg3 uintL count;
  324.           dotimesL(count,body_length,
  325.             { var reg2 object val = popSTACK(); # Wert
  326.               var reg1 object sym = popSTACK(); # Symbol
  327.               setq(sym,val); # Zuweisung durchführen
  328.             });
  329.         }
  330.         value1 = NIL; mv_count=1; # Wert NIL
  331.   }   }
  332.  
  333. LISPFUNN(set,2)
  334. # (SET symbol value), CLTL S. 92
  335.   { var reg1 object symbol = STACK_1;
  336.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  337.     if (constantp(TheSymbol(symbol))) # Konstante?
  338.       { fehler_symbol_constant(S(set),symbol); }
  339.     if (sym_symbolmacrop(symbol)) # Symbol-Macro?
  340.       # Evaluiere `(SETF ,expansion (QUOTE ,value))
  341.       { pushSTACK(S(setf));
  342.         pushSTACK(TheSymbolmacro(Symbol_value(symbol))->symbolmacro_expansion);
  343.         pushSTACK(S(quote)); pushSTACK(STACK_(0+3)); pushSTACK(listof(2));
  344.         eval_noenv(listof(3)); mv_count=1;
  345.       }
  346.       else
  347.       { set_Symbol_value(symbol,STACK_0); value1 = STACK_0; mv_count=1; }
  348.     skipSTACK(2);
  349.   }
  350.   
  351. LISPFUNN(makunbound,1)
  352. # (MAKUNBOUND symbol), CLTL S. 92
  353.   { var reg1 object symbol = popSTACK();
  354.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  355.     if (constantp(TheSymbol(symbol)))
  356.       { pushSTACK(symbol);
  357.         pushSTACK(S(makunbound));
  358.         //: DEUTSCH "~: Der Wert der Konstanten ~ muß erhalten bleiben."
  359.         //: ENGLISH "~: the value of the constant ~ must not be removed"
  360.         //: FRANCAIS "~: La valeur de la constante ~ doit être conservée."
  361.         fehler(error,GETTEXT("~: the value of the constant ~ must not be removed"));
  362.       }
  363.     set_Symbol_value(symbol,unbound);
  364.     value1 = symbol; mv_count=1;
  365.   }
  366.  
  367. LISPFUNN(fmakunbound,1)
  368. # (FMAKUNBOUND symbol), CLTL S. 92, CLTL2 S. 123
  369.   { var reg3 object funname = popSTACK();
  370.     var reg1 object symbol = funname;
  371.     if (!funnamep(symbol)) { fehler_symbol(symbol); }
  372.     if (!symbolp(symbol))
  373.       { symbol = get(Car(Cdr(symbol)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
  374.         if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
  375.           goto undef; # sonst undefiniert
  376.       }
  377.     { var reg2 object obj = Symbol_function(symbol);
  378.       if (fsubrp(obj))
  379.         { pushSTACK(symbol);
  380.           pushSTACK(S(fmakunbound));
  381.           //: DEUTSCH "~: Definition der Spezialform ~ darf nicht gelöscht werden."
  382.           //: ENGLISH "~: the special form definition of ~ must not be removed"
  383.           //: FRANCAIS "~: La définition de la forme spéciale ~ doit être conservée."
  384.           fehler(error,GETTEXT("~: the special form definition of ~ must not be removed"));
  385.     }   }
  386.     Symbol_function(symbol) = unbound;
  387.     undef: value1 = funname; mv_count=1;
  388.   }
  389.  
  390. LISPFUN(apply,2,0,rest,nokey,0,NIL)
  391. # (APPLY function {arg} arglist), CLTL S. 107
  392.   { BEFORE(rest_args_pointer);
  393.     apply(Before(rest_args_pointer), # function
  394.           argcount, # Anzahl der {arg} auf dem Stack
  395.           popSTACK() # arglist
  396.          );
  397.     skipSTACK(1); # function aus dem Stack entfernen
  398.   }
  399.  
  400. LISPFUN(pfuncall,1,0,rest,nokey,0,NIL)
  401. # (SYS::%FUNCALL function {arg})
  402.   { funcall(Before(rest_args_pointer),argcount); skipSTACK(1); }
  403.  
  404. LISPFUN(funcall,1,0,rest,nokey,0,NIL)
  405. # (FUNCALL function {arg}), CLTL S. 108
  406.   { funcall(Before(rest_args_pointer),argcount); skipSTACK(1); }
  407.  
  408. LISPSPECFORM(progn, 0,0,body)
  409. # (PROGN {form}), CLTL S. 109
  410.   { implicit_progn(popSTACK(),NIL); }
  411.  
  412. # Macro: Wertet die Formen einer Formenliste aus.
  413. # implicit_prog();
  414. # > -(STACK): Formenliste
  415. # erhöht STACK um 1
  416. # kann GC auslösen
  417.   #define implicit_prog()  \
  418.     { while (mconsp(STACK_0))                         \
  419.         { var reg1 object forms = STACK_0;            \
  420.           STACK_0 = Cdr(forms);                       \
  421.           eval(Car(forms)); # nächste Form evaluieren \
  422.         }                                             \
  423.       skipSTACK(1);                                   \
  424.     }
  425.  
  426. LISPSPECFORM(prog1, 1,0,body)
  427. # (PROG1 form1 {form}), CLTL S. 109
  428.   { STACK_1 = (eval(STACK_1),value1); # form1 evaluieren, Wert retten
  429.     implicit_prog();
  430.     value1 = popSTACK(); mv_count=1; # geretteten Wert zurückgeben
  431.   }
  432.  
  433. LISPSPECFORM(prog2, 2,0,body)
  434. # (PROG2 form1 form2 {form}), CLTL S. 109
  435.   { eval(STACK_2); # form1 evaluieren
  436.     eval(STACK_1); STACK_2 = value1; # form2 evaluieren, Wert retten
  437.     STACK_1 = STACK_0; skipSTACK(1);
  438.     implicit_prog();
  439.     value1 = popSTACK(); mv_count=1; # geretteten Wert zurückgeben
  440.   }
  441.  
  442. # Fehlermeldung wegen nicht erlaubter Docstrings
  443. # fehler_docstring(caller,body);
  444. # > caller: Aufrufer, ein Symbol
  445. # > body: gesamter Body
  446.   nonreturning_function(local, fehler_docstring, (object caller, object body));
  447.   local void fehler_docstring(caller,body)
  448.     var reg1 object caller;
  449.     var reg2 object body;
  450.     { pushSTACK(body);
  451.       pushSTACK(caller);
  452.       //: DEUTSCH "~: Doc-Strings sind nicht hier erlaubt: ~"
  453.       //: ENGLISH "~: doc-strings are not allowed here: ~"
  454.       //: FRANCAIS "~: Une chaîne de documentation n'est pas permise ici : ~"
  455.       fehler(program_error,GETTEXT("~: doc-strings are not allowed here: ~"));
  456.     }
  457.  
  458. # UP für LET, LET*, LOCALLY, MULTIPLE-VALUE-BIND, SYMBOL-MACROLET:
  459. # Kompiliert die aktuelle Form und führt sie in kompiliertem Zustand aus.
  460. # compile_form()
  461. # > im STACK: EVAL-Frame mit der Form
  462. # < mv_count/mv_space: Werte
  463. # kann GC auslösen
  464.   local Values compile_eval_form (void);
  465.   local Values compile_eval_form()
  466.     { # (SYS::COMPILE-FORM form venv fenv benv genv denv) ausführen:
  467.       # Die ganze Form aus dem EVAL-Frame im Stack holen:
  468.       pushSTACK(STACK_(frame_form)); # als 1. Argument
  469.      {var reg1 environment* stack_env = nest_aktenv(); # aktuelles Environment nesten, auf den STACK legen
  470.       #if !defined(STACK_UP)
  471.       var environment my_env;
  472.       my_env = *stack_env; # und hierher übertragen
  473.       skipSTACK(5); # und wieder vom STACK nehmen
  474.       pushSTACK(my_env.var_env); # 2. Argument
  475.       pushSTACK(my_env.fun_env); # 3. Argument
  476.       pushSTACK(my_env.block_env); # 4. Argument
  477.       pushSTACK(my_env.go_env); # 5. Argument
  478.       pushSTACK(my_env.decl_env); # 6. Argument
  479.       #endif
  480.       funcall(S(compile_form),6);
  481.      }# Die sich ergebende compilierte Closure mit 0 Argumenten aufrufen:
  482.       funcall(value1,0);
  483.     }
  484.  
  485. # UP für LET, LET*, LOCALLY, MULTIPLE-VALUE-BIND, SYMBOL-MACROLET:
  486. # Analysiert die Variablen und Deklarationen, baut einen Variablenbindungs-
  487. # Frame auf und erweitert VENV und evtl. auch DENV durch einen Frame.
  488. # make_variable_frame(caller,varspecs,&bind_ptr,&bind_count)
  489. # > object caller: Aufrufer, ein Symbol
  490. # > object varspecs: Liste von Variablen-Specifiern
  491. # > object value2: Liste von Declaration-Specifiern
  492. # > object value1: Liste ({form}) von Formen
  493. # < Stackaufbau: Variablenbindungsframe, Env-Bindungs-Frame, ({form}).
  494. # < object* bind_ptr: Pointer über die erste "richtige" Bindung.
  495. # < uintC bind_count: Anzahl der "richtigen" Bindungen.
  496. # verändert STACK
  497. # kann GC auslösen
  498.   local void make_variable_frame (object caller, object varspecs, object** bind_ptr_, uintC* bind_count_);
  499.   local void make_variable_frame(caller,varspecs,bind_ptr_,bind_count_)
  500.     var reg10 object caller;
  501.     var reg10 object varspecs;
  502.     var reg10 object** bind_ptr_;
  503.     var reg10 uintC* bind_count_;
  504.     { var reg10 object declarations = value2;
  505.       # Variablenbindungs-Frame aufbauen:
  506.       { var reg9 object* top_of_frame = STACK; # Pointer übern Frame
  507.         # zuerst die Special-deklarierten Variablen aus declarations
  508.         # im Stack ablegen:
  509.         var reg9 object* spec_pointer = args_end_pointer;
  510.         var reg8 uintL spec_anz = 0; # Anzahl der SPECIAL-Referenzen
  511.         { var reg3 object declspecs = declarations;
  512.           while (consp(declspecs))
  513.             { var reg1 object declspec = Car(declspecs); # nächste Deklaration
  514.               if (consp(declspec) && eq(Car(declspec),S(special))) # (SPECIAL ...) ?
  515.                 { while (consp( declspec = Cdr(declspec) ))
  516.                     { var reg2 object declsym = Car(declspec); # nächstes Special-deklariertes Item
  517.                       if (!symbolp(declsym)) # sollte ein Symbol sein
  518.                         { pushSTACK(declsym);
  519.                           pushSTACK(caller);
  520.                           //: DEUTSCH "~: ~ ist kein Symbol, wurde aber als SPECIAL deklariert."
  521.                           //: ENGLISH "~: ~ is not a symbol, but was declared SPECIAL"
  522.                           //: FRANCAIS "~: ~ n'est pas un symbôle mais fut déclaré SPECIAL."
  523.                           fehler(program_error,GETTEXT("~: ~ is not a symbol, but was declared SPECIAL"));
  524.                         }
  525.                       # Special-deklariertes Symbol im Stack ablegen:
  526.                       pushSTACK(specdecl); # SPECDECL als "Wert"
  527.                       pushSTACK_symbolwithflags(declsym,wbit(active_bit_o)); # Symbol aktiv
  528.                       check_STACK();
  529.                       spec_anz++;
  530.                 }   }
  531.               declspecs = Cdr(declspecs);
  532.         }   }
  533.         *bind_ptr_ = args_end_pointer; # Pointer über erste "richtige" Bindung
  534.         # Dann die "richtigen" Variablenbindungen (jeweils die Variable
  535.         # und ihren unausgewerteten Init) im Stack ablegen:
  536.        {var reg7 uintL var_anz = 0; # Anzahl der Variablenbindungen
  537.         { while (consp(varspecs))
  538.             { var reg4 object varspec = Car(varspecs); # nächstes varspec
  539.               # in Symbol und Init aufspalten:
  540.               var reg5 object symbol;
  541.               var reg6 object init;
  542.               if (symbolp(varspec) && !eq(caller,S(symbol_macrolet))) # Symbol ?
  543.                 { symbol = varspec; init = unbound; }
  544.               elif # zweielementige Liste, mit Symbol als CAR ?
  545.                    (consp(varspec)
  546.                     && (symbol = Car(varspec), varspec = Cdr(varspec),
  547.                         symbolp(symbol) && consp(varspec) && nullp(Cdr(varspec))
  548.                    )   )
  549.                 { init = Car(varspec); }
  550.               else
  551.                 { pushSTACK(Car(varspecs));
  552.                   pushSTACK(caller);
  553.                   //: DEUTSCH "~: ~ ist keine korrekte Variablenspezifikation."
  554.                   //: ENGLISH "~: illegal variable specification ~"
  555.                   //: FRANCAIS "~: ~ n'est pas une spécification de variable licite."
  556.                   fehler(program_error,GETTEXT("~: illegal variable specification ~"));
  557.                 }
  558.               pushSTACK(init); # Init und
  559.               pushSTACK_symbolwithflags(symbol,0); # Variable ablegen
  560.               check_STACK();
  561.               # feststellen, ob statische oder dynamische Bindung:
  562.               if (!special_var_p(TheSymbol(symbol)) || eq(caller,S(symbol_macrolet)))
  563.                 { # Variable unter den Special-deklarierten?
  564.                   #ifdef NO_symbolflags
  565.                   var reg1 object* ptr = spec_pointer;
  566.                   var reg2 uintL count;
  567.                   dotimesL(count,spec_anz,
  568.                     { NEXT(ptr);
  569.                       if (eq(NEXT(ptr),symbol))
  570.                         { if (eq(NEXT(ptr),fixnum(bit(active_bit)))) goto dynamic; }
  571.                         else
  572.                         { NEXT(ptr); }
  573.                     });
  574.                   #else
  575.                   var reg3 object to_compare = as_object(as_oint(symbol) | wbit(active_bit_o));
  576.                   var reg1 object* ptr = spec_pointer;
  577.                   var reg2 uintL count;
  578.                   dotimesL(count,spec_anz,
  579.                     { NEXT(ptr);
  580.                       if (eq(NEXT(ptr),to_compare))
  581.                         goto dynamic;
  582.                     });
  583.                   #endif
  584.                   # Nein -> statische Bindung
  585.                 }
  586.                 else
  587.                 { # dynamisch binden
  588.                   if (FALSE)
  589.                     { dynamic:
  590.                       if (eq(caller,S(symbol_macrolet)))
  591.                         { pushSTACK(symbol);
  592.                           pushSTACK(caller);
  593.                           //: DEUTSCH "~: Symbol ~ darf nicht gleichzeitig SPECIAL und Makro deklariert werden."
  594.                           //: ENGLISH "~: symbol ~ must not be declared SPECIAL and a macro at the same time"
  595.                           //: FRANCAIS "~ : Le symbole ~ ne peut être déclaré SPECIAL et macro en même temps."
  596.                           fehler(program_error,GETTEXT("~: symbol ~ must not be declared SPECIAL and a macro at the same time"));
  597.                     }   }
  598.                   *(oint*)(&STACK_0) |= wbit(dynam_bit_o);
  599.                 }
  600.               varspecs = Cdr(varspecs);
  601.               var_anz++;
  602.         }   }
  603.         *bind_count_ = var_anz;
  604.         var_anz += spec_anz; # Gesamtzahl Symbol/Wert-Paare
  605.         #ifndef UNIX_DEC_ULTRIX_GCCBUG
  606.         if (var_anz > (uintC)(~(uintC)0)) # paßt es in ein uintC ?
  607.           { pushSTACK(caller);
  608.             //: DEUTSCH "~: Zuviele Variablen und/oder Deklarationen."
  609.             //: ENGLISH "~: too many variables and/or declarations"
  610.             //: FRANCAIS "~: Trop de déclarations et/ou de variables."
  611.             fehler(program_error,GETTEXT("~: too many variables and/or declarations"));
  612.           }
  613.         #endif
  614.         pushSTACK(aktenv.var_env); # aktuelles VAR_ENV als NEXT_ENV
  615.         pushSTACK(as_object(var_anz)); # Anzahl Bindungen
  616.         finish_frame(VAR);
  617.       }}
  618.       # Der Variablenbindungsframe ist jetzt fertig.
  619.      {var reg5 object* var_frame_ptr = STACK; # Pointer auf Variablenbindungs-Frame
  620.       # VENV-Bindungsframe aufbauen:
  621.       { var reg4 object* top_of_frame = STACK; # Pointer übern Frame
  622.         # Zuerst DENV um die nötigen declspecs erweitern:
  623.         var reg3 object denv = aktenv.decl_env;
  624.         pushSTACK(value1); # ({form}) retten
  625.         pushSTACK(declarations);
  626.         while (mconsp(STACK_0))
  627.           { var reg2 object declspecs = STACK_0;
  628.             STACK_0 = Cdr(declspecs);
  629.            {var reg1 object declspec = Car(declspecs); # nächstes Declspec
  630.             if (consp(declspec)) # sollte ein Cons sein
  631.               { if (!eq(Car(declspec),S(special))) # (SPECIAL ...) haben wir schon behandelt
  632.                   { denv = augment_decl_env(declspec,denv); } # alles andere behandeln
  633.           }}  }
  634.         skipSTACK(1);
  635.        {var reg1 object forms = popSTACK();
  636.         # Nun den Frame bauen:
  637.         if (eq(denv,aktenv.decl_env))
  638.           { pushSTACK(aktenv.var_env);
  639.             finish_frame(ENV1V);
  640.           }
  641.           else
  642.           { pushSTACK(aktenv.decl_env);
  643.             pushSTACK(aktenv.var_env);
  644.             finish_frame(ENV2VD);
  645.             aktenv.decl_env = denv;
  646.           }
  647.         # VENV-Bindungsframe ist fertig.
  648.         aktenv.var_env = make_framepointer(var_frame_ptr); # Pointer auf Variablenbindungsframe
  649.         pushSTACK(forms);
  650.     }}}}
  651.  
  652. LISPSPECFORM(let, 1,0,body)
  653. # (LET ({varspec}) {decl} {form}), CLTL S. 110
  654.   { # {decl} {form} trennen:
  655.     var reg6 boolean to_compile = parse_dd(STACK_0,aktenv.var_env,aktenv.fun_env); # unvollständiges var_env??
  656.     # bitte kein Docstring:
  657.     if (!nullp(value3)) { fehler_docstring(S(let),STACK_0); }
  658.     if (to_compile) # Deklaration (COMPILE) ?
  659.       # ja -> Form kompilieren:
  660.       { skipSTACK(2); return_Values compile_eval_form(); }
  661.       else
  662.       { skipSTACK(1);
  663.         # Variablenbindungsframe aufbauen, VAR_ENV erweitern:
  664.        {var object* bind_ptr;
  665.         var uintC bind_count;
  666.         make_variable_frame(S(let),popSTACK(),&bind_ptr,&bind_count);
  667.         # Dann die Initialisierungsformen auswerten:
  668.         { var reg3 object* frame_pointer = bind_ptr;
  669.           var reg4 uintC count;
  670.           dotimesC(count,bind_count,
  671.             { var reg1 object* initptr = &NEXT(frame_pointer);
  672.               var reg2 object init = *initptr; # nächstes Init
  673.               *initptr = (eq(init,unbound) ? NIL : (eval(init),value1)); # auswerten, NIL als Default
  674.               frame_pointer skipSTACKop -(varframe_binding_size-1);
  675.             });
  676.         }
  677.         # Dann die Bindungen aktivieren:
  678.         { var reg4 object* frame_pointer = bind_ptr;
  679.           var reg5 uintC count;
  680.           dotimesC(count,bind_count,
  681.             { frame_pointer skipSTACKop -varframe_binding_size;
  682.              {var reg1 object* markptr = &Before(frame_pointer);
  683.               if (*(oint*)(markptr) & wbit(dynam_bit_o)) # Bindung dynamisch?
  684.                 { var reg2 object symbol = *(markptr STACKop varframe_binding_sym); # Variable
  685.                   var reg3 object newval = *(markptr STACKop varframe_binding_value); # neuer Wert
  686.                   *(markptr STACKop varframe_binding_value) = Symbolflagged_value(symbol); # alten Wert im Frame sichern
  687.                   *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren
  688.                   set_Symbolflagged_value_on(symbol,newval,markptr); # neuer Wert
  689.                 }
  690.                 else
  691.                 { *(oint*)(markptr) |= wbit(active_bit_o); } # Bindung aktivieren
  692.             }});
  693.         }
  694.         # Body abinterpretieren:
  695.         implicit_progn(popSTACK(),NIL);
  696.         # Frames auflösen:
  697.         unwind(); # VENV-Bindungsframe auflösen
  698.         unwind(); # Variablenbindungs-Frame auflösen
  699.   }   }}
  700.  
  701. LISPSPECFORM(letstern, 1,0,body)
  702. # (LET* ({varspec}) {decl} {form}), CLTL S. 111
  703.   { # {decl} {form} trennen:
  704.     var reg7 boolean to_compile = parse_dd(STACK_0,aktenv.var_env,aktenv.fun_env); # unvollständiges var_env??
  705.     # bitte kein Docstring:
  706.     if (!nullp(value3)) { fehler_docstring(S(letstern),STACK_0); }
  707.     if (to_compile) # Deklaration (COMPILE) ?
  708.       # ja -> Form kompilieren:
  709.       { skipSTACK(2); return_Values compile_eval_form(); }
  710.       else
  711.       { skipSTACK(1);
  712.         # Variablenbindungsframe aufbauen, VAR_ENV erweitern:
  713.        {var object* bind_ptr;
  714.         var uintC bind_count;
  715.         make_variable_frame(S(letstern),popSTACK(),&bind_ptr,&bind_count);
  716.         # Dann die Initialisierungsformen auswerten und die Bindungen aktivieren:
  717.         { var reg5 object* frame_pointer = bind_ptr;
  718.           var reg6 uintC count;
  719.           dotimesC(count,bind_count,
  720.             { var reg2 object* initptr = &Next(frame_pointer);
  721.               frame_pointer skipSTACKop -varframe_binding_size;
  722.              {var reg1 object* markptr = &Before(frame_pointer);
  723.               var reg4 object init = *initptr; # nächstes Init
  724.               var reg4 object newval = (eq(init,unbound) ? NIL : (eval(init),value1)); # auswerten, NIL als Default
  725.               if (*(oint*)(markptr) & wbit(dynam_bit_o)) # Bindung dynamisch?
  726.                 { var reg3 object symbol = *(markptr STACKop varframe_binding_sym); # Variable
  727.                   *initptr = Symbolflagged_value(symbol); # alten Wert im Frame sichern
  728.                   *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren
  729.                   set_Symbolflagged_value_on(symbol,newval,markptr); # neuer Wert
  730.                 }
  731.                 else
  732.                 { *initptr = newval; # neuen Wert in den Frame
  733.                   *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren
  734.                 }
  735.             }});
  736.         }
  737.         # Body abinterpretieren:
  738.         implicit_progn(popSTACK(),NIL);
  739.         # Frames auflösen:
  740.         unwind(); # VENV-Bindungsframe auflösen
  741.         unwind(); # Variablenbindungs-Frame auflösen
  742.   }   }}
  743.  
  744. LISPSPECFORM(locally, 0,0,body)
  745. # (LOCALLY {decl} {form}), CLTL2 S. 221
  746.   { # {decl} {form} trennen:
  747.     var reg1 boolean to_compile = parse_dd(STACK_0,aktenv.var_env,aktenv.fun_env); # unvollständiges var_env??
  748.     # bitte kein Docstring:
  749.     if (!nullp(value3)) { fehler_docstring(S(locally),STACK_0); }
  750.     skipSTACK(1);
  751.     if (to_compile) # Deklaration (COMPILE) ?
  752.       # ja -> Form kompilieren:
  753.       { return_Values compile_eval_form(); }
  754.       else
  755.       { # Variablenbindungsframe aufbauen, VAR_ENV erweitern:
  756.         var object* bind_ptr;
  757.         var uintC bind_count;
  758.         make_variable_frame(S(locally),NIL,&bind_ptr,&bind_count);
  759.         # Body abinterpretieren:
  760.         implicit_progn(popSTACK(),NIL);
  761.         # Frames auflösen:
  762.         unwind(); # VENV-Bindungsframe auflösen
  763.         unwind(); # Variablenbindungs-Frame auflösen
  764.   }   }
  765.  
  766. LISPSPECFORM(compiler_let, 1,0,body)
  767. # (COMPILER-LET ({varspec}) {form}), CLTL S. 112
  768.   { var reg5 object* varspecs_ = &STACK_1;
  769.     var reg3 object varspecs = *varspecs_; # Liste der Variablen
  770.     var reg7 uintL varcount = llength(varspecs); # Anzahl der Variablen
  771.     get_space_on_STACK(varcount*3*sizeof(object)); # Platz auf dem STACK verlangen
  772.     # varspecs evaluieren:
  773.    {var reg6 object* val_pointer = args_end_pointer; # Pointer über die Werte
  774.     while (consp(varspecs))
  775.       { var reg1 object varspec = Car(varspecs);
  776.         var reg2 object symbol;
  777.         if (consp(varspec))
  778.           # varspec ist ein Cons
  779.           { symbol = Car(varspec);
  780.             varspec = Cdr(varspec);
  781.             if (!(consp(varspec) && nullp(Cdr(varspec))))
  782.               { pushSTACK(Car(varspecs));
  783.                 pushSTACK(S(compiler_let));
  784.                 //: DEUTSCH "~: ~ ist keine korrekte Variablenspezifikation."
  785.                 //: ENGLISH "~: illegal variable specification ~"
  786.                 //: FRANCAIS "~: ~ n'est pas une spécification de variable licite."
  787.                 fehler(program_error,GETTEXT("~: illegal variable specification ~"));
  788.               }
  789.             # symbol sollte ein nichtkonstantes Symbol sein:
  790.             if (!symbolp(symbol))
  791.               { fehler_symbol:
  792.                 fehler_kein_symbol(S(compiler_let),symbol);
  793.               }
  794.             if (constantp(TheSymbol(symbol)))
  795.               { fehler_constant:
  796.                 pushSTACK(symbol);
  797.                 pushSTACK(S(compiler_let));
  798.                 //: DEUTSCH "~: ~ ist eine Konstante und kann nicht dynamisch gebunden werden."
  799.                 //: ENGLISH "~: ~ is a constant, cannot be bound"
  800.                 //: FRANCAIS "~: ~ est une constante et ne peut pas être liée."
  801.                 fehler(error,GETTEXT("~: ~ is a constant, cannot be bound"));
  802.               }
  803.             pushSTACK(Cdr(varspecs));
  804.             eval_noenv(Car(varspec)); # zweites Listenelement auswerten
  805.             varspecs = STACK_0;
  806.             STACK_0 = value1; # und in den Stack
  807.           }
  808.           else
  809.           { symbol = varspec;
  810.             if (!symbolp(symbol)) goto fehler_symbol;
  811.             if (constantp(TheSymbol(symbol))) goto fehler_constant;
  812.             pushSTACK(NIL); # NIL als Wert in den Stack
  813.             varspecs = Cdr(varspecs);
  814.       }   }
  815.     varspecs = *varspecs_;
  816.     # Frame aufbauen:
  817.     { var reg4 object* top_of_frame = STACK; # Pointer übern Frame
  818.       while (consp(varspecs))
  819.         { var reg1 object varspec = Car(varspecs);
  820.           if (consp(varspec)) { varspec = Car(varspec); }
  821.           pushSTACK(Symbol_symvalue(varspec)); # alter Wert der Variablen
  822.           pushSTACK(varspec); # Variable
  823.           varspecs = Cdr(varspecs);
  824.         }
  825.       finish_frame(DYNBIND);
  826.     }
  827.     # Frame fertig aufgebaut, nun die Werte der Variablen verändern:
  828.     varspecs = *varspecs_;
  829.     { var reg2 object* valptr = val_pointer;
  830.       while (consp(varspecs))
  831.         { var reg1 object varspec = Car(varspecs);
  832.           if (consp(varspec)) { varspec = Car(varspec); }
  833.           set_Symbol_symvalue(varspec,NEXT(valptr)); # neuen Wert der Variablen zuweisen
  834.           varspecs = Cdr(varspecs);
  835.     }   }
  836.     #ifdef DYNBIND_LIST
  837.     add_frame_to_binding_list(&STACK_0);
  838.     #endif
  839.     # Nun die Formen evaluieren:
  840.     implicit_progn(*(varspecs_ STACKop -1),NIL);
  841.     # Bindungsframe auflösen:
  842.     unwind();
  843.     # Stack aufräumen:
  844.     set_args_end_pointer(val_pointer);
  845.     skipSTACK(2);
  846.   }}
  847.  
  848. LISPSPECFORM(progv, 2,0,body)
  849. # (PROGV symbollist valuelist {form}), CLTL S. 112
  850.   { STACK_2 = (eval(STACK_2),value1); # Symbolliste auswerten
  851.    {var reg4 object valuelist = (eval(STACK_1),value1); # Wertliste auswerten
  852.     var reg3 object body = popSTACK();
  853.     var reg2 object *body_ptr;
  854.     var reg1 object varlist;
  855.     skipSTACK(1);
  856.     varlist=popSTACK();
  857.     pushSTACK(body);
  858.     body_ptr = &STACK_0;
  859.     progv(varlist,valuelist); # Frame aufbauen
  860.     implicit_progn(*body_ptr,NIL); # body auswerten
  861.     unwind(); # Frame auflösen
  862.     skipSTACK(1);
  863.   }}
  864.  
  865. # Fehlermeldung bei FLET/LABELS, wenn keine Funktionsspezifikation vorliegt.
  866. # > caller: Aufrufer, ein Symbol
  867. # > obj: fehlerhafte Funktionsspezifikation
  868.   nonreturning_function(local, fehler_funspec, (object caller, object obj));
  869.   local void fehler_funspec(caller,obj)
  870.     var reg2 object caller;
  871.     var reg1 object obj;
  872.     { pushSTACK(obj);
  873.       pushSTACK(caller);
  874.       //: DEUTSCH "~: ~ ist keine Funktionsspezifikation."
  875.       //: ENGLISH "~: ~ is not a function specification"
  876.       //: FRANCAIS "~: ~ n'est pas une spécification de fonction."
  877.       fehler(program_error,GETTEXT("~: ~ is not a function specification"));
  878.     }
  879.  
  880. # UP: Beendet ein FLET/MACROLET.
  881. # finish_flet(top_of_frame,body);
  882. # > Stackaufbau: [top_of_frame] def1 name1 ... defn namen [STACK]
  883. # > top_of_frame: Pointer übern Frame
  884. # > body: Formenliste
  885. # < mv_count/mv_space: Werte
  886. # kann GC auslösen
  887.   local Values finish_flet (object* top_of_frame, object body);
  888.   local Values finish_flet(top_of_frame,body)
  889.     var reg2 object* top_of_frame;
  890.     var reg3 object body;
  891.     {{var reg1 uintL bindcount = # Anzahl der Bindungen
  892.         STACK_item_count(STACK,top_of_frame) / 2;
  893.       pushSTACK(aktenv.fun_env); # aktuelles FUN_ENV als NEXT_ENV
  894.       pushSTACK(as_object(bindcount));
  895.       finish_frame(FUN);
  896.      }# Funktionsbindungsframe ist fertig.
  897.       # FENV-Bindungsframe bauen:
  898.      {var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  899.       pushSTACK(aktenv.fun_env);
  900.       finish_frame(ENV1F);
  901.       # FENV-Bindungsframe ist fertig.
  902.       # FUN_ENV erweitern:
  903.       # top_of_frame = Pointer auf den Funktionsbindungsframe
  904.       aktenv.fun_env = make_framepointer(top_of_frame);
  905.      }# Formen ausführen:
  906.       implicit_progn(body,NIL);
  907.       unwind(); # FENV-Bindungsframe auflösen
  908.       unwind(); # Funktionsbindungsframe auflösen
  909.     }
  910.  
  911. LISPSPECFORM(flet, 1,0,body)
  912. # (FLET ({funspec}) {form}), CLTL S. 113
  913.   { var reg5 object body = popSTACK(); # ({form})
  914.     var reg1 object funspecs = popSTACK(); # ({funspec})
  915.     # Funktionsbindungs-Frame aufbauen:
  916.     var reg6 object* top_of_frame = STACK; # Pointer übern Frame
  917.     while (consp(funspecs))
  918.       { pushSTACK(body); # Formenliste retten
  919.         pushSTACK(Cdr(funspecs)); # restliche funspecs
  920.         funspecs = Car(funspecs); # nächstes funspec = (name . lambdabody)
  921.         # sollte ein Cons sein, dessen CAR ein Symbol und dessen CDR ein Cons ist:
  922.         if (!consp(funspecs)) { fehler_spec: fehler_funspec(S(flet),funspecs); }
  923.        {var reg2 object name = Car(funspecs);
  924.         var reg3 object lambdabody = Cdr(funspecs);
  925.         if (!funnamep(name)) { fehler_funsymbol(S(flet),name); }
  926.         if (!consp(lambdabody)) { goto fehler_spec; }
  927.         pushSTACK(name); # name retten
  928.         # lambdabody zu einer Closure machen:
  929.         {var reg4 object fun = get_closure(lambdabody,name,&aktenv);
  930.          name = popSTACK();
  931.          funspecs = popSTACK(); # restliche funspecs
  932.          body = popSTACK();
  933.          # in den Frame:
  934.          pushSTACK(fun); # als "Wert" die Closure
  935.          pushSTACK(name); # Name, Bindung ist automatisch aktiv
  936.       }}}
  937.     return_Values finish_flet(top_of_frame,body);
  938.   }
  939.  
  940. LISPSPECFORM(labels, 1,0,body)
  941. # (LABELS ({funspec}) {form}), CLTL S. 113
  942.   { # Auf den Aufbau eines Funktionsbindungs-Frames kann hier verzichtet werden,
  943.     # weil bei der Bildung der ersten Closure sowieso das Environment genestet
  944.     # und dabei dieser Funktionsbindungs-Frame in einen Vektor geschrieben würde.
  945.     # aktuelles FUN_ENV nesten:
  946.     pushSTACK(nest_fun(aktenv.fun_env));
  947.     # Anzahl der funspecs bestimmen und Syntax abtesten:
  948.    {var reg6 uintL veclength = 1; # = 2 * (Anzahl der funspecs) + 1
  949.     { var reg2 object funspecs = STACK_(1+1);
  950.       while (consp(funspecs))
  951.         { var reg1 object funspec = Car(funspecs);
  952.           # sollte ein Cons sein, dessen CAR ein Symbol und dessen CDR ein Cons ist:
  953.           if (!consp(funspec)) { fehler_spec: fehler_funspec(S(labels),funspec); }
  954.           {var reg3 object name = Car(funspec);
  955.            var reg4 object lambdabody = Cdr(funspec);
  956.            if (!funnamep(name)) { fehler_funsymbol(S(labels),name); }
  957.            if (!consp(lambdabody)) { goto fehler_spec; }
  958.           }
  959.           funspecs = Cdr(funspecs);
  960.           veclength += 2;
  961.     }   }
  962.     # Vektor passender Länge allozieren und darin die Namen eintragen:
  963.     {var reg7 object vec = allocate_vector(veclength);
  964.      {var reg2 object* ptr = &TheSvector(vec)->data[0];
  965.       var reg1 object funspecs = STACK_(1+1);
  966.       while (consp(funspecs))
  967.         { *ptr++ = Car(Car(funspecs)); # nächster name
  968.           ptr++; # Funktion bleibt vorerst NIL
  969.           funspecs = Cdr(funspecs);
  970.         }
  971.       *ptr++ = popSTACK(); # genestetes FUN_ENV als letztes Vektor-Element
  972.      }
  973.      {var reg5 object body = popSTACK(); # Formenliste
  974.       var reg2 object funspecs = popSTACK();
  975.       # FENV-Bindungsframe aufbauen:
  976.       { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  977.         pushSTACK(aktenv.fun_env);
  978.         finish_frame(ENV1F);
  979.       }
  980.       # FUN_ENV erweitern:
  981.       aktenv.fun_env = vec;
  982.       # Closures erzeugen und in den Vektor stecken:
  983.       pushSTACK(body);
  984.       pushSTACK(vec);
  985.       {var reg4 uintL index = 1; # Index in den Vektor
  986.        while (consp(funspecs))
  987.          { pushSTACK(Cdr(funspecs)); # restliche funspecs
  988.           {var reg1 object funspec = Car(funspecs);
  989.            # Closure erzeugen:
  990.            var reg3 object fun = get_closure(Cdr(funspec),Car(funspec),&aktenv);
  991.            funspecs = popSTACK();
  992.            TheSvector(STACK_0)->data[index] = fun; # in den Vektor stecken
  993.            index += 2;
  994.       }  }}
  995.       skipSTACK(1); # Vektor vergessen
  996.       body = popSTACK();
  997.       # Formen ausführen:
  998.       implicit_progn(body,NIL);
  999.       unwind(); # FENV-Bindungsframe auflösen
  1000.   }}}}
  1001.  
  1002. LISPSPECFORM(macrolet, 1,0,body)
  1003. # (MACROLET ({macrodef}) {form}), CLTL S. 113
  1004.   { var reg2 object body = popSTACK(); # ({form})
  1005.     var reg1 object macrodefs = popSTACK(); # ({macrodef})
  1006.     # Macrobindungs-Frame aufbauen:
  1007.     var reg4 object* top_of_frame = STACK; # Pointer übern Frame
  1008.     while (consp(macrodefs))
  1009.       { pushSTACK(body); # Formenliste retten
  1010.         pushSTACK(Cdr(macrodefs)); # restliche macrodefs
  1011.         macrodefs = Car(macrodefs); # nächstes macrodef = (name . lambdabody)
  1012.         # sollte ein Cons sein, dessen CAR ein Symbol und dessen CDR ein Cons ist:
  1013.         if (!consp(macrodefs))
  1014.           { fehler_spec:
  1015.             pushSTACK(macrodefs);
  1016.             pushSTACK(S(macrolet));
  1017.             //: DEUTSCH "~: ~ ist keine Macro-Spezifikation."
  1018.             //: ENGLISH "~: ~ is not a macro specification"
  1019.             //: FRANCAIS "~: ~ n'est pas une spécification de macro."
  1020.             fehler(program_error,GETTEXT("~: ~ is not a macro specification"));
  1021.           }
  1022.        {var reg3 object name = Car(macrodefs);
  1023.         if (!symbolp(name))
  1024.           { pushSTACK(name);
  1025.             pushSTACK(S(macrolet));
  1026.             //: DEUTSCH "~: Macro-Name ~ ist kein Symbol."
  1027.             //: ENGLISH "~: macro name ~ should be a symbol"
  1028.             //: FRANCAIS "~: Le nom de macro ~ n'est pas un symbôle."
  1029.             fehler(program_error,GETTEXT("~: macro name ~ should be a symbol"));
  1030.           }
  1031.         if (!mconsp(Cdr(macrodefs))) { goto fehler_spec; }
  1032.         pushSTACK(name); # name retten
  1033.         # Macro-Expander bauen: (SYSTEM::MAKE-MACRO-EXPANDERCONS macrodef)
  1034.         pushSTACK(macrodefs); funcall(S(make_macro_expandercons),1);
  1035.         name = popSTACK();
  1036.         macrodefs = popSTACK(); # restliche macrodefs
  1037.         body = popSTACK();
  1038.         # in den Frame:
  1039.         pushSTACK(value1); # als "Wert" das Cons mit dem Expander
  1040.         pushSTACK(name); # Name, Bindung ist automatisch aktiv
  1041.       }}
  1042.     return_Values finish_flet(top_of_frame,body);
  1043.   }
  1044.  
  1045. LISPSPECFORM(symbol_macrolet, 1,0,body)
  1046. # (SYMBOL-MACROLET ({(var expansion)}) {decl} {form}), CLTL2 S. 155
  1047.   { # {decl} {form} trennen:
  1048.     var reg5 boolean to_compile = parse_dd(STACK_0,aktenv.var_env,aktenv.fun_env); # unvollständiges var_env??
  1049.     # bitte kein Docstring:
  1050.     if (!nullp(value3)) { fehler_docstring(S(symbol_macrolet),STACK_0); }
  1051.     if (to_compile) # Deklaration (COMPILE) ?
  1052.       # ja -> Form kompilieren:
  1053.       { skipSTACK(2); return_Values compile_eval_form(); }
  1054.       else
  1055.       { skipSTACK(1);
  1056.         # Variablenbindungsframe aufbauen, VAR_ENV erweitern:
  1057.        {var object* bind_ptr;
  1058.         var uintC bind_count;
  1059.         make_variable_frame(S(symbol_macrolet),popSTACK(),&bind_ptr,&bind_count);
  1060.         # Dann die Symbol-Macros bilden und die Bindungen aktivieren:
  1061.         { var reg3 object* frame_pointer = bind_ptr;
  1062.           var reg4 uintC count;
  1063.           dotimesC(count,bind_count,
  1064.             { var reg1 object* initptr = &NEXT(frame_pointer);
  1065.               var reg2 object sm = allocate_symbolmacro();
  1066.               TheSymbolmacro(sm)->symbolmacro_expansion = *initptr;
  1067.               *initptr = sm;
  1068.               frame_pointer skipSTACKop -(varframe_binding_size-1);
  1069.               *(oint*)(&Before(frame_pointer)) |= wbit(active_bit_o);
  1070.             });
  1071.         }
  1072.         # Body abinterpretieren:
  1073.         implicit_progn(popSTACK(),NIL);
  1074.         # Frames auflösen:
  1075.         unwind(); # VENV-Bindungsframe auflösen
  1076.         unwind(); # Variablenbindungs-Frame auflösen
  1077.   }   }}
  1078.  
  1079. LISPSPECFORM(if, 2,1,nobody)
  1080. # (IF test form1 [form2]), CLTL S. 115
  1081.   { eval(STACK_2); # Bedingung auswerten
  1082.    {var reg1 object form;
  1083.     if (!nullp(value1))
  1084.       { form = STACK_1; skipSTACK(3); } # form1 auswerten
  1085.       else
  1086.       { form = STACK_0; skipSTACK(3); # form2 auswerten
  1087.         if (eq(form,unbound))
  1088.           { value1 = NIL; mv_count=1; return; } # keine angegeben -> NIL
  1089.       }
  1090.     eval(form);
  1091.   }}
  1092.  
  1093. LISPSPECFORM(when, 1,0,body)
  1094. # (WHEN test {form}), CLTL S. 115
  1095.   { eval(STACK_1); # Bedingung auswerten
  1096.     if (!nullp(value1))
  1097.       { var reg1 object body = STACK_0;
  1098.         skipSTACK(2);
  1099.         implicit_progn(body,NIL);
  1100.       }
  1101.       else
  1102.       { skipSTACK(2);
  1103.         value1 = NIL; mv_count=1;
  1104.       }
  1105.   }
  1106.  
  1107. LISPSPECFORM(unless, 1,0,body)
  1108. # (UNLESS test {form}), CLTL S. 115
  1109.   { eval(STACK_1); # Bedingung auswerten
  1110.     if (nullp(value1))
  1111.       { var reg1 object body = STACK_0;
  1112.         skipSTACK(2);
  1113.         implicit_progn(body,NIL);
  1114.       }
  1115.       else
  1116.       { skipSTACK(2);
  1117.         value1 = NIL; mv_count=1;
  1118.       }
  1119.   }
  1120.  
  1121. LISPSPECFORM(cond, 0,0,body)
  1122. # (COND {(bed {form})}), CLTL S. 116
  1123.   { while (mconsp(STACK_0))
  1124.       { var reg1 object clause = STACK_0; # Klausel-Liste
  1125.         STACK_0 = Cdr(clause); # restliche Klauseln retten
  1126.         clause = Car(clause); # nächste Klausel
  1127.         if (!consp(clause)) # sollte ein Cons sein
  1128.           { pushSTACK(clause);
  1129.             pushSTACK(S(cond));
  1130.             //: DEUTSCH "~: Klausel ~ muß Liste sein."
  1131.             //: ENGLISH "~: clause ~ should be a list"
  1132.             //: FRANCAIS "~: La clause ~ doit être une liste."
  1133.             fehler(program_error,GETTEXT("~: clause ~ should be a list"));
  1134.           }
  1135.         pushSTACK(Cdr(clause)); # Klausel-Rest retten
  1136.         eval(Car(clause)); # Bedingung auswerten
  1137.         if (!nullp(value1)) goto eval_clause;
  1138.         skipSTACK(1); # nächste probieren
  1139.       }
  1140.     # keine Bedingung war erfüllt.
  1141.     skipSTACK(1); value1 = NIL; mv_count=1; return;
  1142.     # erfüllte Bedingung gefunden:
  1143.     eval_clause:
  1144.    {var reg1 object clause_rest = popSTACK(); # Klausel-Rest
  1145.     skipSTACK(1);
  1146.     implicit_progn(clause_rest,value1); # auswerten
  1147.   }}
  1148.  
  1149. LISPSPECFORM(block, 1,0,body)
  1150. # (BLOCK name {form}), CLTL S. 119
  1151.   { var reg9 object body = popSTACK();
  1152.     var reg9 object name = popSTACK();
  1153.     if (!symbolp(name)) { fehler_symbol(name); }
  1154.    {var jmp_buf returner; # Rücksprungpunkt
  1155.     # Block-Frame aufbauen:
  1156.     { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  1157.       pushSTACK(name); # Block-Name
  1158.       pushSTACK(aktenv.block_env); # aktuelles BLOCK_ENV als NEXT_ENV
  1159.       finish_entry_frame(IBLOCK,&!returner,_EMA_, goto block_return; );
  1160.     }
  1161.     # BENV-Frame aufbauen:
  1162.     {var reg1 object* top_of_frame = STACK;
  1163.      pushSTACK(aktenv.block_env);
  1164.      finish_frame(ENV1B);
  1165.     # BLOCK_ENV erweitern (top_of_frame = Pointer auf den Block-Frame)
  1166.      aktenv.block_env = make_framepointer(top_of_frame);
  1167.     }
  1168.     # Body ausführen:
  1169.     implicit_progn(body,NIL);
  1170.     unwind(); # BENV-Bindungsframe auflösen
  1171.     block_return: # Hierher wird gesprungen, wenn der BLOCK-Frame einen
  1172.                   # RETURN-FROM gefangen hat.
  1173.     unwind(); # BLOCK-Frame auflösen
  1174.   }}
  1175.  
  1176. # Fehler, wenn ein Block bereits verlassen wurde.
  1177. # fehler_block_left(name);
  1178. # > name: Block-Name
  1179.   nonreturning_function(global, fehler_block_left, (object name));
  1180.   global void fehler_block_left(name)
  1181.     var reg1 object name;
  1182.     { pushSTACK(name);
  1183.       pushSTACK(S(return_from));
  1184.       //: DEUTSCH "~: Der Block mit Namen ~ wurde bereits verlassen."
  1185.       //: ENGLISH "~: the block named ~ has already been left"
  1186.       //: FRANCAIS "~: Le bloc de nom ~ a déjà été quitté."
  1187.       fehler(control_error,GETTEXT("~: the block named ~ has already been left"));
  1188.     }
  1189.  
  1190. LISPSPECFORM(return_from, 1,1,nobody)
  1191. # (RETURN-FROM name [result]), CLTL S. 120
  1192.   { var reg4 object name = STACK_1;
  1193.     if (!symbolp(name)) { fehler_symbol(name); } # sollte ein Symbol sein
  1194.     # BLOCK_ENV durchgehen:
  1195.    {var reg1 object env = aktenv.block_env; # aktuelles BLOCK_ENV
  1196.     var reg2 object* FRAME;
  1197.     while (stack_env_p(env))
  1198.       { # env ist ein Frame-Pointer auf einen IBLOCK-Frame im Stack.
  1199.         FRAME = TheFramepointer(env);
  1200.         if (mtypecode(FRAME_(0)) & bit(nested_bit_t))
  1201.           # Frame schon genestet
  1202.           { env = FRAME_(frame_next_env); break; }
  1203.         if (eq(FRAME_(frame_name),name)) goto found;
  1204.         env = FRAME_(frame_next_env);
  1205.       }
  1206.     # env ist eine Aliste.
  1207.     while (consp(env))
  1208.       { var reg3 object block_cons = Car(env);
  1209.         if (eq(Car(block_cons),name))
  1210.           { env = Cdr(block_cons);
  1211.             if (eq(env,disabled)) # Block noch aktiv?
  1212.               { fehler_block_left(name); }
  1213.             goto found;
  1214.           }
  1215.         env = Cdr(env);
  1216.       }
  1217.     # env ist zu Ende.
  1218.     pushSTACK(name);
  1219.     pushSTACK(S(return_from));
  1220.     //: DEUTSCH "~: Es ist kein Block namens ~ sichtbar."
  1221.     //: ENGLISH "~: no block named ~ is currently visible"
  1222.     //: FRANCAIS "~: Aucun bloc de nom ~ n'est visible."
  1223.     fehler(program_error,GETTEXT("~: no block named ~ is currently visible"));
  1224.     # Block-Frame gefunden: env
  1225.     found:
  1226.     FRAME = uTheFramepointer(env); # Pointer auf ihn
  1227.     # Werte produzieren, mit denen der Block verlassen werden soll:
  1228.     {var reg5 object result = popSTACK();
  1229.      skipSTACK(1);
  1230.      if (!eq(result,unbound)) # result angegeben?
  1231.        { eval(result); }
  1232.        else
  1233.        { value1 = NIL; mv_count=1; }
  1234.      # Zum gefundenen Block-Frame springen und ihn auflösen:
  1235.      unwind_upto(FRAME);
  1236.   }}}
  1237.  
  1238. # Die Funktionen MAPCAR, MAPLIST, MAPCAN, MAPCON bauen wir in zwei Versionen:
  1239. # Die erste baut die Liste im umgekehrter Reihenfolge, muß sie dann umdrehen.
  1240. # Die zweite arbeitet vorwärtsherum, braucht dafür aber ein Cons zuviel.
  1241.   #define MAP_REVERSES
  1242.  
  1243. #ifdef MAP_REVERSES
  1244.  
  1245. # Macro für MAPCAR und MAPLIST
  1246.   #define MAPCAR_MAPLIST_BODY(listaccess)  \
  1247.     { var reg7 object* args_pointer = rest_args_pointer STACKop 2;              \
  1248.       argcount++; # argcount := Anzahl der Listen auf dem Stack                 \
  1249.       # Platz für die Funktionsaufruf-Argumente reservieren:                    \
  1250.       get_space_on_STACK(sizeof(object)*(uintL)argcount);                       \
  1251.       pushSTACK(NIL); # Anfang der Ergebnisliste                                \
  1252.      {var reg6 object* ergptr = &STACK_0; # Pointer darauf                      \
  1253.       # alle Listen parallel durchlaufen:                                       \
  1254.       loop                                                                      \
  1255.         { var reg3 object* argptr = args_pointer;                               \
  1256.           var reg5 object fun = NEXT(argptr);                                   \
  1257.           var reg4 uintC count;                                                 \
  1258.           dotimespC(count,argcount,                                             \
  1259.             { var reg2 object* next_list_ = &NEXT(argptr);                      \
  1260.               var reg1 object next_list = *next_list_;                          \
  1261.               if (atomp(next_list)) goto fertig; # eine Liste zu Ende -> fertig \
  1262.               pushSTACK(listaccess(next_list)); # als Argument auf den Stack    \
  1263.               *next_list_ = Cdr(next_list); # Liste verkürzen                   \
  1264.             });                                                                 \
  1265.           funcall(fun,argcount); # Funktion aufrufen                            \
  1266.           pushSTACK(value1);                                                    \
  1267.          {var reg1 object new_cons = allocate_cons(); # neues Cons              \
  1268.           Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;                  \
  1269.           STACK_0 = new_cons; # verlängert die Ergebnisliste                    \
  1270.         }}                                                                      \
  1271.       fertig:                                                                   \
  1272.       value1 = nreverse(*ergptr); mv_count=1; # Ergebnisliste umdrehen          \
  1273.       set_args_end_pointer(args_pointer); # STACK aufräumen                     \
  1274.     }}
  1275.  
  1276. #else
  1277.  
  1278. # Macro für MAPCAR und MAPLIST
  1279.   #define MAPCAR_MAPLIST_BODY(listaccess)  \
  1280.     { var reg7 object* args_pointer = rest_args_pointer STACKop 2;              \
  1281.       argcount++; # argcount := Anzahl der Listen auf dem Stack                 \
  1282.       # Platz für die Funktionsaufruf-Argumente reservieren:                    \
  1283.       get_space_on_STACK(sizeof(object)*(uintL)argcount);                       \
  1284.       # Gesamtliste anfangen:                                                   \
  1285.       {var reg1 object new_cons = allocate_cons(); # (CONS NIL NIL)             \
  1286.        pushSTACK(new_cons); # Gesamtliste                                       \
  1287.        pushSTACK(new_cons); # (last Gesamtliste)                                \
  1288.       }                                                                         \
  1289.      {var reg6 object* ergptr = &STACK_1; # Pointer darauf                      \
  1290.       # alle Listen parallel durchlaufen:                                       \
  1291.       loop                                                                      \
  1292.         { var reg3 object* argptr = args_pointer;                               \
  1293.           var reg5 object fun = NEXT(argptr);                                   \
  1294.           var reg4 uintC count;                                                 \
  1295.           dotimespC(count,argcount,                                             \
  1296.             { var reg2 object* next_list_ = &NEXT(argptr);                      \
  1297.               var reg1 object next_list = *next_list_;                          \
  1298.               if (atomp(next_list)) goto fertig; # eine Liste zu Ende -> fertig \
  1299.               pushSTACK(listaccess(next_list)); # als Argument auf den Stack    \
  1300.               *next_list_ = Cdr(next_list); # Liste verkürzen                   \
  1301.             });                                                                 \
  1302.           funcall(fun,argcount); # Funktion aufrufen                            \
  1303.           pushSTACK(value1);                                                    \
  1304.          {var reg1 object new_cons = allocate_cons(); # neues Cons              \
  1305.           Car(new_cons) = popSTACK(); # new_cons = (LIST (FUNCALL ...))         \
  1306.           Cdr(STACK_0) = new_cons; STACK_0 = new_cons; # verlängert Gesamtliste \
  1307.         }}                                                                      \
  1308.       fertig:                                                                   \
  1309.       value1 = Cdr(*ergptr); mv_count=1; # Ergebnisliste ohne Header-Cons       \
  1310.       set_args_end_pointer(args_pointer); # STACK aufräumen                     \
  1311.     }}
  1312.  
  1313. #endif
  1314.  
  1315. # Macro für MAPC und MAPL
  1316.   #define MAPC_MAPL_BODY(listaccess)  \
  1317.     { var reg7 object* args_pointer = rest_args_pointer STACKop 2;              \
  1318.       argcount++; # argcount := Anzahl der Listen auf dem Stack                 \
  1319.       # Platz für die Funktionsaufruf-Argumente reservieren:                    \
  1320.       get_space_on_STACK(sizeof(object)*(uintL)argcount);                       \
  1321.       pushSTACK(BEFORE(rest_args_pointer)); # erstes Listenargument retten      \
  1322.      {var reg6 object* ergptr = &STACK_0; # Pointer darauf                      \
  1323.       # alle Listen parallel durchlaufen:                                       \
  1324.       loop                                                                      \
  1325.         { var reg3 object* argptr = args_pointer;                               \
  1326.           var reg5 object fun = NEXT(argptr);                                   \
  1327.           var reg4 uintC count;                                                 \
  1328.           dotimespC(count,argcount,                                             \
  1329.             { var reg2 object* next_list_ = &NEXT(argptr);                      \
  1330.               var reg1 object next_list = *next_list_;                          \
  1331.               if (atomp(next_list)) goto fertig; # eine Liste zu Ende -> fertig \
  1332.               pushSTACK(listaccess(next_list)); # als Argument auf den Stack    \
  1333.               *next_list_ = Cdr(next_list); # Liste verkürzen                   \
  1334.             });                                                                 \
  1335.           funcall(fun,argcount); # Funktion aufrufen                            \
  1336.         }                                                                       \
  1337.       fertig:                                                                   \
  1338.       value1 = *ergptr; mv_count=1; # 1. Liste als Wert                         \
  1339.       set_args_end_pointer(args_pointer); # STACK aufräumen                     \
  1340.     }}
  1341.  
  1342. #ifdef MAP_REVERSES
  1343.  
  1344. # Macro für MAPCAN und MAPCON
  1345.   #define MAPCAN_MAPCON_BODY(listaccess)  \
  1346.     { var reg7 object* args_pointer = rest_args_pointer STACKop 2;              \
  1347.       argcount++; # argcount := Anzahl der Listen auf dem Stack                 \
  1348.       # Platz für die Funktionsaufruf-Argumente reservieren:                    \
  1349.       get_space_on_STACK(sizeof(object)*(uintL)argcount);                       \
  1350.       pushSTACK(NIL); # Anfang der Ergebnisliste                                \
  1351.      {var reg6 object* ergptr = &STACK_0; # Pointer darauf                      \
  1352.       # alle Listen parallel durchlaufen:                                       \
  1353.       loop                                                                      \
  1354.         { var reg3 object* argptr = args_pointer;                               \
  1355.           var reg5 object fun = NEXT(argptr);                                   \
  1356.           var reg4 uintC count;                                                 \
  1357.           dotimespC(count,argcount,                                             \
  1358.             { var reg2 object* next_list_ = &NEXT(argptr);                      \
  1359.               var reg1 object next_list = *next_list_;                          \
  1360.               if (atomp(next_list)) goto fertig; # eine Liste zu Ende -> fertig \
  1361.               pushSTACK(listaccess(next_list)); # als Argument auf den Stack    \
  1362.               *next_list_ = Cdr(next_list); # Liste verkürzen                   \
  1363.             });                                                                 \
  1364.           funcall(fun,argcount); # Funktion aufrufen                            \
  1365.           STACK_0 = nreconc(value1,STACK_0); # Ergebnis anhängen                \
  1366.         }                                                                       \
  1367.       fertig:                                                                   \
  1368.       value1 = nreconc(*ergptr,NIL); mv_count=1; # Ergebnisliste umdrehen       \
  1369.       set_args_end_pointer(args_pointer); # STACK aufräumen                     \
  1370.     }}
  1371.  
  1372. #else
  1373.  
  1374. # Macro für MAPCAN und MAPCON
  1375.   #define MAPCAN_MAPCON_BODY(listaccess)  \
  1376.     { var reg7 object* args_pointer = rest_args_pointer STACKop 2;              \
  1377.       argcount++; # argcount := Anzahl der Listen auf dem Stack                 \
  1378.       # Platz für die Funktionsaufruf-Argumente reservieren:                    \
  1379.       get_space_on_STACK(sizeof(object)*(uintL)argcount);                       \
  1380.       # Gesamtliste anfangen:                                                   \
  1381.       {var reg1 object new_cons = allocate_cons(); # (CONS NIL NIL)             \
  1382.        pushSTACK(new_cons); # Gesamtliste                                       \
  1383.        pushSTACK(new_cons); # (last Gesamtliste)                                \
  1384.       }                                                                         \
  1385.      {var reg6 object* ergptr = &STACK_1; # Pointer darauf                      \
  1386.       # alle Listen parallel durchlaufen:                                       \
  1387.       loop                                                                      \
  1388.         { var reg3 object* argptr = args_pointer;                               \
  1389.           var reg5 object fun = NEXT(argptr);                                   \
  1390.           var reg4 uintC count;                                                 \
  1391.           dotimespC(count,argcount,                                             \
  1392.             { var reg2 object* next_list_ = &NEXT(argptr);                      \
  1393.               var reg1 object next_list = *next_list_;                          \
  1394.               if (atomp(next_list)) goto fertig; # eine Liste zu Ende -> fertig \
  1395.               pushSTACK(listaccess(next_list)); # als Argument auf den Stack    \
  1396.               *next_list_ = Cdr(next_list); # Liste verkürzen                   \
  1397.             });                                                                 \
  1398.           funcall(fun,argcount); # Funktion aufrufen                            \
  1399.          {var reg1 object list = value1; # anzuhängende Liste                   \
  1400.           if (consp(list))                                                      \
  1401.             { Cdr(STACK_0) = list; # als (cdr (last Gesamtliste)) einhängen     \
  1402.               while (mconsp(Cdr(list))) { list = Cdr(list); }                   \
  1403.               STACK_0 = list; # und (last Gesamtliste) := (last list)           \
  1404.         }}  }                                                                   \
  1405.       fertig:                                                                   \
  1406.       value1 = Cdr(*ergptr); mv_count=1; # Ergebnisliste ohne Header-Cons       \
  1407.       set_args_end_pointer(args_pointer); # STACK aufräumen                     \
  1408.     }}
  1409.  
  1410. #endif
  1411.  
  1412. #define Identity
  1413.  
  1414. LISPFUN(mapcar,2,0,rest,nokey,0,NIL)
  1415. # (MAPCAR fun list {list}), CLTL S. 128
  1416.   MAPCAR_MAPLIST_BODY(Car)
  1417.  
  1418. LISPFUN(maplist,2,0,rest,nokey,0,NIL)
  1419. # (MAPLIST fun list {list}), CLTL S. 128
  1420.   MAPCAR_MAPLIST_BODY(Identity)
  1421.  
  1422. LISPFUN(mapc,2,0,rest,nokey,0,NIL)
  1423. # (MAPC fun list {list}), CLTL S. 128
  1424.   MAPC_MAPL_BODY(Car)
  1425.  
  1426. LISPFUN(mapl,2,0,rest,nokey,0,NIL)
  1427. # (MAPL fun list {list}), CLTL S. 128
  1428.   MAPC_MAPL_BODY(Identity)
  1429.  
  1430. LISPFUN(mapcan,2,0,rest,nokey,0,NIL)
  1431. # (MAPCAN fun list {list}), CLTL S. 128
  1432.   MAPCAN_MAPCON_BODY(Car)
  1433.  
  1434. LISPFUN(mapcon,2,0,rest,nokey,0,NIL)
  1435. # (MAPCON fun list {list}), CLTL S. 128
  1436.   MAPCAN_MAPCON_BODY(Identity)
  1437.  
  1438. LISPSPECFORM(tagbody, 0,0,body)
  1439. # (TAGBODY {tag | statement}), CLTL S. 130
  1440.   { var reg5 object body = popSTACK();
  1441.     # GENV-Frame aufbauen:
  1442.     { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  1443.       pushSTACK(aktenv.go_env);
  1444.       finish_frame(ENV1G);
  1445.     }
  1446.     # TAGBODY-Frame aufbauen:
  1447.    {var reg6 object* top_of_frame = STACK; # Pointer übern Frame
  1448.     # Body durchparsen und Tags im Stack ablegen:
  1449.     var reg4 uintL tagcount = 0;
  1450.     { var reg3 object body_rest = body;
  1451.       while (consp(body_rest))
  1452.         { var reg2 object item = Car(body_rest);
  1453.           body_rest = Cdr(body_rest);
  1454.           # Als Tags werden Symbole /=NIL sowie Zahlen angesehen
  1455.           # (wie im Compiler), Conses sind Statements.
  1456.           if (atomp(item))
  1457.             { if (numberp(item) || (symbolp(item) && (!nullp(item))))
  1458.                 # Marke im Stack ablegen:
  1459.                 { check_STACK();
  1460.                   pushSTACK(body_rest); # Body-Rest nach der Marke
  1461.                   pushSTACK(item);
  1462.                   tagcount++;
  1463.                 }
  1464.                 else
  1465.                 { pushSTACK(item);
  1466.                   pushSTACK(S(tagbody));
  1467.                   //: DEUTSCH "~: ~ ist weder Marke noch Statement."
  1468.                   //: ENGLISH "~: ~ is neither tag nor form"
  1469.                   //: FRANCAIS "~: ~ n'est ni un marqueur ni une forme à evaluer."
  1470.                   fehler(program_error,GETTEXT("~: ~ is neither tag nor form"));
  1471.                 }
  1472.     }   }   }
  1473.     if (tagcount>0)
  1474.       { var jmp_buf returner; # Rücksprungpunkt
  1475.         pushSTACK(aktenv.go_env); # aktuelles GO_ENV als NEXT_ENV
  1476.         finish_entry_frame(ITAGBODY,&!returner,_EMA_, goto go_entry; );
  1477.         # GO_ENV erweitern:
  1478.         aktenv.go_env = make_framepointer(STACK);
  1479.         if (FALSE)
  1480.           { go_entry: # Hierher wird gesprungen, wenn dieser Frame ein GO
  1481.                       # gefangen hat.
  1482.             body = value1; # Die Formenliste wird als value1 übergeben.
  1483.           }
  1484.         # Statements abarbeiten:
  1485.         pushSTACK(body);
  1486.         while (mconsp(STACK_0))
  1487.           { var reg1 object body_rest = STACK_0;
  1488.             STACK_0 = Cdr(body_rest); # restlicher Body
  1489.             body_rest = Car(body_rest); # nächstes Item
  1490.             if (consp(body_rest)) { eval(body_rest); } # Form -> auswerten
  1491.           }
  1492.         skipSTACK(1); # Body vergessen
  1493.         unwind(); # TAGBODY-Frame auflösen
  1494.         unwind(); # GENV-Frame auflösen
  1495.       }
  1496.       else
  1497.       # Body ohne Tags -> nur PROGN mit Wert NIL
  1498.       { skipSTACK(2); # GENV-Frame wieder auflösen, GENV ist unverändert
  1499.         pushSTACK(body); implicit_prog();
  1500.       }
  1501.     value1 = NIL; mv_count=1; # Wert NIL
  1502.   }}
  1503.  
  1504.   local void fehler_control_error (object tag,object go);
  1505.   local void fehler_control_error(tag,go)
  1506.     var object tag;
  1507.     var object go;
  1508.     {
  1509.        pushSTACK(tag);
  1510.        pushSTACK(go);
  1511.         //: DEUTSCH "~: Tagbody zur Marke ~ wurde bereits verlassen."
  1512.         //: ENGLISH "~: tagbody for tag ~ has already been left"
  1513.         //: FRANCAIS "~: Le TAGBODY du marqueur ~ a déjà été quitté."
  1514.        fehler(control_error,GETTEXT("~: tagbody for tag ~ has already been left"));
  1515.     }
  1516.  
  1517. LISPSPECFORM(go, 1,0,nobody)
  1518. # (GO tag), CLTL S. 133
  1519.   { var reg3 object tag = popSTACK();
  1520.     if (!(numberp(tag) || (symbolp(tag) && (!nullp(tag)))))
  1521.       { pushSTACK(tag);
  1522.         pushSTACK(S(go));
  1523.         //: DEUTSCH "~: ~ ist keine zulässige Marke."
  1524.         //: ENGLISH "~: illegal tag ~"
  1525.         //: FRANCAIS "~: ~ n'est pas un marqueur permis."
  1526.         fehler(program_error,GETTEXT("~: illegal tag ~"));
  1527.       }
  1528.     # GO_ENV durchgehen:
  1529.    {var reg7 object env = aktenv.go_env; # aktuelles GO_ENV
  1530.     var reg8 object* FRAME;
  1531.     while (stack_env_p(env))
  1532.       { # env ist ein Frame-Pointer auf einen ITAGBODY-Frame im Stack.
  1533.         FRAME = uTheFramepointer(env);
  1534.         if (mtypecode(FRAME_(0)) & bit(nested_bit_t))
  1535.           # Frame schon genestet
  1536.           { env = FRAME_(frame_next_env); break; }
  1537.         # Tags im ungenesteten ITAGBODY-Frame absuchen:
  1538.         { var reg1 object* bind_ptr = &FRAME_(frame_bindings); # Pointer unter die Tagbindungen
  1539.           var reg2 object* bindend_ptr = STACKpointable(topofframe(FRAME_(0))); # Pointer über die Tagbindungen
  1540.           do { if (eql(*bind_ptr,tag)) # Tag gefunden?
  1541.                  { value1 = *(bind_ptr STACKop 1); # Formenliste aus dem Frame holen
  1542.                    goto found;
  1543.                  }
  1544.                bind_ptr skipSTACKop 2;
  1545.              }
  1546.              until (bind_ptr==bindend_ptr);
  1547.         }
  1548.         env = FRAME_(frame_next_env);
  1549.       }
  1550.     # env ist eine Aliste.
  1551.     while (consp(env))
  1552.       { var reg6 object tagbody_cons = Car(env);
  1553.         var reg5 object tagbody_vec = Car(tagbody_cons); # Tag-Vektor
  1554.         var reg1 object* tagptr = &TheSvector(tagbody_vec)->data[0];
  1555.         var reg4 uintL index = 0;
  1556.         var reg2 uintL count;
  1557.         dotimespL(count,TheSvector(tagbody_vec)->length,
  1558.           { if (eql(*tagptr++,tag)) # Tag gefunden?
  1559.               { env = Cdr(tagbody_cons);
  1560.                 if (eq(env,disabled)) # Tagbody noch aktiv?
  1561.                   fehler_control_error (tag,S(go));
  1562.                 FRAME = uTheFramepointer(env); # Pointer auf den (noch aktiven!) Frame
  1563.                 value1 = FRAME_(frame_bindings+2*index+1); # Formenliste
  1564.                 goto found;
  1565.               }
  1566.             index++;
  1567.           });
  1568.         env = Cdr(env);
  1569.       }
  1570.     # env ist zu Ende.
  1571.     pushSTACK(tag);
  1572.     pushSTACK(S(go));
  1573.     //: DEUTSCH "~: Es ist keine Marke namens ~ sichtbar."
  1574.     //: ENGLISH "~: no tag named ~ is currently visible"
  1575.     //: FRANCAIS "~: Aucun marqueur de nom ~ n'est visible."
  1576.     fehler(program_error,GETTEXT("~: no tag named ~ is currently visible"));
  1577.     # Tagbody-Frame gefunden. FRAME ist ein Pointer auf ihn (ohne Typinfo),
  1578.     # value1 die Liste der auszuführenden Formen.
  1579.     found:
  1580.     mv_count=1; # Formenliste value1 wird übergeben
  1581.     # Zum gefundenen Tagbody-Frame springen und dort weitermachen:
  1582.     unwind_upto(FRAME);
  1583.   }}
  1584.  
  1585. # Fehlermeldung bei zu vielen Werten
  1586. # fehler_mv_zuviel(caller);
  1587. # > caller: Aufrufer, ein Symbol
  1588.   nonreturning_function(global, fehler_mv_zuviel, (object caller));
  1589.   global void fehler_mv_zuviel(caller)
  1590.     var reg1 object caller;
  1591.     { pushSTACK(caller);
  1592.       //: DEUTSCH "~: Zu viele Werte."
  1593.       //: ENGLISH "~: too many values"
  1594.       //: FRANCAIS "~: Trop de valeurs."
  1595.       fehler(error,GETTEXT("~: too many values"));
  1596.     }
  1597.  
  1598. LISPFUN(values,0,0,rest,nokey,0,NIL)
  1599. # (VALUES {arg}), CLTL S. 134
  1600.   { if (argcount >= mv_limit) { fehler_mv_zuviel(S(values)); }
  1601.     STACK_to_mv(argcount);
  1602.   }
  1603.  
  1604. LISPFUNN(values_list,1)
  1605. # (VALUES-LIST list), CLTL S. 135
  1606.   { list_to_mv(popSTACK(), fehler_mv_zuviel(S(values_list)); ); }
  1607.  
  1608. LISPSPECFORM(multiple_value_list, 1,0,nobody)
  1609. # (MULTIPLE-VALUE-LIST form), CLTL S. 135
  1610.   { eval(popSTACK()); # form auswerten
  1611.     mv_to_list(); # Werte in Liste packen
  1612.     value1 = popSTACK(); mv_count=1; # Liste als Wert
  1613.   }
  1614.  
  1615. LISPSPECFORM(multiple_value_call, 1,0,body)
  1616. # (MULTIPLE-VALUE-CALL fun {form}), CLTL S. 135
  1617.   { var reg3 object* fun_ = &STACK_1;
  1618.     *fun_ = (eval(*fun_),value1); # Funktion auswerten
  1619.    {var reg1 object forms = popSTACK(); # Formenliste
  1620.     var reg2 uintL argcount = 0; # Anzahl der bisherigen Argumente
  1621.     while (consp(forms))
  1622.       { pushSTACK(Cdr(forms)); # restliche Formen
  1623.         eval(Car(forms)); # nächste Form auswerten
  1624.         forms = popSTACK();
  1625.         # Deren Werte in den Stack:
  1626.         argcount += (uintL)mv_count;
  1627.         mv_to_STACK();
  1628.       }
  1629.     if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
  1630.       { pushSTACK(*fun_);
  1631.         pushSTACK(S(multiple_value_call));
  1632.         //: DEUTSCH "~: Zu viele Argumente für ~"
  1633.         //: ENGLISH "~: too many arguments to ~"
  1634.         //: FRANCAIS "~: Trop d'arguments pour ~."
  1635.         fehler(error,GETTEXT("~: too many arguments to ~"));
  1636.       }
  1637.     funcall(*fun_,argcount); # Funktion aufrufen
  1638.     skipSTACK(1);
  1639.   }}
  1640.  
  1641. LISPSPECFORM(multiple_value_prog1, 1,0,body)
  1642. # (MULTIPLE-VALUE-PROG1 form {form}), CLTL S. 136
  1643.   {  eval(STACK_1); # erste Form auswerten
  1644.    { var reg3 object body = popSTACK();
  1645.      skipSTACK(1);
  1646.     {var reg2 uintC mvcount = mv_count; # Wertezahl
  1647.      mv_to_STACK(); # alle Werte in den Stack
  1648.      pushSTACK(body); implicit_prog();
  1649.      STACK_to_mv(mvcount); # alle Werte wieder aus dem Stack zurückholen
  1650.   }}}
  1651.  
  1652. LISPSPECFORM(multiple_value_bind, 2,0,body)
  1653. # (MULTIPLE-VALUE-BIND ({var}) values-form {decl} {form}), CLTL S. 136
  1654.   { # {decl} {form} trennen:
  1655.     var reg10 boolean to_compile = parse_dd(STACK_0,aktenv.var_env,aktenv.fun_env); # unvollständiges var_env??
  1656.     # bitte kein Docstring:
  1657.     if (!nullp(value3)) { fehler_docstring(S(multiple_value_bind),STACK_0); }
  1658.     if (to_compile) # Deklaration (COMPILE) ?
  1659.       # ja -> Form kompilieren:
  1660.       { skipSTACK(3); return_Values compile_eval_form(); }
  1661.       else
  1662.       { var reg10 object varlist = STACK_2;
  1663.         STACK_2 = STACK_1;
  1664.         skipSTACK(2);
  1665.         # Variablenbindungsframe aufbauen, VAR_ENV erweitern:
  1666.        {var reg9 object* form_ = &STACK_0;
  1667.         var object* bind_ptr;
  1668.         var uintC bind_count;
  1669.         make_variable_frame(S(multiple_value_bind),varlist,&bind_ptr,&bind_count);
  1670.         # Stackaufbau: values-form, Variablenbindungsframe, Env-Bindungs-Frame, ({form}).
  1671.         # Dann values-form auswerten:
  1672.         eval(*form_);
  1673.         # Macro zum Binden von Variablen im Variablenframe:
  1674.         # Bindet die nächste Variable an value, erniedrigt frame_pointer um 2 bzw. 3.
  1675.         #define bind_next_var(value)  \
  1676.           { var reg3 object* valptr = &Next(frame_pointer);                   \
  1677.             frame_pointer skipSTACKop -varframe_binding_size;                 \
  1678.            {var reg2 object* markptr = &Before(frame_pointer);                \
  1679.             if (*(oint*)(markptr) & wbit(dynam_bit_o))                        \
  1680.               # dynamische Bindung aktivieren:                                \
  1681.               { var reg4 object sym = *(markptr STACKop varframe_binding_sym); # Variable \
  1682.                 *valptr = Symbolflagged_value(sym); # alten Wert in den Frame      \
  1683.                 *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren             \
  1684.                 set_Symbolflagged_value_on(sym,value,markptr); # neuen Wert in die Wertzelle  \
  1685.               }                                                               \
  1686.               else                                                            \
  1687.               # statische Bindung aktivieren:                                 \
  1688.               { *valptr = (value); # neuen Wert in den Frame                  \
  1689.                 *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren \
  1690.               }                                                               \
  1691.           }}
  1692.         # Die r:=bind_count Variablen an die s:=mv_count Werte binden:
  1693.         # (Falls die Variablen ausgehen: restliche Werte wegwerfen;
  1694.         #  falls die Werte ausgehen: mit NIL auffüllen.)
  1695.         # Hier r>=0 und s>=0.
  1696.         { var reg5 object* frame_pointer = bind_ptr;
  1697.           var reg7 uintC r = bind_count;
  1698.           var reg6 object* mv_pointer;
  1699.           var reg8 uintC s = mv_count;
  1700.           if (r==0) goto ok; # keine Variablen?
  1701.           if (s==0) goto fill; # keine Werte?
  1702.           # noch min(r,s)>0 Werte binden:
  1703.           #if !defined(VALUE1_EXTRA)
  1704.           mv_pointer = &mv_space[0];
  1705.           #else
  1706.           bind_next_var(value1);
  1707.           if (--r == 0) goto ok; # keine Variablen mehr?
  1708.           if (--s == 0) goto fill; # keine Werte mehr?
  1709.           mv_pointer = &mv_space[1];
  1710.           #endif
  1711.           # noch min(r,s)>0 Werte binden:
  1712.           loop
  1713.             { bind_next_var(*mv_pointer++);
  1714.               if (--r == 0) goto ok; # keine Variablen mehr?
  1715.               if (--s == 0) goto fill; # keine Werte mehr?
  1716.             }
  1717.           fill: # Noch r>0 Variablen an NIL binden
  1718.           dotimespC(r,r, { bind_next_var(NIL); } );
  1719.           ok: ;
  1720.         }
  1721.         # Body abinterpretieren:
  1722.         implicit_progn(popSTACK(),NIL);
  1723.         # Frames auflösen:
  1724.         unwind(); # VENV-Bindungsframe auflösen
  1725.         unwind(); # Variablenbindungs-Frame auflösen
  1726.         skipSTACK(1);
  1727.   }   }}
  1728.  
  1729. LISPSPECFORM(multiple_value_setq, 2,0,nobody)
  1730. # (MULTIPLE-VALUE-SETQ ({var}) form), CLTL S. 136
  1731.   { {var reg2 object varlist = STACK_1;
  1732.      # Variablenliste durchgehen:
  1733.      while (consp(varlist))
  1734.        { var reg1 object symbol = Car(varlist); # nächste Variable
  1735.          if (!symbolp(symbol)) # sollte ein Symbol
  1736.            { fehler_kein_symbol(S(multiple_value_setq),symbol); }
  1737.          if (constantp(TheSymbol(symbol))) # und keine Konstante sein
  1738.            { fehler_symbol_constant(S(multiple_value_setq),symbol); }
  1739.          if (sym_macrop(symbol)) # und kein Symbol-Macro
  1740.            goto expand;
  1741.          varlist = Cdr(varlist);
  1742.     }  }
  1743.     if (FALSE)
  1744.       { expand:
  1745.         pushSTACK(STACK_0); STACK_1 = STACK_2; STACK_2 = S(multiple_value_setf);
  1746.        {var reg1 object newform = listof(3); # aus MULTIPLE-VALUE-SETQ mache MULTIPLE-VALUE-SETF
  1747.         eval(newform);
  1748.       }}
  1749.       else
  1750.       {  eval(popSTACK()); # form auswerten
  1751.        { var reg4 object varlist = popSTACK();
  1752.          var reg5 object* args_end = args_end_pointer;
  1753.          mv_to_STACK(); # Werte in den Stack schreiben (erleichtert den Zugriff)
  1754.          # Variablenliste durchgehen:
  1755.         {var reg1 object* mvptr = args_end;
  1756.          var reg3 uintC count = mv_count; # Anzahl noch verfügbarer Werte
  1757.          while (consp(varlist))
  1758.            { var reg2 object value;
  1759.              if (count>0)
  1760.                { value = NEXT(mvptr); count--; } # nächster Wert
  1761.                else
  1762.                { value = NIL; } # NIL, wenn alle Werte verbraucht
  1763.              setq(Car(varlist),value); # der nächsten Variablen zuweisen
  1764.              varlist = Cdr(varlist);
  1765.            }
  1766.          set_args_end_pointer(args_end); # STACK aufräumen
  1767.          mv_count=1; # letzter value1 als einziger Wert
  1768.   }   }}}
  1769.  
  1770. LISPSPECFORM(catch, 1,0,body)
  1771. # (CATCH tag {form}), CLTL S. 139
  1772.   { STACK_1 = (eval(STACK_1),value1); # tag auswerten
  1773.     # CATCH-Frame zu Ende aufbauen:
  1774.    {var reg1 object body = popSTACK(); # ({form})
  1775.     var reg2 object* top_of_frame = STACK STACKop 1; # Pointer übern Frame
  1776.     var jmp_buf returner; # Rücksprungpunkt merken
  1777.     finish_entry_frame(CATCH,&!returner,_EMA_, goto catch_return; );
  1778.     # Body ausführen:
  1779.     implicit_progn(body,NIL);
  1780.     catch_return: # Hierher wird gesprungen, wenn der oben aufgebaute
  1781.                   # Catch-Frame einen Throw gefangen hat.
  1782.     skipSTACK(3); # CATCH-Frame auflösen
  1783.   }}
  1784.  
  1785. LISPSPECFORM(unwind_protect, 1,0,body)
  1786. # (UNWIND-PROTECT form {cleanup}), CLTL S. 140
  1787.   { var reg2 object cleanup = popSTACK();
  1788.     var reg3 object form = popSTACK();
  1789.     # UNWIND-PROTECT-Frame aufbauen:
  1790.     pushSTACK(cleanup);
  1791.    {var reg4 object* top_of_frame = STACK;
  1792.     var jmp_buf returner; # Rücksprungpunkt
  1793.     finish_entry_frame(UNWIND_PROTECT,&!returner,_EMA_, goto throw_save; );
  1794.     # Protected form auswerten:
  1795.     eval(form);
  1796.     # Cleanup nach normaler Beendigung der Protected form:
  1797.       # UNWIND-PROTECT-Frame auflösen:
  1798.       skipSTACK(2);
  1799.       cleanup = popSTACK();
  1800.       # Werte retten:
  1801.      {var reg1 uintC mvcount = mv_count;
  1802.       mv_to_STACK();
  1803.       # Cleanup-Formen abarbeiten:
  1804.       pushSTACK(cleanup); implicit_prog();
  1805.       # Werte zurückschreiben:
  1806.       STACK_to_mv(mvcount);
  1807.      }
  1808.     return;
  1809.     throw_save: # Hierher wird gesprungen, wenn der oben aufgebaute
  1810.                 # Unwind-Protect-Frame einen Throw aufgehalten hat.
  1811.                 # unwind_protect_to_save ist zu retten und am Schluß anzuspringen.
  1812.     { var reg5 restart fun = unwind_protect_to_save.fun;
  1813.       var reg6 object* arg = unwind_protect_to_save.upto_frame;
  1814.     # Cleanup:
  1815.       # UNWIND-PROTECT-Frame auflösen:
  1816.       skipSTACK(2);
  1817.       cleanup = popSTACK();
  1818.       # Werte retten:
  1819.      {var reg1 uintC mvcount = mv_count;
  1820.       mv_to_STACK();
  1821.       # Cleanup-Formen abarbeiten:
  1822.       pushSTACK(cleanup); implicit_prog();
  1823.       # Werte zurückschreiben:
  1824.       STACK_to_mv(mvcount);
  1825.      }# und weiterspringen:
  1826.       fun(arg);
  1827.     }
  1828.   }}
  1829.  
  1830. LISPSPECFORM(throw, 2,0,nobody)
  1831. # (THROW tag result), CLTL S. 142
  1832.   { STACK_1 = (eval(STACK_1),value1); # tag auswerten
  1833.     eval(popSTACK()); # result auswerten
  1834.    {var reg1 object tag = popSTACK(); # ausgewertetes Tag
  1835.     throw(tag); # versuche auf dieses zu THROWen
  1836.     # Nicht gelungen.
  1837.     pushSTACK(tag);
  1838.     pushSTACK(S(throw));
  1839.     //: DEUTSCH "~: Es gibt kein CATCH zur Marke ~."
  1840.     //: ENGLISH "~: there is no CATCHer for tag ~"
  1841.     //: FRANCAIS "~: Il n'y a pas de CATCH correspondant au marqueur ~."
  1842.     fehler(control_error,GETTEXT("~: there is no CATCHer for tag ~"));
  1843.   }}
  1844.  
  1845. LISPFUNN(driver,1)
  1846. # (SYS::DRIVER fun) baut einen Driver-Frame auf, der jedesmal die Funktion
  1847. # fun (mit 0 Argumenten) aufruft. fun wird in einer Endlosschleife ausgeführt,
  1848. # die mit GO oder THROW abgebrochen werden kann.
  1849.   { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  1850.     var DRIVER_frame_data returner_and_data; # Einsprungpunkt merken
  1851.     #ifdef HAVE_NUM_STACK
  1852.     returner_and_data.old_NUM_STACK_normal = NUM_STACK_normal;
  1853.     #endif
  1854.     finish_entry_frame(DRIVER,&!returner_and_data.returner,_EMA_,;);
  1855.     # Hier ist der Einsprungpunkt.
  1856.     loop { funcall(STACK_(0+2),0); } # fun aufrufen, Endlosschleife
  1857.   }
  1858.  
  1859. LISPFUNN(unwind_to_driver,0)
  1860. # (SYS::UNWIND-TO-DRIVER) macht ein UNWIND bis zum nächsthöheren Driver-Frame.
  1861.   { reset(); }
  1862.  
  1863. # Überprüft ein optionales Macroexpansions-Environment in STACK_0.
  1864. # > STACK_0: Argument
  1865. # < STACK_0: Macroexpansions-Environment #(venv fenv)
  1866. # kann GC auslösen
  1867.   local void test_env (void);
  1868.   local void test_env()
  1869.     { var reg1 object arg = STACK_0;
  1870.       if (eq(arg,unbound))
  1871.         { STACK_0 = allocate_vector(2); } # Vektor #(nil nil) als Default
  1872.       elif (!(simple_vector_p(arg) && (TheSvector(arg)->length == 2)))
  1873.         { pushSTACK(arg); # Wert für Slot DATUM von TYPE-ERROR
  1874.           pushSTACK(O(type_svector2)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  1875.           pushSTACK(arg);
  1876.           //: DEUTSCH "Argument ~ ist kein Macroexpansions-Environment."
  1877.           //: ENGLISH "Argument ~ is not a macroexpansion environment"
  1878.           //: FRANCAIS "L'argument ~ n'est pas un environnement pour macros"
  1879.           fehler(type_error,GETTEXT("Argument ~ is not a macroexpansion environment"));
  1880.     }   }
  1881.  
  1882. LISPFUNN(macro_function,1)
  1883. # (MACRO-FUNCTION symbol), CLTL S. 144
  1884.   { var reg3 object symbol = popSTACK();
  1885.     if (!symbolp(symbol)) { fehler_symbol(symbol); }
  1886.    {var reg2 object fundef = Symbol_function(symbol); # globale Funktionsdefinition
  1887.     if (fsubrp(fundef))
  1888.       # ein FSUBR -> Propertyliste absuchen: (GET symbol 'SYS::MACRO)
  1889.       { var reg1 object got = get(symbol,S(macro)); # suchen
  1890.         if (eq(got,unbound)) goto nil; # nichts gefunden?
  1891.         value1 = got;
  1892.       }
  1893.     elif (consp(fundef) && eq(Car(fundef),S(macro))) # (SYS::MACRO . expander) ?
  1894.       { value1 = Cdr(fundef); }
  1895.     else # SUBR/Closure/#<UNBOUND> -> keine Macrodefinition
  1896.       { nil: value1 = NIL; }
  1897.     mv_count=1;
  1898.   }}
  1899.  
  1900. LISPFUN(macroexpand,1,1,norest,nokey,0,NIL)
  1901. # (MACROEXPAND form [env]), CLTL S. 151
  1902.   { test_env();
  1903.    {var reg1 object env = popSTACK();
  1904.     var reg2 object form = STACK_0;
  1905.     STACK_0 = env; # env retten
  1906.     macroexp0(form,env); # expandieren
  1907.     if (!nullp(value2)) # was getan?
  1908.       # ja -> zu Tode expandieren:
  1909.       { do { macroexp0(value1,STACK_0); } until (nullp(value2));
  1910.         value2 = T;
  1911.       }
  1912.     mv_count=2; skipSTACK(1);
  1913.   }}
  1914.  
  1915. LISPFUN(macroexpand_1,1,1,norest,nokey,0,NIL)
  1916. # (MACROEXPAND-1 form [env]), CLTL S. 151
  1917.   { test_env();
  1918.    {var reg1 object env = popSTACK();
  1919.     var reg2 object form = popSTACK();
  1920.     macroexp0(form,env); # 1 mal expandieren
  1921.     mv_count=2;
  1922.   }}
  1923.  
  1924. LISPSPECFORM(declare, 0,0,body)
  1925. # (DECLARE {decl-spec}), CLTL S. 153
  1926.   { # ({decl-spec}) bereits in STACK_0
  1927.     //: DEUTSCH "Deklarationen ~ an dieser Stelle nicht erlaubt."
  1928.     //: ENGLISH "declarations ~ are not allowed here"
  1929.     //: FRANCAIS "Les déclarations ~ ne sont pas permises à cet endroit."
  1930.     fehler(program_error,GETTEXT("declarations ~ are not allowed here"));
  1931.   }
  1932.  
  1933. LISPSPECFORM(the, 2,0,nobody)
  1934. # (THE value-type form), CLTL S. 161
  1935.   { eval(STACK_0); # form auswerten
  1936.     mv_to_list(); # Werteliste bilden und retten
  1937.     # Stackaufbau: value-type, form, values.
  1938.     # zum Typ-Check (SYS::%THE values value-type) aufrufen:
  1939.     pushSTACK(STACK_0); pushSTACK(STACK_(2+1)); funcall(S(pthe),2);
  1940.     if (nullp(value1))
  1941.       # Typ-Check mißlang
  1942.       { pushSTACK(STACK_(2+0)); # value-type
  1943.         pushSTACK(STACK_(0+1)); # values
  1944.         pushSTACK(STACK_(1+2)); # form
  1945.         pushSTACK(S(the));
  1946.         //: DEUTSCH "~: Die Form ~ produzierte die Werte ~, nicht vom Typ ~"
  1947.         //: ENGLISH "~: ~ evaluated to the values ~, not of type ~"
  1948.         //: FRANCAIS "~: La forme ~ a produit les valeurs ~ qui ne sont pas de type ~."
  1949.         fehler(error, GETTEXT("~: ~ evaluated to the values ~, not of type ~")); # type_error ??      
  1950.       }
  1951.     # Typ-Check OK -> Werte zurückgeben:
  1952.     list_to_mv(popSTACK(), { fehler_mv_zuviel(S(the)); } );
  1953.     skipSTACK(2);
  1954.   }
  1955.  
  1956. LISPFUNN(proclaim,1)
  1957. # (PROCLAIM decl-spec)
  1958.   { var reg3 object declspec = popSTACK();
  1959.     if (!consp(declspec))
  1960.       { pushSTACK(declspec);
  1961.         pushSTACK(S(proclaim));
  1962.         //: DEUTSCH "~: Falsche Deklaration: ~"
  1963.         //: ENGLISH "~: bad declaration ~"
  1964.         //: FRANCAIS "~: Mauvaise déclaration : ~"
  1965.         fehler(error,GETTEXT("~: bad declaration ~"));
  1966.       }
  1967.    {var reg4 object decltype = Car(declspec); # Deklarationstyp
  1968.     if (eq(decltype,S(special))) # SPECIAL
  1969.       { while (consp( declspec = Cdr(declspec) ))
  1970.           { var reg1 object symbol = Car(declspec);
  1971.             if (!symbolp(symbol)) { fehler_symbol(symbol); }
  1972.             if (!keywordp(symbol)) { clear_const_flag(TheSymbol(symbol)); }
  1973.             set_special_flag(TheSymbol(symbol));
  1974.       }   }
  1975.     elif (eq(decltype,S(declaration))) # DECLARATION
  1976.       { while (consp( declspec = Cdr(declspec) ))
  1977.           { var reg2 object symbol = Car(declspec);
  1978.             if (!symbolp(symbol)) { fehler_symbol(symbol); }
  1979.             # (PUSHNEW symbol (cdr declaration-types)) :
  1980.             { var reg1 object list = Cdr(O(declaration_types));
  1981.               while (consp(list))
  1982.                 { if (eq(Car(list),symbol)) goto not_adjoin;
  1983.                   list = Cdr(list);
  1984.             }   }
  1985.             pushSTACK(declspec); pushSTACK(symbol);
  1986.            {var reg1 object new_cons = allocate_cons();
  1987.             var reg2 object list = O(declaration_types);
  1988.             Car(new_cons) = popSTACK(); Cdr(new_cons) = Cdr(list);
  1989.             Cdr(list) = new_cons;
  1990.             declspec = popSTACK();
  1991.            }
  1992.             not_adjoin: ;
  1993.       }   }
  1994.     elif (eq(decltype,S(inline)) || eq(decltype,S(notinline))) # INLINE, NOTINLINE
  1995.       { pushSTACK(decltype);
  1996.         while (consp( declspec = Cdr(declspec) ))
  1997.           { var reg2 object symbol = Car(declspec);
  1998.             if (!funnamep(symbol)) { fehler_kein_symbol(S(proclaim),symbol); }
  1999.             # (SYS::%PUT (SYS::GET-FUNNAME-SYMBOL symbol) 'SYS::INLINABLE decltype) :
  2000.             pushSTACK(declspec);
  2001.             pushSTACK(symbol); funcall(S(get_funname_symbol),1); pushSTACK(value1);
  2002.             pushSTACK(S(inlinable));
  2003.             pushSTACK(STACK_(1+2));
  2004.             funcall(L(put),3);
  2005.             declspec = popSTACK();
  2006.           }
  2007.         skipSTACK(1);
  2008.       }
  2009.     # Alles restliche wird ignoriert.
  2010.     value1 = NIL; mv_count=1;
  2011.   }}
  2012.  
  2013. LISPFUNN(eval,1)
  2014. # (EVAL form), CLTL S. 321
  2015.   { eval_noenv(popSTACK()); } # form im leeren Environment auswerten
  2016.  
  2017. LISPSPECFORM(load_time_value, 1,1,nobody)
  2018. # (LOAD-TIME-VALUE form [read-only-p]), CLTL2 S. 680
  2019.   { var reg1 object form = STACK_1;
  2020.     skipSTACK(2); # read-only-p ignorieren
  2021.     eval_noenv(form); # form im leeren Environment auswerten
  2022.     mv_count=1;
  2023.   }
  2024.  
  2025. # UP: Überprüft ein optionales Environment-Argument für EVALHOOK und APPLYHOOK.
  2026. # test_optional_env_arg(&env5);
  2027. # > subr_self: Aufrufer (ein SUBR)
  2028. # < env5: 5 Komponenten des Environments
  2029. # erhöht STACK um 1
  2030.   local void test_optional_env_arg (environment* env5,object env);
  2031.   local void test_optional_env_arg(env5,env)
  2032.     var reg2 environment* env5;
  2033.     var reg1 object env;
  2034.     { if (eq(env,unbound)) # nicht angegeben -> leeres Environment
  2035.         { env5->var_env   = NIL;
  2036.           env5->fun_env   = NIL;
  2037.           env5->block_env = NIL;
  2038.           env5->go_env    = NIL;
  2039.           env5->decl_env  = O(top_decl_env);
  2040.         }
  2041.       elif (simple_vector_p(env) && (TheSvector(env)->length == 5))
  2042.         # ein Simple-Vector der Länge 5
  2043.         { env5->var_env   = TheSvector(env)->data[0];
  2044.           env5->fun_env   = TheSvector(env)->data[1];
  2045.           env5->block_env = TheSvector(env)->data[2];
  2046.           env5->go_env    = TheSvector(env)->data[3];
  2047.           env5->decl_env  = TheSvector(env)->data[4];
  2048.         }
  2049.       else
  2050.         { pushSTACK(env); # Wert für Slot DATUM von TYPE-ERROR
  2051.           pushSTACK(O(type_svector5)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2052.           pushSTACK(env);
  2053.           pushSTACK(TheSubr(subr_self)->name);
  2054.           //: DEUTSCH "~: ~ ist nicht als Environment geeignet."
  2055.           //: ENGLISH "~: ~ may not be used as an environment"
  2056.           //: FRANCAIS "~: ~ ne peut pas être utilisé comme environnement."
  2057.           fehler(type_error,GETTEXT("~: ~ may not be used as an environment"));
  2058.     }   }
  2059.  
  2060. LISPFUN(evalhook,3,1,norest,nokey,0,NIL)
  2061. # (EVALHOOK form evalhookfn applyhookfn [env]), CLTL S. 323
  2062.  { var reg4 object applyhookfn = STACK_1;
  2063.    var reg3 object evalhookfn = STACK_2;
  2064.    var reg2 object *form_ptr = &STACK_3;
  2065.    var reg5 object *env_ptr = &STACK_0;
  2066.    var environment env5;
  2067.  
  2068.    bindhooks(evalhookfn,applyhookfn);
  2069.    test_optional_env_arg(&env5,*env_ptr); # env-Argument nach env5
  2070.    # Environment-Frame aufbauen:
  2071.    make_ENV5_frame();
  2072.    # aktuelle Environments setzen:
  2073.    aktenv = env5;
  2074.    # form unter Umgehung von *EVALHOOK* und *APPLYHOOK* auswerten:
  2075.    eval_no_hooks(*form_ptr);
  2076.    unwind(); # Environment-Frame auflösen
  2077.    unwind(); # Bindungsframe für *EVALHOOK* / *APPLYHOOK* auflösen
  2078.    skipSTACK(4);
  2079.  }
  2080.  
  2081. LISPFUN(applyhook,4,1,norest,nokey,0,NIL)
  2082. # (APPLYHOOK function args evalhookfn applyhookfn [env]), CLTL S. 323
  2083.   { var environment env5;
  2084.     var reg2 object args;
  2085.     var reg6 object applyhookfn = STACK_1;
  2086.     var reg5 object evalhookfn = STACK_2;
  2087.     var reg1 object *args_ptr = &STACK_3;
  2088.     var reg7 object *fun_ptr = &STACK_4;
  2089.     var reg8 object *env_ptr = &STACK_0;
  2090.  
  2091.     bindhooks(evalhookfn,applyhookfn);
  2092.     test_optional_env_arg(&env5,*env_ptr); # env-Argument nach env5
  2093.     args = *args_ptr;
  2094.     # Environment-Frame aufbauen:
  2095.     make_ENV5_frame();
  2096.     # aktuelle Environments setzen:
  2097.     aktenv = env5;
  2098.     # fun retten:
  2099.     { # Argumente einzeln auswerten und auf dem Stack ablegen:
  2100.       var reg2 uintC argcount = 0;
  2101.       while (consp(args))
  2102.         { pushSTACK(Cdr(args)); # restliche Argumentliste
  2103.           eval_no_hooks(Car(args)); # nächstes arg auswerten
  2104.           args = STACK_0; STACK_0 = value1; # Wert im Stack ablegen
  2105.           argcount++;
  2106.           if (argcount==0) # Überlauf?
  2107.             { pushSTACK(*fun_ptr);
  2108.               pushSTACK(S(applyhook));
  2109.               //: DEUTSCH "~: Zu viele Argumente für ~"
  2110.               //: ENGLISH "~: too many arguments given to ~"
  2111.               //: FRANCAIS "~: Trop d'arguments fournis à ~."
  2112.               fehler(error,GETTEXT("~: too many arguments given to ~"));
  2113.         }   }
  2114.       funcall(*fun_ptr,argcount); # Funktion anwenden
  2115.     }
  2116.     unwind(); # Environment-Frame auflösen
  2117.     unwind(); # Bindungsframe für *EVALHOOK* / *APPLYHOOK* auflösen
  2118.     skipSTACK(5);
  2119.   }
  2120.  
  2121. LISPFUNN(constantp,1)
  2122. # (CONSTANTP expr), CLTL S. 324
  2123.   { var reg1 object arg = popSTACK();
  2124.     switch (typecode(arg))
  2125.       { case_cons: # Cons
  2126.           if (eq(Car(arg),S(quote))) goto ja; else goto nein;
  2127.         case_symbol: # Symbol
  2128.           if (constantp(TheSymbol(arg))) goto ja; else goto nein;
  2129.         case_number: # Zahl
  2130.         case_char: # Character
  2131.         case_string: # String
  2132.         case_bvector: # Bit-Vektor
  2133.           goto ja;
  2134.         default:
  2135.           goto nein;
  2136.       }
  2137.     ja: value1 = T; mv_count=1; return;
  2138.     nein: value1 = NIL; mv_count=1; return;
  2139.   }
  2140.  
  2141. LISPFUNN(function_name_p,1)
  2142. # (SYS::FUNCTION-NAME-P expr) erkennt Funktionsnamen
  2143.   { var reg1 object arg = popSTACK();
  2144.     value1 = (funnamep(arg) ? T : NIL); mv_count=1;
  2145.   }
  2146.  
  2147. LISPFUN(parse_body,1,2,norest,nokey,0,NIL)
  2148. # (SYS::PARSE-BODY body [docstring-allowed [env]])
  2149. # parst body, erkennt Deklarationen, liefert 3 Werte:
  2150. # 1. body-rest, alle Formen nach den Deklarationen,
  2151. # 2. Liste der aufgetretenen declspecs
  2152. # 3. docstring (nur falls docstring-allowed=T war) oder NIL.
  2153. # (docstring-allowed sollte = NIL oder T sein,
  2154. #  env sollte ein Function-Environment sein.)
  2155.   { test_env();
  2156.    {var reg5 boolean docstring_allowed = (!eq(STACK_1,unbound) && !nullp(STACK_1)); # Docstrings erlaubt?
  2157.     var reg2 object body = STACK_2; # body = ({decl|doc} {form})
  2158.     STACK_1 = NIL; # Noch war kein Doc-String da
  2159.     pushSTACK(NIL); # Anfang decl-spec-Liste
  2160.     # Stackaufbau: body, docstring, env, declspecs.
  2161.     while (consp(body))
  2162.       {  pushSTACK(body); # body retten
  2163.        { var reg1 object form = Car(body); # nächste Form
  2164.          # evtl. macroexpandieren (ohne FSUBRs, Symbole zu expandieren):
  2165.          do { var reg1 object env = STACK_(1+1);
  2166.               macroexp(form,TheSvector(env)->data[0],TheSvector(env)->data[1]);
  2167.               form = value1;
  2168.             }
  2169.             until (nullp(value2));
  2170.          body = popSTACK();
  2171.         {var reg4 object body_rest = Cdr(body); # body verkürzen
  2172.          if (stringp(form)) # Doc-String gefunden?
  2173.            { if (atomp(body_rest)) # an letzter Stelle der Formenliste?
  2174.                goto fertig; # ja -> letzte Form kann kein Doc-String sein!
  2175.              if (!docstring_allowed) # kein Doc-String erlaubt?
  2176.                { pushSTACK(STACK_3); # ganzer body
  2177.                  //: DEUTSCH "Hier sind keine Doc-Strings erlaubt: ~"
  2178.                  //: ENGLISH "no doc-strings allowed here: ~"
  2179.                  //: FRANCAIS "Les chaînes de documentation ne sont pas permises ici : ~"
  2180.                  fehler(program_error,GETTEXT("no doc-strings allowed here: ~"));
  2181.                }
  2182.              if (!nullp(STACK_2)) # schon ein Doc-String dagewesen?
  2183.                # ja -> mehr als ein Doc-String ist zuviel:
  2184.                { pushSTACK(STACK_3); # ganzer body
  2185.                  //: DEUTSCH "In ~ kommen zu viele Doc-Strings vor."
  2186.                  //: ENGLISH "Too many documentation strings in ~"
  2187.                  //: FRANCAIS "Trop de chaînes de documentation apparaîssent dans ~."
  2188.                  fehler(program_error,GETTEXT("Too many documentation strings in ~"));
  2189.                }
  2190.              STACK_2 = form; # neuer Doc-String
  2191.              body = body_rest;
  2192.            }
  2193.          elif (consp(form) && eq(Car(form),S(declare))) # Deklaration (DECLARE ...) ?
  2194.            { # neue decl-specs einzeln auf STACK_0 consen:
  2195.              pushSTACK(body_rest); # body_rest retten
  2196.              pushSTACK(Cdr(form)); # Liste der neuen decl-specs
  2197.              while (mconsp(STACK_0))
  2198.                { # Diese Deklaration auf STACK_(0+2) consen:
  2199.                  var reg3 object new_cons = allocate_cons();
  2200.                  Car(new_cons) = Car(STACK_0);
  2201.                  Cdr(new_cons) = STACK_(0+2);
  2202.                  STACK_(0+2) = new_cons;
  2203.                  # zum nächsten decl-spec:
  2204.                  STACK_0 = Cdr(STACK_0);
  2205.                }
  2206.              skipSTACK(1);
  2207.              body = popSTACK(); # body := alter body_rest
  2208.            }
  2209.          else
  2210.            { fertig: # fertig mit Durchlaufen der Formenliste
  2211.              #if 0 # Im Interpreter zwar eine gute Idee, aber der Compiler
  2212.                    # wird dadurch behindert, weil er dann CASE und HANDLER-BIND
  2213.                    # nicht so gut compilieren kann.
  2214.              if (!eq(form,Car(body))) # Sofern die Form expandiert wurde,
  2215.                # ersetze body durch (cons form (cdr body)) :
  2216.                { pushSTACK(body_rest); pushSTACK(form);
  2217.                  body = allocate_cons();
  2218.                  Car(body) = popSTACK(); # form
  2219.                  Cdr(body) = popSTACK(); # body_rest
  2220.                }
  2221.              #endif
  2222.              break;
  2223.            }
  2224.       }}}
  2225.     value1 = body;
  2226.     value2 = nreverse(popSTACK()); # decl-spec-Liste
  2227.     skipSTACK(1);
  2228.     value3 = popSTACK(); # Doc-String
  2229.     skipSTACK(1);
  2230.     mv_count=3; # 3 Werte: ({form}), declspecs, doc
  2231.   }}
  2232.  
  2233. LISPFUNN(keyword_test,2)
  2234. # (SYSTEM::KEYWORD-TEST arglist kwlist)
  2235. # stellt fest, ob in der Argumentliste arglist (eine paarige Keyword/Value -
  2236. # Liste) alle Keywords in der Liste kwlist  vorkommen oder aber
  2237. # ein Keyword/Value-Paar :ALLOW-OTHER-KEYS mit value /= NIL vorkommt.
  2238. # Wenn nein, Error.
  2239.   { var reg4 object arglist = STACK_1;
  2240.     # Argumente-Zahl überprüfen:
  2241.     { var reg1 uintL argcount = llength(arglist);
  2242.       if (!((argcount%2) == 0))
  2243.         { pushSTACK(arglist);
  2244.           //: DEUTSCH "Keyword-Argumentliste ~ hat ungerade Länge."
  2245.           //: ENGLISH "keyword argument list ~ has an odd length"
  2246.           //: FRANCAIS "La liste de mots clé ~ est de longueur impaire."
  2247.           fehler(error,GETTEXT("keyword argument list ~ has an odd length"));
  2248.     }   }
  2249.     # Suche, ob :ALLOW-OTHER-KEYS kommt:
  2250.     { var reg1 object arglistr = arglist;
  2251.       while (consp(arglistr))
  2252.         { if (eq(Car(arglistr),S(Kallow_other_keys)) && !nullp(Car(Cdr(arglistr))))
  2253.             goto fertig;
  2254.           arglistr = Cdr(Cdr(arglistr));
  2255.     }   }
  2256.     # Suche, ob alle angegebenen Keywords in kwlist vorkommen:
  2257.     { var reg3 object arglistr = arglist;
  2258.       while (consp(arglistr))
  2259.         { var reg2 object key = Car(arglistr);
  2260.           var reg1 object kwlistr = STACK_0;
  2261.           while (consp(kwlistr))
  2262.             { if (eq(Car(kwlistr),key)) goto found;
  2263.               kwlistr = Cdr(kwlistr);
  2264.             }
  2265.           # nicht gefunden
  2266.           pushSTACK(Car(Cdr(arglistr)));
  2267.           pushSTACK(key);
  2268.           //: DEUTSCH "Unzulässiges Keyword/Wert-Paar ~, ~ in einer Argumentliste. Die erlaubten Keywords sind ~"
  2269.           //: ENGLISH "illegal keyword/value pair ~, ~ in argument list. The allowed keywords are ~"
  2270.           //: FRANCAIS "Paire mot-clé - valeur ~, ~ illicite dans une liste d'arguments. Les mots-clé permis sont ~"
  2271.           fehler(error,GETTEXT("illegal keyword/value pair ~, ~ in argument list. The allowed keywords are ~"));
  2272.           found: # gefunden. Weiter:
  2273.           arglistr = Cdr(Cdr(arglistr));
  2274.     }   }
  2275.     fertig:
  2276.     skipSTACK(2);
  2277.     value1 = NIL; mv_count=0; # keine Werte
  2278.   }
  2279.  
  2280. LISPSPECFORM(and, 0,0,body)
  2281. # (AND {form}), CLTL S. 82
  2282.   { var reg1 object body = popSTACK();
  2283.     if (atomp(body))
  2284.       { value1 = T; mv_count=1; } # (AND) -> T
  2285.       else
  2286.       loop
  2287.         { pushSTACK(Cdr(body));
  2288.           eval(Car(body)); # form auswerten
  2289.           body = popSTACK();
  2290.           if (atomp(body)) break; # am Schluß: Werte der letzten Form zurück
  2291.           if (nullp(value1)) { mv_count=1; break; } # vorzeitig: 1 Wert NIL
  2292.         }
  2293.   }
  2294.  
  2295. LISPSPECFORM(or, 0,0,body)
  2296. # (OR {form}), CLTL S. 83
  2297.   { var reg1 object body = popSTACK();
  2298.     if (atomp(body))
  2299.       { value1 = NIL; mv_count=1; } # (OR) -> NIL
  2300.       else
  2301.       loop
  2302.         { pushSTACK(Cdr(body));
  2303.           eval(Car(body)); # form auswerten
  2304.           body = popSTACK();
  2305.           if (atomp(body)) break; # am Schluß: Werte der letzten Form zurück
  2306.           if (!nullp(value1)) { mv_count=1; break; } # vorzeitig: 1 Wert /=NIL
  2307.         }
  2308.   }
  2309.  
  2310. # Ab jetzt hat der Tabellenmacro eine andere Verwendung:
  2311.   #undef LISPSPECFORM
  2312.  
  2313. # Tabelle aller Fsubr-Funktionen:
  2314.   global struct fsubr_tab_ fsubr_tab =
  2315.     {
  2316.       #define LISPSPECFORM LISPSPECFORM_D
  2317.       #include "fsubr.c"
  2318.       #undef LISPSPECFORM
  2319.     };
  2320.  
  2321.