home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / eval.d < prev    next >
Encoding:
Text File  |  1996-04-18  |  382.3 KB  |  8,170 lines

  1. # Evaluator, Applyer und Bytecode-Interpreter für CLISP
  2. # Bruno Haible 13.6.1995
  3.  
  4. #include "lispbibl.c"
  5.  
  6.  
  7. # Der STACK:
  8.   #if !defined(STACK_register)
  9.     global object* STACK;
  10.   #endif
  11.   #ifdef HAVE_SAVED_STACK
  12.     global object* saved_STACK;
  13.   #endif
  14.  
  15. # MULTIPLE-VALUE-SPACE:
  16.   #if !defined(mv_count_register)
  17.     global uintC mv_count;
  18.   #endif
  19.   #ifdef NEED_temp_mv_count
  20.     global uintC temp_mv_count;
  21.   #endif
  22.   global object mv_space [mv_limit-1];
  23.   #ifdef NEED_temp_value1
  24.     global object temp_value1;
  25.   #endif
  26.  
  27. # Während der Ausführung eines SUBR, FSUBR: das aktuelle SUBR bzw. FSUBR
  28.   #if !defined(subr_self_register)
  29.     global object subr_self;
  30.   #endif
  31.   #ifdef HAVE_SAVED_SUBR_SELF
  32.     global object saved_subr_self;
  33.   #endif
  34.  
  35. # Während Callbacks die geretteten Register:
  36.   #if defined(HAVE_SAVED_REGISTERS)
  37.     global struct registers *callback_saved_registers;
  38.   #endif
  39.  
  40. # Funktionen-Tabelle:
  41. # Darin stehen nur SUBRs, die der Compiler "inline" machen darf.
  42. # In FUNTAB1 und FUNTAB2 stehen SUBRs ohne Rest-Parameter (also
  43. # mit zur Compile-Zeit bekannter fester Argumentezahl).
  44. # In FUNTABR stehen SUBRs mit Rest-Parameter.
  45.   #define _(name)  &subr_tab.D_##name  # Adresse von SUBR name, wie L(name)
  46.   # erst FUNTAB1 und FUNTAB2 :
  47.   global Subr FUNTAB[] = {
  48.     # SPVW : 0 SUBRs
  49.     # EVAL : 2 SUBRs
  50.     _(funtabref), _(subr_info),
  51.     # ARRAY : 29-2 SUBRs
  52.     /* _(svref), _(psvstore), */ _(row_major_aref), _(row_major_store),
  53.     _(array_element_type), _(array_rank), _(array_dimension),
  54.     _(array_dimensions), _(array_total_size), _(adjustable_array_p),
  55.     _(bit_and), _(bit_ior), _(bit_xor), _(bit_eqv), _(bit_nand), _(bit_nor),
  56.     _(bit_andc1), _(bit_andc2), _(bit_orc1), _(bit_orc2), _(bit_not),
  57.     _(array_has_fill_pointer_p), _(fill_pointer), _(set_fill_pointer),
  58.     _(vector_push), _(vector_pop), _(vector_push_extend), _(make_array),
  59.     _(adjust_array),
  60.     # CHARSTRG : 52 SUBRs
  61.     _(standard_char_p), _(graphic_char_p), _(string_char_p), _(alpha_char_p),
  62.     _(upper_case_p), _(lower_case_p), _(both_case_p), _(digit_char_p),
  63.     _(alphanumericp), _(char_code), _(char_bits), _(char_font), _(code_char),
  64.     _(make_char), _(character), _(char_upcase), _(char_downcase),
  65.     _(digit_char), _(char_int), _(int_char), _(char_name), _(char_bit),
  66.     _(set_char_bit), _(char), _(schar), _(store_char), _(store_schar),
  67.     _(string_gleich), _(string_ungleich), _(string_kleiner),
  68.     _(string_groesser), _(string_klgleich), _(string_grgleich),
  69.     _(string_equal), _(string_not_equal), _(string_lessp), _(string_greaterp),
  70.     _(string_not_greaterp), _(string_not_lessp), _(search_string_gleich),
  71.     _(search_string_equal), _(make_string), _(string_both_trim),
  72.     _(nstring_upcase), _(string_upcase), _(nstring_downcase),
  73.     _(string_downcase), _(nstring_capitalize), _(string_capitalize),
  74.     _(string), _(name_char), _(substring),
  75.     # CONTROL : 21-2 SUBRs
  76.     _(symbol_value), /* _(symbol_function), */ _(boundp), _(fboundp),
  77.     _(special_form_p), _(set), _(makunbound), _(fmakunbound), /* _(values_list), */
  78.     _(driver), _(unwind_to_driver), _(macro_function), _(macroexpand),
  79.     _(macroexpand_1), _(proclaim), _(eval), _(evalhook), _(applyhook),
  80.     _(constantp), _(parse_body), _(keyword_test),
  81.     # DEBUG : 1 SUBR
  82.     _(room),
  83.     # ERROR : 1 SUBR
  84.     _(invoke_debugger),
  85.     # HASHTABL : 11 SUBRs
  86.     _(make_hash_table), _(gethash), _(puthash), _(remhash), _(maphash),
  87.     _(clrhash), _(hash_table_count), _(hash_table_iterator),
  88.     _(hash_table_iterate), _(class_gethash), _(sxhash),
  89.     # IO : 36 SUBRs
  90.     _(copy_readtable), _(set_syntax_from_char), _(set_macro_character),
  91.     _(get_macro_character), _(make_dispatch_macro_character),
  92.     _(set_dispatch_macro_character), _(get_dispatch_macro_character),
  93.     _(read), _(read_preserving_whitespace), _(read_delimited_list),
  94.     _(read_line), _(read_char), _(unread_char), _(peek_char), _(listen),
  95.     _(read_char_no_hang), _(clear_input), _(read_from_string),
  96.     _(parse_integer), _(write), _(prin1), _(print), _(pprint), _(princ),
  97.     _(write_to_string), _(prin1_to_string), _(princ_to_string), _(write_char),
  98.     _(write_string), _(write_line), _(terpri), _(fresh_line),
  99.     _(finish_output), _(force_output), _(clear_output), _(line_position),
  100.     # LIST : 83-36 SUBRs
  101.     /* _(car), _(cdr), _(caar), _(cadr), _(cdar), _(cddr), _(caaar), _(caadr),
  102.     _(cadar), _(caddr), _(cdaar), _(cdadr), _(cddar), _(cdddr), _(caaaar),
  103.     _(caaadr), _(caadar), _(caaddr), _(cadaar), _(cadadr), _(caddar),
  104.     _(cadddr), _(cdaaar), _(cdaadr), _(cdadar), _(cdaddr), _(cddaar),
  105.     _(cddadr), _(cdddar), _(cddddr), _(cons), */ _(tree_equal), _(endp),
  106.     _(list_length), _(nth), /* _(first), _(second), _(third), _(fourth), */
  107.     _(fifth), _(sixth), _(seventh), _(eighth), _(ninth), _(tenth), /* _(rest), */
  108.     _(nthcdr), _(last), _(make_list), _(copy_list), _(copy_alist),
  109.     _(copy_tree), _(revappend), _(nreconc), _(list_nreverse), _(butlast),
  110.     _(nbutlast), _(ldiff), _(rplaca), _(prplaca), _(rplacd), _(prplacd),
  111.     _(subst), _(subst_if), _(subst_if_not), _(nsubst), _(nsubst_if),
  112.     _(nsubst_if_not), _(sublis), _(nsublis), _(member), _(member_if),
  113.     _(member_if_not), _(tailp), _(adjoin), _(acons), _(pairlis), _(assoc),
  114.     _(assoc_if), _(assoc_if_not), _(rassoc), _(rassoc_if), _(rassoc_if_not),
  115.     # MISC : 10 SUBRs
  116.     _(lisp_implementation_type), _(lisp_implementation_version),
  117.     _(software_type), _(software_version), _(identity), _(get_universal_time),
  118.     _(get_internal_run_time), _(get_internal_real_time), _(sleep), _(time),
  119.     # PACKAGE : 26 SUBRs
  120.     _(make_symbol), _(find_package), _(package_name), _(package_nicknames),
  121.     _(rename_package), _(package_use_list), _(package_used_by_list),
  122.     _(package_shadowing_symbols), _(list_all_packages), _(intern),
  123.     _(find_symbol), _(unintern), _(export), _(unexport), _(import),
  124.     _(shadowing_import), _(shadow), _(use_package), _(unuse_package),
  125.     _(make_package), _(pin_package), _(in_package), _(find_all_symbols),
  126.     _(map_symbols), _(map_external_symbols), _(map_all_symbols),
  127.     # PATHNAME : 27 SUBRs
  128.     _(parse_namestring), _(pathname), _(pathnamehost), _(pathnamedevice),
  129.     _(pathnamedirectory), _(pathnamename), _(pathnametype),
  130.     _(pathnameversion), _(file_namestring), _(directory_namestring),
  131.     _(host_namestring), _(merge_pathnames), _(enough_namestring),
  132.     _(make_pathname), _(namestring), _(truename), _(probe_file),
  133.     _(delete_file), _(rename_file), _(open), _(directory), _(cd),
  134.     _(make_dir), _(delete_dir), _(file_write_date), _(file_author),
  135.     _(savemem),
  136.     # PREDTYPE : 46-3 SUBRs
  137.     /* _(eq), */ _(eql), _(equal), _(equalp), _(consp), _(atom), _(symbolp),
  138.     _(stringp), _(numberp), _(compiled_function_p), /* _(null), _(not), */
  139.     _(closurep), _(listp), _(integerp), _(fixnump), _(rationalp), _(floatp),
  140.     _(short_float_p), _(single_float_p), _(double_float_p), _(long_float_p),
  141.     _(realp), _(complexp), _(streamp), _(random_state_p), _(readtablep),
  142.     _(hash_table_p), _(pathnamep), _(logical_pathname_p), _(characterp),
  143.     _(functionp), _(generic_function_p), _(packagep), _(arrayp),
  144.     _(simple_array_p), _(bit_vector_p), _(vectorp), _(simple_vector_p),
  145.     _(simple_string_p), _(simple_bit_vector_p), _(commonp), _(type_of),
  146.     _(class_of), _(find_class), _(coerce),
  147.     # RECORD : 21 SUBRs
  148.     _(record_ref), _(record_store), _(record_length), _(structure_ref),
  149.     _(structure_store), _(make_structure), _(copy_structure),
  150.     _(structure_type_p), _(closure_name), _(closure_codevec),
  151.     _(closure_consts), _(make_code_vector), _(make_closure),
  152.     _(make_load_time_eval), _(std_instance_p), _(allocate_std_instance),
  153.     _(slot_value), _(set_slot_value), _(slot_boundp), _(slot_makunbound),
  154.     _(slot_exists_p),
  155.     # SEQUENCE : 40 SUBRs
  156.     _(sequencep), _(elt), _(setelt), _(subseq), _(copy_seq), _(length),
  157.     _(reverse), _(nreverse), _(make_sequence), _(reduce), _(fill),
  158.     _(replace), _(remove), _(remove_if), _(remove_if_not), _(delete),
  159.     _(delete_if), _(delete_if_not), _(remove_duplicates),
  160.     _(delete_duplicates), _(substitute), _(substitute_if),
  161.     _(substitute_if_not), _(nsubstitute), _(nsubstitute_if),
  162.     _(nsubstitute_if_not), _(find), _(find_if), _(find_if_not), _(position),
  163.     _(position_if), _(position_if_not), _(count), _(count_if),
  164.     _(count_if_not), _(mismatch), _(search), _(sort), _(stable_sort),
  165.     _(merge),
  166.     # STREAM : 23 SUBRs
  167.     _(file_stream_p), _(make_synonym_stream), _(synonym_stream_p),
  168.     _(broadcast_stream_p), _(concatenated_stream_p), _(make_two_way_stream),
  169.     _(two_way_stream_p), _(make_echo_stream), _(echo_stream_p),
  170.     _(make_string_input_stream), _(string_input_stream_index),
  171.     _(make_string_output_stream), _(get_output_stream_string),
  172.     _(make_string_push_stream), _(string_stream_p), _(input_stream_p),
  173.     _(output_stream_p), _(stream_element_type), _(close), _(read_byte),
  174.     _(write_byte), _(file_position), _(file_length),
  175.     # SYMBOL : 15 SUBRs
  176.     _(putd), _(proclaim_constant), _(get), _(getf), _(get_properties),
  177.     _(putplist), _(put), _(remprop), _(symbol_package), _(symbol_plist),
  178.     _(symbol_name), _(keywordp), _(gensym), _(special_variable_p), _(gensym),
  179.     # LISPARIT : 84 SUBRs
  180.     _(decimal_string), _(zerop), _(plusp), _(minusp), _(oddp), _(evenp),
  181.     _(einsplus), _(einsminus), _(conjugate), _(exp), _(expt), _(log),
  182.     _(sqrt), _(isqrt), _(abs), _(phase), _(signum), _(sin), _(cos), _(tan),
  183.     _(cis), _(asin), _(acos), _(atan), _(sinh), _(cosh), _(tanh), _(asinh),
  184.     _(acosh), _(atanh), _(float), _(rational), _(rationalize), _(numerator),
  185.     _(denominator), _(floor), _(ceiling), _(truncate), _(round), _(mod),
  186.     _(rem), _(ffloor), _(fceiling), _(ftruncate), _(fround), _(decode_float),
  187.     _(scale_float), _(float_radix), _(float_sign), _(float_digits),
  188.     _(float_precision), _(integer_decode_float), _(complex), _(realpart),
  189.     _(imagpart), _(lognand), _(lognor), _(logandc1), _(logandc2), _(logorc1),
  190.     _(logorc2), _(boole), _(lognot), _(logtest), _(logbitp), _(ash),
  191.     _(logcount), _(integer_length), _(byte), _(bytesize), _(byteposition),
  192.     _(ldb), _(ldb_test), _(mask_field), _(dpb), _(deposit_field), _(random),
  193.     _(make_random_state), _(fakultaet), _(exquo), _(long_float_digits),
  194.     _(set_long_float_digits), _(log2), _(log10),
  195.     # sonstige:
  196.     };
  197.   # Das waren 528-43 SUBRs.
  198.   # Nun FUNTABR :
  199.   local Subr FUNTABR[] = {
  200.     # SPVW : 0 SUBRs
  201.     # EVAL : 0 SUBRs
  202.     # ARRAY : 7 SUBRs
  203.     _(vector), _(aref), _(store), _(array_in_bounds_p),
  204.     _(array_row_major_index), _(bit), _(sbit),
  205.     # CHARSTRG : 13 SUBRs
  206.     _(char_gleich), _(char_ungleich), _(char_kleiner), _(char_groesser),
  207.     _(char_klgleich), _(char_grgleich), _(char_equal), _(char_not_equal),
  208.     _(char_lessp), _(char_greaterp), _(char_not_greaterp), _(char_not_lessp),
  209.     _(string_concat),
  210.     # CONTROL : 10 SUBRs
  211.     _(apply), _(pfuncall), _(funcall), _(mapcar), _(maplist), _(mapc),
  212.     _(mapl), _(mapcan), _(mapcon), _(values),
  213.     # DEBUG : 0 SUBRs
  214.     # ERROR : 2 SUBRs
  215.     _(error), _(error_of_type),
  216.     # HASHTABL : 1 SUBR
  217.     _(class_tuple_gethash),
  218.     # IO : 0 SUBRs
  219.     # LIST : 4 SUBRs
  220.     _(list), _(liststern), _(append), _(nconc),
  221.     # MISC : 0 SUBRs
  222.     # PACKAGE : 0 SUBRs
  223.     # PATHNAME : 0 SUBRs
  224.     # PREDTYPE : 0 SUBRs
  225.     # RECORD : 0 SUBRs
  226.     # SEQUENCE : 6 SUBRs
  227.     _(concatenate), _(map), _(some), _(every), _(notany), _(notevery),
  228.     # STREAM : 2 SUBRs
  229.     _(make_broadcast_stream), _(make_concatenated_stream),
  230.     # SYMBOL : 0 SUBRs
  231.     # LISPARIT : 18 SUBRs
  232.     _(gleich), _(ungleich), _(kleiner), _(groesser), _(klgleich),
  233.     _(grgleich), _(max), _(min), _(plus), _(minus), _(mal), _(durch), _(gcd),
  234.     _(lcm), _(logior), _(logxor), _(logand), _(logeqv),
  235.     };
  236.   # Das waren 63 SUBRs.
  237.   #undef _
  238.   #define FUNTAB1  (&FUNTAB[0])
  239.   #define FUNTAB2  (&FUNTAB[256])
  240.   #define FUNTAB_length  (sizeof(FUNTAB)/sizeof(Subr))
  241.   #define FUNTABR_length  (sizeof(FUNTABR)/sizeof(Subr))
  242.  
  243. # Argumenttyp-Kürzel bei compilierten Closures:
  244.   typedef enum {cclos_argtype_default,
  245.                 cclos_argtype_0_0,
  246.                 cclos_argtype_1_0,
  247.                 cclos_argtype_2_0,
  248.                 cclos_argtype_3_0,
  249.                 cclos_argtype_4_0,
  250.                 cclos_argtype_5_0,
  251.                 cclos_argtype_0_1,
  252.                 cclos_argtype_1_1,
  253.                 cclos_argtype_2_1,
  254.                 cclos_argtype_3_1,
  255.                 cclos_argtype_4_1,
  256.                 cclos_argtype_0_2,
  257.                 cclos_argtype_1_2,
  258.                 cclos_argtype_2_2,
  259.                 cclos_argtype_3_2,
  260.                 cclos_argtype_0_3,
  261.                 cclos_argtype_1_3,
  262.                 cclos_argtype_2_3,
  263.                 cclos_argtype_0_4,
  264.                 cclos_argtype_1_4,
  265.                 cclos_argtype_0_5,
  266.                 cclos_argtype_0_0_rest,
  267.                 cclos_argtype_1_0_rest,
  268.                 cclos_argtype_2_0_rest,
  269.                 cclos_argtype_3_0_rest,
  270.                 cclos_argtype_4_0_rest,
  271.                 cclos_argtype_0_0_key,
  272.                 cclos_argtype_1_0_key,
  273.                 cclos_argtype_2_0_key,
  274.                 cclos_argtype_3_0_key,
  275.                 cclos_argtype_4_0_key,
  276.                 cclos_argtype_0_1_key,
  277.                 cclos_argtype_1_1_key,
  278.                 cclos_argtype_2_1_key,
  279.                 cclos_argtype_3_1_key,
  280.                 cclos_argtype_0_2_key,
  281.                 cclos_argtype_1_2_key,
  282.                 cclos_argtype_2_2_key,
  283.                 cclos_argtype_0_3_key,
  284.                 cclos_argtype_1_3_key,
  285.                 cclos_argtype_0_4_key,
  286.                 cclos_argtype_for_broken_compilers_that_dont_like_trailing_commas
  287.                }
  288.           cclos_argtype_;
  289.  
  290. # Aufruf des Bytecode-Interpreters:
  291. # Interpretiert den Bytecode einer compilierten Closure.
  292. # interpret_bytecode(closure,codevec,index);
  293. # > closure: compilierte Closure
  294. # > codevec: ihr Codevektor, ein Simple-Bit-Vector
  295. # > index: Start-Index
  296. # < mv_count/mv_space: Werte
  297. # verändert STACK, kann GC auslösen
  298.   # local Values interpret_bytecode (object closure, object codevec, uintL index);
  299.   local Values interpret_bytecode_ (object closure, Sbvector codeptr, uintB* byteptr);
  300.   #define interpret_bytecode(closure,codevec,index)  \
  301.     interpret_bytecode_(closure,TheSbvector(codevec),&TheSbvector(codevec)->data[index])
  302.  
  303. # GCC2 kann direkt zu Labels springen. Das gibt schnelleren Code als switch().
  304.   #ifdef GNU
  305.     #if (__GNUC__ >= 2) && !defined(NO_FAST_DISPATCH)
  306.       #define FAST_DISPATCH
  307.       #if (__GNUC_MINOR__ >= 7) # gcc-2.6.3 Bug umgehen (-fno-defer-pop ginge auch)
  308.         #define FAST_DISPATCH_THREADED
  309.       #endif
  310.     #endif
  311.   #endif
  312.  
  313. # Werte der Bytecodes (256 Stück):
  314.   #ifndef FAST_DISPATCH
  315.     typedef enum {
  316.                    #define BYTECODE(code)  code,
  317.                    #include "bytecode.c"
  318.                    #undef BYTECODE
  319.                    cod_for_broken_compilers_that_dont_like_trailing_commas
  320.                  }
  321.             bytecode_enum;
  322.   #endif
  323.  
  324.  
  325. #        ---------------------- LISP-FUNKTIONEN -----------------------
  326.  
  327. # (SYS::%FUNTABREF i) liefert den Namen der Funktion Nr. i aus der Funktionen-
  328. # tabelle (ein Symbol), bzw. NIL falls i nicht im richtigen Bereich liegt.
  329. LISPFUNN(funtabref,1)
  330.   { var reg2 object arg = popSTACK(); # Argument
  331.     var reg1 uintL i;
  332.     if (posfixnump(arg) # sollte ein Fixnum >=0
  333.         && (i = posfixnum_to_L(arg),
  334.             i < FUNTAB_length+FUNTABR_length # und < Tabellenlänge sein
  335.        )   )
  336.       # Name des indizierten Elements der Tabelle:
  337.       { value1 = (i < FUNTAB_length
  338.                   ? FUNTAB[i]                # aus FUNTAB1/2
  339.                   : FUNTABR[i-FUNTAB_length] # bzw. aus FUNTABR
  340.                  )->name;
  341.       }
  342.       else
  343.       { value1 = NIL; } # oder NIL
  344.     mv_count=1; # als Wert
  345.   }
  346.  
  347. # (SYS::SUBR-INFO obj) liefert, wenn obj ein SUBR (oder ein Symbol mit einem
  348. # SUBR als globaler Funktionsdefinition) ist, Information zu diesem SUBR,
  349. # 6 Werte:
  350. #   name              Name,
  351. #   req-anz           Anzahl der required-Parameter,
  352. #   opt-anz           Anzahl der optionalen Parameter,
  353. #   rest-p            Flag, ob &rest angegeben,
  354. #   keywords          Liste der zulässigen Keywords (leer: kein &key angegeben),
  355. #   allow-other-keys  Flag, ob zusätzliche Keywords erlaubt sind,
  356. # und sonst NIL.
  357. LISPFUNN(subr_info,1)
  358.   { var reg1 object obj = popSTACK();
  359.     if (!subrp(obj))
  360.       { if (!(symbolp(obj) && msubrp(Symbol_function(obj))))
  361.           { value1 = NIL; mv_count=0; return; } # kein SUBR -> kein Wert
  362.         obj = Symbol_function(obj);
  363.       }
  364.     # obj ist ein SUBR
  365.     pushSTACK(TheSubr(obj)->name); # Name
  366.     pushSTACK(fixnum(TheSubr(obj)->req_anz)); # req-anz
  367.     pushSTACK(fixnum(TheSubr(obj)->opt_anz)); # opt-anz
  368.     pushSTACK(TheSubr(obj)->rest_flag == subr_norest ? NIL : T); # rest-p
  369.     coerce_sequence(TheSubr(obj)->keywords,S(list));
  370.     pushSTACK(value1); # Keyword-Vektor als Liste
  371.     pushSTACK(TheSubr(obj)->key_flag == subr_key_allow ? T : NIL); # allow-other-keys
  372.     funcall(L(values),6); # 6 Werte
  373.   }
  374.  
  375.  
  376. LISPFUNN(find_subr,1)
  377.   { if (!msymbolp(STACK_0)) fehler_symbol(STACK_0);
  378.     value1 = Symbol_function(STACK_0);
  379.     if (!subrp(value1)) value1 = NIL;
  380.     mv_count=1;
  381.     skipSTACK(1);
  382.   }
  383.  
  384. #        ----------------------- UNTERPROGRAMME -----------------------
  385.  
  386. # UP: Löst einen Frame auf, auf den STACK zeigt.
  387. # unwind();
  388. # Die Werte mv_count/mv_space bleiben dieselben.
  389. # Falls es kein Unwind-Protect-Frame ist: kehrt normal zurück.
  390. # Falls es ein Unwind-Protect-Frame ist:
  391. #   rettet die Werte, klettert STACK und SP hoch
  392. #   und springt dann unwind_protect_to_save.fun an.
  393. # verändert STACK
  394. # kann GC auslösen
  395.   global unwind_protect_caller unwind_protect_to_save;
  396.   global void unwind (void);
  397.   global void unwind()
  398.     { var reg3 tint frame_info = mtypecode(STACK_0);
  399.       #ifdef unwind_bit_t
  400.       if (frame_info & bit(unwind_bit_t)) # überhaupt etwas zu tun?
  401.       #else
  402.       if (frame_info >= unwind_limit_t) # überhaupt etwas zu tun?
  403.       #endif
  404.         # (Nein bei APPLY, EVAL ungetrapped, CATCH, HANDLER,
  405.         #  IBLOCK und ITAGBODY ungenestet)
  406.         { if ((frame_info & bit(skip2_bit_t)) == 0) # ENV-Frame oder DYNBIND-Frame?
  407.             #ifdef entrypoint_bit_t
  408.             if (frame_info & bit(entrypoint_bit_t)) # BLOCK, TAGBODY, CATCH etc. ?
  409.             #else
  410.             if (frame_info < entrypoint_limit_t) # BLOCK, TAGBODY, CATCH etc. ?
  411.             #endif
  412.               # Frame mit Exitpoint liegt vor
  413.               if (frame_info & bit(blockgo_bit_t)) # BLOCK oder TAGBODY?
  414.                 # BLOCK_FRAME oder TAGBODY_FRAME liegt vor
  415.                 if (frame_info & bit(cframe_bit_t)) # compilierter?
  416.                   # CBLOCK_FRAME oder CTAGBODY_FRAME liegt vor
  417.                   { # Im Cons (NAME/Tags . <Framepointer>)
  418.                     Cdr(STACK_(frame_ctag)) = disabled; # Exit/Tags disablen
  419.                   }
  420.                   else
  421.                   # IBLOCK_FRAME oder ITAGBODY_FRAME liegt vor, genestet
  422.                   { # Im Cons (NAME/Tags . <Framepointer>)
  423.                     # (erstes Paar der Aliste next_env)
  424.                     Cdr(Car(STACK_(frame_next_env))) = disabled; # Exit/Tags disablen
  425.                   }
  426.                 else
  427.                 # UNWIND_PROTECT_FRAME, DRIVER_FRAME oder getrappter APPLY/EVAL_FRAME liegt vor
  428.                 if (frame_info & bit(dynjump_bit_t))
  429.                   # UNWIND_PROTECT_FRAME oder DRIVER_FRAME liegt vor
  430.                   if (frame_info & bit(driver_bit_t))
  431.                     # DRIVER_FRAME liegt vor
  432.                     {
  433.                       #ifdef HAVE_NUM_STACK
  434.                       # NUM_STACK_normal muß wieder den Wert bekommen, den es vor
  435.                       # Aufbau des Driver-Frames hatte:
  436.                       NUM_STACK =
  437.                       NUM_STACK_normal =
  438.                         ((DRIVER_frame_data*)(STACK_(frame_SP)))->old_NUM_STACK_normal;
  439.                       #endif
  440.                     }
  441.                     else
  442.                     # UNWIND_PROTECT_FRAME liegt vor
  443.                     { enter_frame_at_STACK(); }
  444.                   else
  445.                   # getrappter APPLY/EVAL_FRAME liegt vor
  446.                   { # Wie im Tracer:
  447.                     var reg1 object values;
  448.                     mv_to_list(); values = popSTACK(); # Werte in Liste packen
  449.                     dynamic_bind(S(trace_values),values); # *TRACE-VALUES* binden
  450.                     break_driver(T); # Break-Driver aufrufen
  451.                     list_to_mv(Symbol_value(S(trace_values)), # wieder Werte bilden
  452.                                fehler_mv_zuviel(mtypecode(STACK_(0+DYNBIND_SIZE))==TRAPPED_EVAL_frame_info
  453.                                                 ? S(eval)
  454.                                                 : S(apply)
  455.                                                );
  456.                               );
  457.                     dynamic_unbind(); # Bindung auflösen
  458.                   }
  459.               else
  460.               # VAR_FRAME oder FUN_FRAME liegt vor
  461.               { var reg4 object* new_STACK = topofframe(STACK_0); # Pointer übern Frame
  462.                 if (frame_info & bit(fun_bit_t))
  463.                   {} # bei Funktionen nichts weiter zu tun
  464.                   else
  465.                   # VAR_FRAME liegt vor, bindingptr läuft durch die Bindungen hoch
  466.                   { var reg2 object* frame_end = STACKpointable(new_STACK);
  467.                     var reg1 object* bindingptr = &STACK_(frame_bindings); # Beginn der Variablen-/Funktionsbindungen
  468.                     until (bindingptr == frame_end)
  469.                       { if (as_oint(*(bindingptr STACKop 0)) & wbit(dynam_bit_o))
  470.                           if (as_oint(*(bindingptr STACKop 0)) & wbit(active_bit_o))
  471.                             # Bindung statisch oder inaktiv -> nichts zu tun
  472.                             # Bindung dynamisch und aktiv -> Wert zurückschreiben:
  473.                             { set_Symbolflagged_value_off(*(bindingptr STACKop varframe_binding_sym),*(bindingptr STACKop varframe_binding_value));
  474.                               
  475.                             }
  476.                         bindingptr skipSTACKop varframe_binding_size; # nächste Bindung
  477.                   }   }
  478.                 # STACK neu setzen, dadurch Frame auflösen:
  479.                 setSTACK(STACK = new_STACK);
  480.                 goto fertig;
  481.               }
  482.             else
  483.             # DYNBIND_FRAME oder ENV_FRAME liegt vor
  484.             if (frame_info & bit(envbind_bit_t))
  485.               # ENV_FRAME liegt vor
  486.               { var reg1 object* ptr = &STACK_1;
  487.                 switch (frame_info & envbind_case_mask_t)
  488.                   { case (ENV1V_frame_info & envbind_case_mask_t): # 1 VAR_ENV
  489.                       aktenv.var_env = *ptr; ptr skipSTACKop 1; break;
  490.                     case (ENV1F_frame_info & envbind_case_mask_t): # 1 FUN_ENV
  491.                       aktenv.fun_env = *ptr; ptr skipSTACKop 1; break;
  492.                     case (ENV1B_frame_info & envbind_case_mask_t): # 1 BLOCK_ENV
  493.                       aktenv.block_env = *ptr; ptr skipSTACKop 1; break;
  494.                     case (ENV1G_frame_info & envbind_case_mask_t): # 1 GO_ENV
  495.                       aktenv.go_env = *ptr; ptr skipSTACKop 1; break;
  496.                     case (ENV1D_frame_info & envbind_case_mask_t): # 1 DECL_ENV
  497.                       aktenv.decl_env = *ptr; ptr skipSTACKop 1; break;
  498.                     case (ENV2VD_frame_info & envbind_case_mask_t): # 1 VAR_ENV und 1 DECL_ENV
  499.                       aktenv.var_env = *ptr; ptr skipSTACKop 1;
  500.                       aktenv.decl_env = *ptr; ptr skipSTACKop 1;
  501.                       break;
  502.                     case (ENV5_frame_info & envbind_case_mask_t): # alle 5 Environments
  503.                       aktenv.var_env = *ptr; ptr skipSTACKop 1;
  504.                       aktenv.fun_env = *ptr; ptr skipSTACKop 1;
  505.                       aktenv.block_env = *ptr; ptr skipSTACKop 1;
  506.                       aktenv.go_env = *ptr; ptr skipSTACKop 1;
  507.                       aktenv.decl_env = *ptr; ptr skipSTACKop 1;
  508.                       break;
  509.                     default: NOTREACHED
  510.               }   }
  511.               else
  512.               # DYNBIND_FRAME liegt vor
  513.               { var reg4 object* new_STACK = topofframe(STACK_0); # Pointer übern Frame
  514.                 var reg2 object* frame_end = STACKpointable(new_STACK);
  515.                 var reg1 object* bindingptr = &STACK_1; # Beginn der Bindungen
  516.                 # bindingptr läuft durch die Bindungen hoch
  517.                 until (bindingptr == frame_end)
  518.                   { set_Symbol_symvalue(*(bindingptr STACKop 0),*(bindingptr STACKop 1));
  519.                     bindingptr skipSTACKop 2; # nächste Bindung
  520.                   }
  521.                 #ifdef DYNBIND_LIST
  522.                 delete_frame_from_binding_list(&STACK_0);
  523.                 #endif
  524.                 # STACK neu setzen, dadurch Frame auflösen:
  525.                 setSTACK(STACK = new_STACK);
  526.                 goto fertig;
  527.               }
  528.         }
  529.       # STACK neu setzen, dadurch Frame auflösen:
  530.       setSTACK(STACK = topofframe(STACK_0));
  531.       fertig: ;
  532.     }
  533.  
  534. # UP: "unwindet" den STACK bis zum nächsten DRIVER_FRAME und
  535. # springt in die entsprechende Top-Level-Schleife.
  536. # reset();
  537.   nonreturning_function(global, reset, (void));
  538.   global void reset()
  539.     { # Beim Auflösen von UNWIND-PROTECT-Frames keine Werte retten:
  540.       value1 = NIL; mv_count=0;
  541.       unwind_protect_to_save.fun = (restart)&reset;
  542.       loop
  543.         { # Hört der STACK hier auf?
  544.           if (eq(STACK_0,nullobj) && eq(STACK_1,nullobj))
  545.             { driver(); } # STACK völlig weg -> Neustart
  546.           if (mtypecode(STACK_0) & bit(frame_bit_t))
  547.             # Bei STACK_0 beginnt ein Frame
  548.             { if (mtypecode(STACK_0) == DRIVER_frame_info) # DRIVER_FRAME ?
  549.                 break; # ja -> gefunden
  550.               unwind(); # Frame auflösen
  551.             }
  552.             else
  553.             # STACK_0 enthält ein normales LISP-Objekt
  554.             { skipSTACK(1); }
  555.         }
  556.       # Bei STACK_0 beginnt ein Driver-Frame.
  557.       enter_frame_at_STACK();
  558.     }
  559.  
  560. # UP: bindet dynamisch die Symbole der Liste symlist
  561. # an die Werte aus der Liste vallist.
  562. # progv(symlist,vallist);
  563. # > symlist, vallist: zwei Listen
  564. # Es wird genau ein Variablenbindungsframe aufgebaut.
  565. # verändert STACK
  566.   global void progv (object symlist, object vallist);
  567.   global void progv(symlist,vallist)
  568.     var reg2 object symlist;
  569.     var reg4 object vallist;
  570.     { # Platz auf dem STACK verlangen:
  571.       get_space_on_STACK(llength(symlist)*2*sizeof(object));
  572.       # Frame aufbauen:
  573.       { var reg5 object* top_of_frame = STACK; # Pointer übern Frame
  574.         var reg3 object symlistr = symlist;
  575.         while (consp(symlistr)) # Symbolliste durchgehen
  576.           { var reg1 object sym = Car(symlistr);
  577.             if (!symbolp(sym)) { fehler_kein_symbol(S(progv),sym); }
  578.             if (constantp(TheSymbol(sym)))
  579.               { pushSTACK(sym);
  580.                 pushSTACK(S(progv));
  581.                 //: DEUTSCH "~: ~ ist eine Konstante und kann nicht dynamisch gebunden werden."
  582.                 //: ENGLISH "~: ~ is a constant, cannot be bound dynamically"
  583.                 //: FRANCAIS "~: ~ est une constante et ne peut pas être liée dynamiquement."
  584.                 fehler(error, GETTEXT("~: ~ is a constant, cannot be bound dynamically"));
  585.               }
  586.             pushSTACK(Symbol_symvalue(sym)); # alter Wert der Variablen
  587.             pushSTACK(sym); # Variable
  588.             symlistr = Cdr(symlistr);
  589.           }
  590.         finish_frame(DYNBIND);
  591.         # Frame fertig aufgebaut, nun die Werte der Variablen verändern:
  592.         while (consp(symlist))
  593.           { if (atomp(vallist))
  594.               # Wertliste kürzer als Symbolliste
  595.               # -> alle weiteren "Werte" sind #<UNBOUND>
  596.               { do { set_Symbol_symvalue(Car(symlist),unbound);
  597.                      symlist = Cdr(symlist);
  598.                    }
  599.                    while (consp(symlist));
  600.                 break;
  601.               }
  602.             # Symbol bekommt neuen Wert:
  603.             set_Symbol_symvalue(Car(symlist),Car(vallist));
  604.             symlist = Cdr(symlist); vallist = Cdr(vallist);
  605.           }
  606.         #ifdef DYNBIND_LIST
  607.         add_frame_to_binding_list(&STACK_0);
  608.         #endif
  609.     } }
  610.  
  611. # UP: Löst die dynamische Schachtelung im STACK auf bis zu dem Frame
  612. # (ausschließlich), auf den upto zeigt, und springt diesen dann an.
  613. # unwind_upto(upto);
  614. # > upto: Pointer auf einen Frame (in den Stack, ohne Typinfo).
  615. # Rettet die Werte mv_count/mv_space.
  616. # verändert STACK,SP
  617. # kann GC auslösen
  618. # Springt dann den gefundenen Frame an.
  619.   nonreturning_function(global, unwind_upto, (object* upto_frame));
  620.   global void unwind_upto(upto_frame)
  621.     var reg1 object* upto_frame;
  622.     { unwind_protect_to_save.fun        = &unwind_upto;
  623.       unwind_protect_to_save.upto_frame = upto_frame;
  624.       until (STACK == upto_frame) # am Ziel-Frame angelangt?
  625.         { if (mtypecode(STACK_0) & bit(frame_bit_t)) # liegt ein Frame vor?
  626.             { unwind(); } # ja -> auflösen
  627.             # (Sollte dies ein Unwind-Protect-Frame sein, so wird danach wieder
  628.             # unwind_upto(upto_frame) aufgerufen, und wir sind wieder hier.)
  629.             else
  630.             { skipSTACK(1); } # nein -> einfach weiter
  631.         }
  632.       # Nun zeigt STACK auf den gefundenen FRAME.
  633.       enter_frame_at_STACK();
  634.     }
  635.  
  636. # UP: throwt zum Tag tag und übergibt dabei die Werte mv_count/mv_space.
  637. # Kommt nur dann zurück, wenn es keinen CATCH-Frame dieses Tags gibt.
  638. # throw(tag);
  639.   global void throw (object tag);
  640.   global void throw(tag)
  641.     var reg2 object tag;
  642.     { # Suche nach Catch-Frame mit Tag =tag:
  643.       var reg1 object* FRAME = STACK;
  644.       loop # Suche im Stack ab FRAME nach einem CATCH-Frame mit demselben Tag:
  645.         { if (eq(FRAME_(0),nullobj)) # Stackende?
  646.             { return; } # ja -> kein passendes Catch vorhanden -> Rücksprung
  647.           if (mtypecode(FRAME_(0)) & bit(frame_bit_t))
  648.             # Frame gefunden
  649.             { if ((mtypecode(FRAME_(0)) == CATCH_frame_info) # Catch-Frame?
  650.                   && eq(FRAME_(frame_tag),tag) # mit demselben Tag?
  651.                  )
  652.                 break; # ja -> Suchschleife fertig
  653.               # Frame übergehen:
  654.               FRAME = topofframe(FRAME_(0));
  655.             }
  656.             else
  657.             { FRAME skipSTACKop 1; }
  658.         }
  659.       # FRAME zeigt auf den untersten CATCH-Frame mit demselben Tag
  660.       unwind_upto(FRAME); # bis dorthin auflösen, dann anspringen
  661.     }
  662.  
  663. # UP: Ruft alle Handler zur Condition cond auf. Kommt nur zurück, wenn keiner
  664. # dieser Handler sich zuständig fühlt (d.h. wenn jeder Handler zurückkehrt).
  665. # invoke_handlers(cond);
  666. # kann GC auslösen
  667.   global void invoke_handlers (object cond);
  668.   # Variablen zur Übergabe von Information an den Beginn des Handlers:
  669.   local struct { object condition; object* stack; SPint* sp; uintL spdepth; }
  670.         handler_args;
  671. # Dies deaktiviert den Handler, der gerade aufgerufen wird,
  672. # und alle neueren Handler.
  673.   # Da immer nur ganze Bereiche von Handlers deaktiviert und wieder aktiviert
  674.   # werden, behandeln wir die Handler beim Deaktivieren nicht einzeln, sondern
  675.   # führen eine Liste der STACK-Bereiche, in denen die Handler deaktiviert sind.
  676.   typedef struct stack_range { struct stack_range * next;
  677.                                object* low_limit; object* high_limit;
  678.                              }
  679.           stack_range;
  680.   local stack_range * inactive_handlers = NULL;
  681.   # Ein Handler gilt genau dann als inaktiv, wenn für einen der in
  682.   # inactive_handlers aufgeführten Bereiche gilt:
  683.   # low_limit <= handler < high_limit.
  684.   global void invoke_handlers(cond)
  685.     var reg2 object cond;
  686.     { # Die Handler-Bereiche, die ausgeblendet werden:
  687.       var stack_range* other_ranges = inactive_handlers;
  688.       var stack_range new_range;
  689.       # Suche nach Handler-Frame, der einen Typ behandelt mit (TYPEP cond type):
  690.      {var reg1 object* FRAME = STACK;
  691.       loop # Suche im Stack ab FRAME nach einem passenden HANDLER-Frame:
  692.         { if (!(other_ranges == NULL) && (FRAME == other_ranges->low_limit))
  693.             { FRAME = other_ranges->high_limit;
  694.               other_ranges = other_ranges->next;
  695.             }
  696.           elif (eq(FRAME_(0),nullobj)) # Stackende?
  697.             { break; } # ja -> fertig, Rücksprung
  698.           elif (mtypecode(FRAME_(0)) & bit(frame_bit_t))
  699.             # Frame gefunden
  700.             { if (mtypecode(FRAME_(0)) == HANDLER_frame_info) # Handler-Frame?
  701.                 # Typen des Vektors #(type1 label1 ... typem labelm) durchlaufen:
  702.                 { var reg4 uintL m2 = TheSvector(Car(FRAME_(frame_handlers)))->length; # 2*m
  703.                   var reg3 uintL i = 0;
  704.                   do { pushSTACK(cond); # cond retten
  705.                        pushSTACK(cond);
  706.                        pushSTACK(TheSvector(Car(FRAME_(frame_handlers)))->data[i]); # typei
  707.                        funcall(S(safe_typep),2); # (SYS::SAFE-TYPEP cond typei) ausführen
  708.                        if (!nullp(value1)) # passender Handler gefunden?
  709.                          goto found_handler;
  710.                        cond = popSTACK(); # cond zurück
  711.                        i += 2;
  712.                      }
  713.                      while (i < m2);
  714.                   if (FALSE)
  715.                     found_handler:
  716.                     { # CLtL2 S. 873, 884: "A handler is executed in the dynamic context
  717.                       # of the signaler, except that the set of available condition
  718.                       # handlers will have been rebound to the value that was active
  719.                       # at the time the condition handler was made active."
  720.                       # Das Ganze sichern wir durch einen Unwind-Protect-Frame ab:
  721.                       var stack_range* saved_inactive_handlers = inactive_handlers;
  722.                       new_range.low_limit = STACK;
  723.                       new_range.high_limit = topofframe(FRAME_(0));
  724.                       new_range.next = other_ranges;
  725.                       {var reg4 object* top_of_frame = STACK;
  726.                        var jmp_buf returner; # Rücksprungpunkt
  727.                        finish_entry_frame(UNWIND_PROTECT,&!returner,_EMA_,
  728.                          { var reg5 restart fun = unwind_protect_to_save.fun;
  729.                            var reg6 object* arg = unwind_protect_to_save.upto_frame;
  730.                            skipSTACK(2); # Unwind-Protect-Frame auflösen
  731.                            # Cleanup: Handler reaktivieren:
  732.                            inactive_handlers = saved_inactive_handlers;
  733.                            # und weiterspringen:
  734.                            fun(arg);
  735.                            NOTREACHED
  736.                          });
  737.                        # Handler deaktivieren:
  738.                        inactive_handlers = &new_range;
  739.                        # Information für den Handler bereitlegen:
  740.                        handler_args.condition = STACK_(0+2);
  741.                        handler_args.stack = FRAME STACKop 4;
  742.                        handler_args.sp = (SPint*)(aint)as_oint(FRAME_(frame_SP));
  743.                        handler_args.spdepth = posfixnum_to_L(Cdr(FRAME_(frame_handlers)));
  744.                        # Handler aufrufen:
  745.                        {var reg4 object closure = FRAME_(frame_closure);
  746.                         var reg5 object codevec = TheCclosure(closure)->clos_codevec;
  747.                         var reg6 uintL index = (TheSbvector(codevec)->data[CCHD+4] & bit(7) ? CCHD+10 : CCHD+6)
  748.                                                + posfixnum_to_L(TheSvector(Car(FRAME_(frame_handlers)))->data[i+1]);
  749.                         interpret_bytecode(closure,codevec,index);
  750.                        }
  751.                        skipSTACK(2); # Unwind-Protect-Frame auflösen
  752.                        # Handler reaktivieren:
  753.                        inactive_handlers = saved_inactive_handlers;
  754.                       }
  755.                       cond = popSTACK(); # cond zurück
  756.                 }   }
  757.               # Frame übergehen:
  758.               FRAME = topofframe(FRAME_(0));
  759.             }
  760.             else
  761.             { FRAME skipSTACKop 1; }
  762.     }}  }
  763.  
  764. # UP: Stellt fest, ob ein Objekt ein Funktionsname, d.h. ein Symbol oder
  765. # eine Liste der Form (SETF symbol), ist.
  766. # funnamep(obj)
  767. # > obj: Objekt
  768. # < ergebnis: TRUE falls Funktionsname
  769.   global boolean funnamep (object obj);
  770.   global boolean funnamep(obj)
  771.     var reg1 object obj;
  772.     { if (symbolp(obj)) return TRUE;
  773.       if (consp(obj) && eq(Car(obj),S(setf)))
  774.           { obj = Cdr(obj);
  775.             if (consp(obj) && nullp(Cdr(obj)) && msymbolp(Car(obj)))
  776.               return TRUE;
  777.           }
  778.       return FALSE;
  779.     }
  780.  
  781. # UP: Liefert den Wert eines Symbols in einem Environment.
  782. # sym_value(symbol,venv)
  783. # > symbol: Symbol
  784. # > venv: ein Variablen- und Symbolmacro-Environment
  785. # < ergebnis: Wert des Symbols in diesem Environment
  786.   local object sym_value (object sym, object venv);
  787.   local object sym_value(sym,env)
  788.     var reg6 object sym;
  789.     var reg5 object env;
  790.     { if (constantp(TheSymbol(sym))) goto global_value; # Konstanten haben nur globale Werte
  791.       if (special_var_p(TheSymbol(sym))) goto global_value; # special deklarierte ebenso
  792.      {
  793.       #ifdef NO_symbolflags
  794.         #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
  795.           (eq(*(bindptr STACKop 1),sym) # richtiges Symbol?                                  \
  796.            && eq(*(bindingsptr STACKop 0),fixnum(bit(active_bit))) # und aktiv und statisch? \
  797.           )
  798.       #else
  799.       var reg4 object cmp = as_object(as_oint(sym) | wbit(active_bit_o)); # zum Vergleich: Bindung muß aktiv sein
  800.         #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
  801.           (eq(*(bindingsptr STACKop 0),cmp)) # richtiges Symbol und aktiv und statisch?
  802.       #endif
  803.       next_env:
  804.         switch (typecode(env))
  805.           { case_system: # Environment ist ein Pointer auf einen Variablenbindungs-Frame
  806.               { var reg2 object* FRAME = TheFramepointer(env);
  807.                {var reg3 uintL count = as_oint(FRAME_(frame_anz)); # Anzahl der Bindungen
  808.                 var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
  809.                 dotimesL(count,count,
  810.                   { if (binds_sym_p(bindingsptr)) # richtiges Symbol und aktiv und statisch?
  811.                       { var reg1 object value = *(bindingsptr STACKop varframe_binding_value);
  812.                         if (eq(value,specdecl))
  813.                           { goto global_value; }
  814.                           else
  815.                           { return value; }
  816.                       }
  817.                     bindingsptr skipSTACKop varframe_binding_size; # nein: nächste Bindung
  818.                   });
  819.                 env = FRAME_(frame_next_env);
  820.                 goto next_env;
  821.               }}
  822.             case_svector: # Environment ist ein Simple-Vector
  823.               goto next_vector;
  824.             default: # Environment ist NIL
  825.               goto global_value;
  826.           }
  827.       next_vector:
  828.         # Environment ist ein Simple-Vector
  829.         { var reg2 uintL count = floor(TheSvector(env)->length,2); # Anzahl der Bindungen
  830.           var reg1 object* ptr = &TheSvector(env)->data[0];
  831.           dotimesL(count,count,
  832.             { if (eq(*ptr,sym)) # richtiges Symbol?
  833.                 { var reg1 object value = *(ptr+1);
  834.                   if (eq(value,specdecl))
  835.                     { goto global_value; }
  836.                     else
  837.                     { return value; }
  838.                 }
  839.               ptr += 2; # nächste Bindung
  840.             });
  841.           env = *ptr; # nächstes Environment
  842.           if (simple_vector_p(env)) goto next_vector; # ein Simple-Vector?
  843.           # sonst: Environment ist NIL
  844.         }
  845.       #undef binds_sym_p
  846.      }
  847.       global_value: # Es gilt der globale (dynamische) Wert des Symbols
  848.         return Symbol_value(sym);
  849.     }
  850.  
  851. # UP: Stellt fest, ob ein Symbol im aktuellen Environment einen Macro darstellt.
  852. # sym_macrop(symbol)
  853. # > symbol: Symbol
  854. # < ergebnis: TRUE falls sym einen Symbol-Macro darstellt
  855.   global boolean sym_macrop (object sym);
  856.   global boolean sym_macrop(sym)
  857.     var reg2 object sym;
  858.     { var reg1 object val = sym_value(sym,aktenv.var_env);
  859.       return (symbolmacrop(val) ? TRUE : FALSE);
  860.     }
  861.  
  862. # UP: Setzt den Wert eines Symbols im aktuellen Environment.
  863. # setq(symbol,value);
  864. # > symbol: Symbol, keine Konstante
  865. # > value: gewünschter Wert des Symbols im aktuellen Environment
  866.   global void setq (object sym, object value);
  867.   global void setq(sym,value)
  868.     var reg6 object sym;
  869.     var reg7 object value;
  870.     { if (special_var_p(TheSymbol(sym))) goto global_value; # special deklarierte ebenso
  871.      {var reg5 object env = aktenv.var_env; # aktuelles VAR_ENV
  872.       #ifdef NO_symbolflags
  873.         #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
  874.           (eq(*(bindptr STACKop 1),sym) # richtiges Symbol?                                  \
  875.            && eq(*(bindingsptr STACKop 0),fixnum(bit(active_bit))) # und aktiv und statisch? \
  876.           )
  877.       #else
  878.       var reg4 object cmp = as_object(as_oint(sym) | wbit(active_bit_o)); # zum Vergleich: Bindung muß aktiv sein
  879.         #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
  880.           (eq(*(bindingsptr STACKop 0),cmp)) # richtiges Symbol und aktiv und statisch?
  881.       #endif
  882.       next_env:
  883.         switch (typecode(env))
  884.           { case_system: # Environment ist ein Pointer auf einen Variablenbindungs-Frame
  885.               { var reg2 object* FRAME = TheFramepointer(env);
  886.                {var reg3 uintL count = as_oint(FRAME_(frame_anz)); # Anzahl der Bindungen
  887.                 var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
  888.                 dotimesL(count,count,
  889.                   { if (binds_sym_p(bindingsptr)) # richtiges Symbol und aktiv und statisch?
  890.                       { if (eq(*(bindingsptr STACKop varframe_binding_value),specdecl))
  891.                           { goto global_value; }
  892.                           else
  893.                           { *(bindingsptr STACKop varframe_binding_value) = value; return; }
  894.                       }
  895.                     bindingsptr skipSTACKop varframe_binding_size; # nein: nächste Bindung
  896.                   });
  897.                 env = FRAME_(frame_next_env);
  898.                 goto next_env;
  899.               }}
  900.             case_svector: # Environment ist ein Simple-Vector
  901.               goto next_vector;
  902.             default: # Environment ist NIL
  903.               goto global_value;
  904.           }
  905.       next_vector:
  906.         # Environment ist ein Simple-Vector
  907.         { var reg2 uintL count = floor(TheSvector(env)->length,2); # Anzahl der Bindungen
  908.           var reg1 object* ptr = &TheSvector(env)->data[0];
  909.           dotimesL(count,count,
  910.             { if (eq(*ptr,sym)) # richtiges Symbol?
  911.                 { if (eq(*(ptr+1),specdecl))
  912.                     { goto global_value; }
  913.                     else
  914.                     { *(ptr+1) = value; return; }
  915.                 }
  916.               ptr += 2; # nächste Bindung
  917.             });
  918.           env = *ptr; # nächstes Environment
  919.           if (simple_vector_p(env)) goto next_vector; # ein Simple-Vector?
  920.           # sonst: Environment ist NIL
  921.         }
  922.       #undef binds_sym_p
  923.      }
  924.       global_value: # Es gilt der globale (dynamische) Wert des Symbols
  925.         set_Symbol_value(sym,value); return;
  926.     }
  927.  
  928. # UP: Liefert zu einem Symbol seine Funktionsdefinition in einem Environment
  929. # sym_function(sym,fenv)
  930. # > sym: Funktionsname (z.B. Symbol)
  931. # > fenv: ein Funktions- und Macrobindungs-Environment
  932. # < ergebnis: Funktionsdefinition, entweder unbound (falls undefinierte Funktion)
  933. #             oder Closure/SUBR/FSUBR oder ein Cons (SYS::MACRO . expander).
  934.   global object sym_function (object sym, object fenv);
  935.   global object sym_function(sym,env)
  936.     var reg6 object sym;
  937.     var reg4 object env;
  938.     { var reg5 object value;
  939.      {next_env:
  940.         switch (typecode(env))
  941.           { case_system: # Environment ist ein Pointer auf einen Funktionsbindungs-Frame
  942.               { var reg2 object* FRAME = TheFramepointer(env);
  943.                {var reg3 uintL count = as_oint(FRAME_(frame_anz)); # Anzahl der Bindungen
  944.                 var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
  945.                 dotimesL(count,count,
  946.                   { if (equal(*(bindingsptr STACKop 0),sym)) # richtiges Symbol?
  947.                       { value = *(bindingsptr STACKop 1); goto fertig; }
  948.                     bindingsptr skipSTACKop 2; # nein: nächste Bindung
  949.                   });
  950.                 env = FRAME_(frame_next_env);
  951.                 goto next_env;
  952.               }}
  953.             case_svector: # Environment ist ein Simple-Vector
  954.               goto next_vector;
  955.             default: # Environment ist NIL
  956.               goto global_value;
  957.           }
  958.       next_vector:
  959.         # Environment ist ein Simple-Vector
  960.         { var reg2 uintL count = floor(TheSvector(env)->length,2); # Anzahl der Bindungen
  961.           var reg1 object* ptr = &TheSvector(env)->data[0];
  962.           dotimesL(count,count,
  963.             { if (equal(*ptr,sym)) # richtiges Symbol?
  964.                 { value = *(ptr+1); goto fertig; }
  965.               ptr += 2; # nächste Bindung
  966.             });
  967.           env = *ptr; # nächstes Environment
  968.           if (simple_vector_p(env)) goto next_vector; # ein Simple-Vector?
  969.           # sonst: Environment ist NIL
  970.         }
  971.      }
  972.       global_value: # Es gilt die globale Funktionsdefinition
  973.         if (!symbolp(sym))
  974.           { sym = get(Car(Cdr(sym)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
  975.             if (!symbolp(sym)) # sollte (uninterniertes) Symbol sein
  976.               { return unbound; } # sonst undefiniert
  977.           }
  978.         return Symbol_function(sym);
  979.       fertig: # Symbol aktiv im Environment gefunden, "Wert" value
  980.         # (eine Closure oder NIL oder ein Cons (SYS::MACRO . expander) )
  981.         # Falls Definition = NIL (während LABELS), gilt die Funktion als
  982.         # undefiniert:
  983.         if (nullp(value)) { value = unbound; }
  984.         return value;
  985.     }
  986.  
  987. # UP: Wertet eine Form in einem gegebenen Environment aus.
  988. # eval_5env(form,var,fun,block,go,decl);
  989. # > var_env: Wert für VAR_ENV
  990. # > fun_env: Wert für FUN_ENV
  991. # > block_env: Wert für BLOCK_ENV
  992. # > go_env: Wert für GO_ENV
  993. # > decl_env: Wert für DECL_ENV
  994. # > form: Form
  995. # < mv_count/mv_space: Werte
  996. # kann GC auslösen
  997.   global Values eval_5env (object form, object var_env, object fun_env, object block_env, object go_env, object decl_env);
  998.   global Values eval_5env(form,var_env,fun_env,block_env,go_env,decl_env)
  999.     var reg2 object form;
  1000.     var reg3 object var_env;
  1001.     var reg4 object fun_env;
  1002.     var reg5 object block_env;
  1003.     var reg6 object go_env;
  1004.     var reg7 object decl_env;
  1005.     { # Environments binden:
  1006.       make_ENV5_frame();
  1007.       # aktuelle Environments setzen:
  1008.       aktenv.var_env = var_env;
  1009.       aktenv.fun_env = fun_env;
  1010.       aktenv.block_env = block_env;
  1011.       aktenv.go_env = go_env;
  1012.       aktenv.decl_env = decl_env;
  1013.       # Form auswerten:
  1014.       eval(form);
  1015.       # Environment-Frame auflösen:
  1016.       unwind();
  1017.       return; # fertig
  1018.     }
  1019.  
  1020. # UP: Wertet eine Form in einem leeren Environment aus.
  1021. # eval_noenv(form);
  1022. # > form: Form
  1023. # < mv_count/mv_space: Werte
  1024. # kann GC auslösen
  1025.   global Values eval_noenv (object form);
  1026.   global Values eval_noenv(form)
  1027.     var reg1 object form;
  1028.     { return_Values eval_5env(form,NIL,NIL,NIL,NIL,O(top_decl_env)); }
  1029.  
  1030. # UP: "nestet" ein FUN-Environment, d.h. schreibt alle aktiven Bindungen
  1031. # aus dem Stack in neu allozierte Vektoren.
  1032. # nest_fun(env)
  1033. # > env: FUN-Env
  1034. # < ergebnis: selbes Environment, kein Pointer in den Stack
  1035. # kann GC auslösen
  1036.   global object nest_fun (object env);
  1037.   global object nest_fun(env)
  1038.     var reg5 object env;
  1039.     { var reg6 uintL depth = 0; # Rekursionszähler:=0
  1040.       # Pseudorekursion mit Input env, Output env.
  1041.       nest_start: # Rekursionsbeginn
  1042.       if (typecode(env) == system_type)
  1043.         # env ist ein Pointer auf einen STACK-Frame.
  1044.         { check_STACK();
  1045.           pushSTACK(env); # env retten
  1046.           # entrekursiviert nest_fun(NEXT_ENV(env)) durchführen:
  1047.           {var reg1 object* FRAME = TheFramepointer(env);
  1048.            env = FRAME_(frame_next_env); depth++; goto nest_start;
  1049.           }
  1050.           nest_reentry: depth--;
  1051.           # NEXT_ENV ist nun genestet.
  1052.           {var reg4 object* FRAME = TheFramepointer(STACK_0); # nächster zu nestender STACK-Frame
  1053.            STACK_0 = env; # bisher genestetes Environment
  1054.            {var reg3 uintL anzahl = as_oint(FRAME_(frame_anz)); # Anzahl der noch nicht genesteten Bindungen
  1055.             if (anzahl == 0)
  1056.               # keine Bindungen -> unnötig, einen Vektor zu erzeugen.
  1057.               { env = popSTACK(); }
  1058.               else
  1059.               # Vektor für anzahl Bindungen erzeugen:
  1060.               { env = allocate_vector(2*anzahl+1);
  1061.                 # und füllen:
  1062.                 { var reg1 object* ptr = &TheSvector(env)->data[0];
  1063.                   var reg2 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
  1064.                   # anzahl Bindungen ab bindingsptr in den Vektor ab ptr eintragen:
  1065.                   dotimespL(anzahl,anzahl,
  1066.                     { *ptr++ = *(bindingsptr STACKop 0); # Bindung in den Vektor kopieren
  1067.                       *ptr++ = *(bindingsptr STACKop 1);
  1068.                       bindingsptr skipSTACKop 2;
  1069.                     });
  1070.                   *ptr++ = popSTACK(); # genestetes NEXT_ENV in Vektor eintragen
  1071.                 }
  1072.                 FRAME_(frame_next_env) = env; # Vektor als NEXT_ENV in den Frame
  1073.                 FRAME_(frame_anz) = as_object(0); # neue Zahl noch nicht genesteter Bindungen
  1074.               }
  1075.         } }}
  1076.       # mit diesem Nest-Teilschritt fertig.
  1077.       if (depth>0) goto nest_reentry; # Ende der Rekursion
  1078.       return env;
  1079.     }
  1080.  
  1081. # UP: "nestet" ein VAR-Environment, d.h. schreibt alle aktiven Bindungen
  1082. # aus dem Stack in neu allozierte Vektoren.
  1083. # nest_var(env)
  1084. # > env: VAR-Env
  1085. # < ergebnis: selbes Environment, kein Pointer in den Stack
  1086. # kann GC auslösen
  1087.   local object nest_var (object env);
  1088.   local object nest_var(env)
  1089.     var reg6 object env;
  1090.     { var reg7 uintL depth = 0; # Rekursionszähler:=0
  1091.       # Pseudorekursion mit Input env, Output env.
  1092.       nest_start: # Rekursionsbeginn
  1093.       if (typecode(env) == system_type)
  1094.         # env ist ein Pointer auf einen STACK-Frame.
  1095.         { check_STACK();
  1096.           pushSTACK(env); # env retten
  1097.           # entrekursiviert nest_var(NEXT_ENV(env)) durchführen:
  1098.           {var reg1 object* FRAME = TheFramepointer(env);
  1099.            env = FRAME_(frame_next_env); depth++; goto nest_start;
  1100.           }
  1101.           nest_reentry: depth--;
  1102.           # NEXT_ENV ist nun genestet.
  1103.           {var reg5 object* FRAME = TheFramepointer(STACK_0); # nächster zu nestender STACK-Frame
  1104.            STACK_0 = env; # bisher genestetes Environment
  1105.            # Suche (von unten) die erste aktive unter den noch nicht
  1106.            # genesteten Bindungen:
  1107.            {var reg3 uintL anzahl = as_oint(FRAME_(frame_anz)); # Anzahl der noch nicht genesteten Bindungen
  1108.             var reg4 uintL count = 0;
  1109.             var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
  1110.             until ((count>=anzahl) # alle ungenesteten Bindungen durch?
  1111.                    || (as_oint(*(bindingsptr STACKop 0)) & wbit(active_bit_o)) # aktive Bindung entdeckt?
  1112.                   )
  1113.               { # nein -> weitersuchen:
  1114.                 bindingsptr skipSTACKop varframe_binding_size;
  1115.                 count++;
  1116.               }
  1117.             # Unterhalb von bindingsptr sind count inaktive Bindungen.
  1118.             # Ab bindingsptr kommen anzahl-count aktive, zu nestende Bindungen.
  1119.             anzahl = anzahl-count; # Anzahl zu nestender Bindungen
  1120.             if (anzahl == 0)
  1121.               # keine Bindungen -> unnötig, einen Vektor zu erzeugen.
  1122.               { env = popSTACK(); }
  1123.               else
  1124.               # Vektor für anzahl Bindungen erzeugen:
  1125.               { env = allocate_vector(2*anzahl+1);
  1126.                 # und füllen:
  1127.                 { var reg2 object* ptr = &TheSvector(env)->data[0];
  1128.                   # Bindungen ab bindingsptr in den Vektor ab ptr eintragen:
  1129.                   dotimespL(anzahl,anzahl,
  1130.                     { if (as_oint(*(bindingsptr STACKop varframe_binding_mark)) & wbit(dynam_bit_o)) # Bindung dynamisch?
  1131.                         # dynamische Bindung, lexikalische Sichtbarkeit
  1132.                         { *ptr++ = symbol_without_flags(*(bindingsptr STACKop varframe_binding_sym)); # Symbol ohne Flag-Bits in den Vektor
  1133.                           *ptr++ = specdecl; # als special reference kennzeichnen
  1134.                           # Bindung bleibt im Frame aktiv
  1135.                         }
  1136.                         else
  1137.                         # statische Bindung, lexikalische Sichtbarkeit
  1138.                         { *(oint*)(bindingsptr STACKop varframe_binding_mark) &= ~wbit(active_bit_o); # Bindung inaktivieren
  1139.                           *ptr++ = *(bindingsptr STACKop varframe_binding_sym); # Bindung in den Vektor kopieren
  1140.                           *ptr++ = *(bindingsptr STACKop varframe_binding_value);
  1141.                         }
  1142.                       bindingsptr skipSTACKop varframe_binding_size;
  1143.                     });
  1144.                   *ptr++ = popSTACK(); # genestetes NEXT_ENV in Vektor eintragen
  1145.                 }
  1146.                 FRAME_(frame_next_env) = env; # Vektor als NEXT_ENV in den Frame
  1147.                 FRAME_(frame_anz) = as_object(count); # neue Zahl noch nicht genesteter Bindungen
  1148.               }
  1149.         } }}
  1150.       # mit diesem Nest-Teilschritt fertig.
  1151.       if (depth>0) goto nest_reentry; # Ende der Rekursion
  1152.       return env;
  1153.     }
  1154.  
  1155. # Macro: Legt fünf einzelne Environment auf den STACK
  1156. # und bildet daraus ein einzelnes Environment.
  1157. # make_STACK_env(venv,fenv,benv,genv,denv, env5 = );
  1158. # > object venv,fenv,benv,genv,denv: 5 einzelne Environments
  1159. # < environment* env5: Pointer auf im Stack liegendes Environment
  1160.   #ifdef STACK_UP
  1161.     #define make_STACK_env(venv,fenv,benv,genv,denv,env5_zuweisung)  \
  1162.       { pushSTACK(venv); pushSTACK(fenv); pushSTACK(benv); pushSTACK(genv); pushSTACK(denv); \
  1163.         env5_zuweisung &STACKblock_(environment,0);                                           \
  1164.       }
  1165.   #endif
  1166.   #ifdef STACK_DOWN
  1167.     #define make_STACK_env(venv,fenv,benv,genv,denv,env5_zuweisung)  \
  1168.       { pushSTACK(denv); pushSTACK(genv); pushSTACK(benv); pushSTACK(fenv); pushSTACK(venv); \
  1169.         env5_zuweisung &STACKblock_(environment,0);                                           \
  1170.       }
  1171.   #endif
  1172.  
  1173. # UP: Nestet die Environments in *env (d.h. schreibt alle Informationen in
  1174. # Stack-unabhängige Strukturen) und schiebt sie auf den STACK.
  1175. # (Die Werte VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV werden nicht
  1176. # verändert, da evtl. noch inaktive Bindungen in Frames sitzen, die ohne
  1177. # Veränderung von VAR_ENV aktiviert werden können müssen.)
  1178. # nest_env(env)
  1179. # > environment* env: Pointer auf fünf einzelne Environments
  1180. # < environment* ergebnis: Pointer auf die Environments im STACK
  1181. # verändert STACK, kann GC auslösen
  1182.   global environment* nest_env (environment* env);
  1183.   global environment* nest_env(env5)
  1184.     var reg6 environment* env5;
  1185.     { # Erst alle Environments in den STACK kopieren:
  1186.       make_STACK_env(env5->var_env,env5->fun_env,env5->block_env,env5->go_env,env5->decl_env,
  1187.                      env5 = );
  1188.       # DECL_ENV: Nicht zu verändern.
  1189.       # GO_ENV:
  1190.       { var reg5 object env = env5->go_env;
  1191.         var reg9 uintL depth = 0; # Rekursionstiefe := 0
  1192.         # Pseudo-Rekursion: nestet ein GO_ENV.
  1193.         # Input: env, ein GO_ENV. Output: env, die Aliste dazu.
  1194.         nest_go_start: # Rekursionsbeginn
  1195.         if (typecode(env) == system_type)
  1196.           # env ist ein Pointer in den STACK auf einen ITAGBODY-Frame.
  1197.           { check_STACK();
  1198.            {var reg4 object* FRAME = TheFramepointer(env);
  1199.             if (mtypecode(FRAME_(0)) & bit(nested_bit_t)) # Frame schon genestet?
  1200.               { env = FRAME_(frame_next_env); } # ja -> bisherige Aliste holen
  1201.               else
  1202.               {  pushSTACK(env); # env retten
  1203.                  # entrekursiviert nest_go(NEXT_ENV(env)) durchführen:
  1204.                  env = FRAME_(frame_next_env); depth++; goto nest_go_start;
  1205.                  nest_go_reentry: depth--;
  1206.                  # NEXT_ENV ist nun genestet.
  1207.                { var reg8 object frame = STACK_0; # nächster zu nestender STACK-Frame
  1208.                  FRAME = uTheFramepointer(frame);
  1209.                  STACK_0 = env; # bisher genestetes Environment
  1210.                 {var reg1 object* tagsptr = &FRAME_(frame_bindings); # Pointer aufs unterste Tag
  1211.                  var reg7 object* frame_end = STACKpointable(topofframe(FRAME_(0))); # Pointer übern Frame
  1212.                  var reg3 uintL count = # Anzahl der Tags
  1213.                    # Dazu die Pointer tagsptr und frame_end (beide ohne Typinfo!) abziehen:
  1214.                    STACK_item_count(tagsptr,frame_end) / 2;
  1215.                  # Vektor für count Tags erzeugen:
  1216.                  { var reg6 object tagvec = allocate_vector(count);
  1217.                    # und füllen:
  1218.                    { var reg2 object* ptr = &TheSvector(tagvec)->data[0];
  1219.                      # Tags ab tagsptr in den Vektor ab ptr eintragen:
  1220.                      dotimesL(count,count,
  1221.                        { *ptr++ = *(tagsptr STACKop 0);
  1222.                          tagsptr skipSTACKop 2;
  1223.                        });
  1224.                    }
  1225.                    pushSTACK(tagvec); # und retten
  1226.                  }
  1227.                  # Nächstes Alistencons (cons Tag-Vektor Frame-Pointer) erzeugen:
  1228.                  { var reg2 object new_cons = allocate_cons();
  1229.                    Car(new_cons) = STACK_0; # tagvec
  1230.                    Cdr(new_cons) = frame;
  1231.                    STACK_0 = new_cons;
  1232.                  }
  1233.                  # und vor die Aliste hängen:
  1234.                  env = allocate_cons();
  1235.                  Car(env) = popSTACK(); # new_cons
  1236.                  Cdr(env) = popSTACK(); # bisherige Aliste
  1237.                  FRAME_(frame_next_env) = env; # neues NEXT_ENV eintragen
  1238.                  *(oint*)(&FRAME_(0)) |= wbit(nested_bit_o); # Dieser Frame ist nun genestet.
  1239.               }}}
  1240.           }}
  1241.         # mit diesem Nest-Teilschritt fertig.
  1242.         if (depth>0) goto nest_go_reentry; # Ende der Rekursion
  1243.         env5->go_env = env; # genestetes GO_ENV ablegen
  1244.       }
  1245.       # BLOCK_ENV:
  1246.       { var reg2 object env = env5->block_env;
  1247.         var reg5 uintL depth = 0; # Rekursionstiefe := 0
  1248.         # Pseudo-Rekursion: nestet ein BLOCK_ENV.
  1249.         # Input: env, ein BLOCK_ENV. Output: env, die Aliste dazu.
  1250.         nest_block_start: # Rekursionsbeginn
  1251.         if (typecode(env) == system_type)
  1252.           # env ist ein Pointer in den STACK auf einen IBLOCK-Frame.
  1253.           { check_STACK();
  1254.            {var reg1 object* FRAME = TheFramepointer(env);
  1255.             if (mtypecode(FRAME_(0)) & bit(nested_bit_t)) # Frame schon genestet?
  1256.               { env = FRAME_(frame_next_env); } # ja -> bisherige Aliste holen
  1257.               else
  1258.               { pushSTACK(env); # env retten
  1259.                 # entrekursiviert nest_block(NEXT_ENV(env)) durchführen:
  1260.                 env = FRAME_(frame_next_env); depth++; goto nest_block_start;
  1261.                 nest_block_reentry: depth--;
  1262.                 # NEXT_ENV ist nun genestet.
  1263.                {var reg4 object frame = STACK_0; # nächster zu nestender STACK-Frame
  1264.                 FRAME = TheFramepointer(frame);
  1265.                 STACK_0 = env; # bisher genestetes Environment
  1266.                 # Nächstes Alistencons (cons Block-Name Frame-Pointer) erzeugen:
  1267.                 { var reg3 object new_cons = allocate_cons();
  1268.                   Car(new_cons) = FRAME_(frame_name);
  1269.                   Cdr(new_cons) = frame;
  1270.                   pushSTACK(new_cons);
  1271.                 }
  1272.                 # und vor die Aliste hängen:
  1273.                 env = allocate_cons();
  1274.                 Car(env) = popSTACK(); # new_cons
  1275.                 Cdr(env) = popSTACK(); # bisherige Aliste
  1276.                 FRAME_(frame_next_env) = env; # neues NEXT_ENV eintragen
  1277.                 *(oint*)(&FRAME_(0)) |= wbit(nested_bit_o); # Dieser Frame ist nun genestet.
  1278.               }}
  1279.           }}
  1280.         # mit diesem Nest-Teilschritt fertig.
  1281.         if (depth>0) goto nest_block_reentry; # Ende der Rekursion
  1282.         env5->block_env = env; # genestetes BLOCK_ENV ablegen
  1283.       }
  1284.       # FUN_ENV:
  1285.       env5->fun_env = nest_fun(env5->fun_env);
  1286.       # VAR_ENV:
  1287.       env5->var_env = nest_var(env5->var_env);
  1288.       # fertig.
  1289.       return env5;
  1290.     }
  1291.  
  1292. # UP: Nestet die aktuellen Environments (d.h. schreibt alle Informationen in
  1293. # Stack-unabhängige Strukturen) und schiebt sie auf den STACK.
  1294. # (Die Werte VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV werden nicht
  1295. # verändert, da evtl. noch inaktive Bindungen in Frames sitzen, die ohne
  1296. # Veränderung von VAR_ENV aktiviert werden können müssen.)
  1297. # nest_aktenv()
  1298. # < environment* ergebnis: Pointer auf die Environments im STACK
  1299. # verändert STACK, kann GC auslösen
  1300.   #define nest_aktenv()  nest_env(&aktenv)
  1301.  
  1302. # UP: Ergänzt ein Deklarations-Environment um ein decl-spec.
  1303. # augment_decl_env(declspec,env)
  1304. # > declspec: Deklarations-Specifier, ein Cons
  1305. # > env: Deklarations-Environment
  1306. # < ergebnis: neues (evtl. augmentiertes) Deklarations-Environment
  1307. # kann GC auslösen
  1308.   global object augment_decl_env (object new_declspec, object env);
  1309.   global object augment_decl_env(new_declspec,env)
  1310.     var reg6 object new_declspec;
  1311.     var reg5 object env;
  1312.     { var reg2 object decltype = Car(new_declspec); # Deklarations-Typ
  1313.       # Ist dies ein zu beachtender Deklarationstyp?
  1314.       # Gibt es in env ein Decl-Spec der Form (DECLARATION ... decltype ...) ?
  1315.       # NB: Die Liste O(declaration_types) ist das letzte Decl-Spec in env.
  1316.       if (symbolp(decltype))
  1317.         { # Alle lokal zu beachtenden Deklarations-Typen durchgehen:
  1318.           { var reg4 object declspecs = env;
  1319.             while (consp(declspecs)) # Alle declspecs aus env durchgehen
  1320.               { var reg3 object declspec = Car(declspecs);
  1321.                 if (eq(Car(declspec),S(declaration))) # Deklaration (DECLARATION ...) ?
  1322.                   { var reg1 object list = Cdr(declspec); # ja -> restliche Liste durchgehen
  1323.                     while (consp(list))
  1324.                       { if (eq(Car(list),decltype)) # Listenelement = decltype ?
  1325.                           goto beachten;
  1326.                         list = Cdr(list);
  1327.                   }   }
  1328.                 declspecs = Cdr(declspecs);
  1329.           }   }
  1330.         }
  1331.       # nicht zu beachtende Deklaration.
  1332.       return env; # env unverändert lassen
  1333.       beachten:
  1334.       # eine zu beachtende Deklaration -> env := (cons new_declspec env)
  1335.       pushSTACK(env); pushSTACK(new_declspec);
  1336.       env = allocate_cons();
  1337.       Car(env) = popSTACK(); Cdr(env) = popSTACK();
  1338.       return env;
  1339.     }
  1340.  
  1341. # UP: expandiert eine Form, falls möglich, (nicht jedoch, wenn FSUBR-Aufruf
  1342. # oder Symbol) in einem Environment
  1343. # macroexp(form,venv,fenv);
  1344. # > form: Form
  1345. # > venv: ein Variablen- und Symbolmacro-Environment
  1346. # > fenv: ein Funktions- und Macrobindungs-Environment
  1347. # < value1: die Expansion
  1348. # < value2: NIL, wenn nicht expandiert,
  1349. #           T, wenn expandiert wurde
  1350. # kann GC auslösen
  1351.   global void macroexp (object form, object venv, object fenv);
  1352.   global void macroexp(form,venv,fenv)
  1353.     var reg2 object form;
  1354.     var reg5 object venv;
  1355.     var reg4 object fenv;
  1356.     { if (consp(form)) # nur Listen können Macro-call sein
  1357.         { var reg3 object funname = Car(form); # Funktionsname
  1358.           if (symbolp(funname))
  1359.             { var reg1 object fdef = sym_function(funname,fenv); # Funktionsdefinition holen
  1360.               # Ist sie (SYS::MACRO . Expander) ?
  1361.               if (consp(fdef) && eq(Car(fdef),S(macro)))
  1362.                 # ja -> expandieren:
  1363.                 { # (FUNCALL *MACROEXPAND-HOOK* expander form env) ausführen:
  1364.                   pushSTACK(Cdr(fdef)); # Expander als erstes Argument
  1365.                   pushSTACK(form); # Form als zweites Argument
  1366.                   pushSTACK(fenv);
  1367.                   pushSTACK(nest_var(venv)); # genestetes Variablen- und Symbolmacro-Environment
  1368.                   STACK_1 = nest_fun(STACK_1); # genestetes Funktions- und Macrobindungs-Environment
  1369.                  {var reg6 object env = allocate_vector(2); # Environment für beide
  1370.                   TheSvector(env)->data[0] = popSTACK(); # venv als 1. Komponente
  1371.                   TheSvector(env)->data[1] = STACK_0;    # fenv als 2. Komponente
  1372.                   STACK_0 = env; # Environment als drittes Argument
  1373.                   funcall(Symbol_value(S(macroexpand_hook)),3);
  1374.                   value2 = T; # expandierte Form als 1. Wert, T als 2. Wert
  1375.                   return;
  1376.                 }}
  1377.         }   }
  1378.       # sonst nicht expandieren:
  1379.       value1 = form; value2 = NIL;
  1380.     }
  1381.  
  1382. # UP: expandiert eine Form, falls möglich, (auch, wenn FSUBR-Aufruf)
  1383. # in einem Environment
  1384. # macroexp0(form,env);
  1385. # > form: Form
  1386. # > env: ein Macroexpansions-Environment
  1387. # < value1: die Expansion
  1388. # < value2: NIL, wenn nicht expandiert,
  1389. #           T, wenn expandiert wurde
  1390. # kann GC auslösen
  1391.   global void macroexp0 (object form, object env);
  1392.   global void macroexp0(form,env)
  1393.     var reg4 object form;
  1394.     var reg6 object env;
  1395.     { if (consp(form)) # nur Listen können Macro-call sein
  1396.         { var reg5 object funname = Car(form); # Funktionsname
  1397.           if (symbolp(funname))
  1398.             { var reg3 object fdef = sym_function(funname,TheSvector(env)->data[1]); # Funktionsdefinition holen
  1399.               if (fsubrp(fdef))
  1400.                 # fdef ist ein FSUBR, also war die globale Funktionsdefinition gültig.
  1401.                 # Schaue nach, ob die Propertyliste eine Macrodefinition enthält:
  1402.                 { var reg1 object expander = get(funname,S(macro)); # nach Property SYS::MACRO suchen
  1403.                   if (!eq(expander,unbound))
  1404.                     # gefunden. Mit dem Expander aus der Propertyliste expandieren:
  1405.                     { # (FUNCALL *MACROEXPAND-HOOK* expander form env) ausführen:
  1406.                       pushSTACK(expander); # Expander als erstes Argument
  1407.                       pushSTACK(form); # Form als zweites Argument
  1408.                       pushSTACK(env); # Environment als drittes Argument
  1409.                       funcall(Symbol_value(S(macroexpand_hook)),3);
  1410.                       value2 = T; # expandierte Form als 1. Wert, T als 2. Wert
  1411.                       return;
  1412.                 }   }
  1413.                 else
  1414.                 # 3 Möglichkeiten:
  1415.                 # #UNBOUND/SUBR/Closure (globale oder lexikalische Funktionsdef.)
  1416.                 #   -> nicht expandieren
  1417.                 # (SYS::MACRO . Expander) (lexikalische Macrodefinition)
  1418.                 #   -> expandieren (Expander aufrufen)
  1419.                 # Symbol (lexikalische Funktionsdefinition während SYS::%EXPAND)
  1420.                 #   expandieren: (list* 'SYS::%FUNCALL Symbol (cdr form))
  1421.                 if (consp(fdef))
  1422.                   { # Ist es (SYS::MACRO . Expander) ?
  1423.                     if (eq(Car(fdef),S(macro)))
  1424.                       # ja -> expandieren:
  1425.                       { # (FUNCALL *MACROEXPAND-HOOK* expander form env) ausführen:
  1426.                         pushSTACK(Cdr(fdef)); # Expander als erstes Argument
  1427.                         pushSTACK(form); # Form als zweites Argument
  1428.                         pushSTACK(env); # Environment als drittes Argument
  1429.                         funcall(Symbol_value(S(macroexpand_hook)),3);
  1430.                         value2 = T; # expandierte Form als 1. Wert, T als 2. Wert
  1431.                         return;
  1432.                   }   }
  1433.                 elif (symbolp(fdef))
  1434.                   # fdef ein Symbol
  1435.                   { # Muß zu (SYS::%FUNCALL fdef ...) expandieren:
  1436.                     pushSTACK(Cdr(form)); # (cdr form)
  1437.                     pushSTACK(fdef); # Symbol
  1438.                    {var reg1 object new_cons = allocate_cons();
  1439.                     Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
  1440.                     STACK_0 = new_cons; # (cons Symbol (cdr form))
  1441.                    }
  1442.                    {var reg1 object new_cons = allocate_cons();
  1443.                     Car(new_cons) = S(pfuncall); Cdr(new_cons) = popSTACK();
  1444.                     value1 = new_cons; # (cons 'SYS::%FUNCALL (cons Symbol (cdr form)))
  1445.                    }
  1446.                     value2 = T; return; # es wurde expandiert.
  1447.                   }
  1448.         }   }
  1449.       elif (symbolp(form))
  1450.         { var reg1 object val = sym_value(form,TheSvector(env)->data[0]);
  1451.           if (symbolmacrop(val)) # Symbol-Macro gefunden?
  1452.             # ja -> expandieren
  1453.             { value1 = TheSymbolmacro(val)->symbolmacro_expansion; value2 = T; return; }
  1454.         }
  1455.       # sonst nicht expandieren:
  1456.       value1 = form; value2 = NIL;
  1457.     }
  1458.  
  1459. # UP: Parse-Declarations-Docstring. Trennt von einer Formenliste diejenigen
  1460. # ab, die als Deklarationen bzw. Dokumentationsstring angesehen werden
  1461. # müssen.
  1462. # parse_dd(formlist,venv,fenv)
  1463. # > formlist: ( {decl|doc-string} . body )
  1464. # > venv: ein Variablen- und Symbolmacro-Environment (für die Macroexpansionen)
  1465. # > fenv: Funktions- und Macrobindungs-Environment (für die Macroexpansionen)
  1466. # < value1: body
  1467. # < value2: Liste der decl-specs
  1468. # < value3: Doc-String oder NIL
  1469. # < ergebnis: TRUE falls eine (COMPILE)-Deklaration vorkam, FALSE sonst
  1470. # kann GC auslösen
  1471.   global boolean parse_dd (object formlist, object venv, object fenv);
  1472.   global boolean parse_dd(formlist,venv,fenv)
  1473.     var reg8 object formlist;
  1474.     var reg7 object venv;
  1475.     var reg6 object fenv;
  1476.     { pushSTACK(formlist); # formlist aufheben für Fehlermeldung
  1477.       pushSTACK(venv); # Variablen-Environment
  1478.       pushSTACK(fenv); # Macrobindungs-Environment
  1479.       pushSTACK(NIL); # vorläufiger Doc-String
  1480.       pushSTACK(NIL); # Anfang decl-spec-Liste
  1481.       # Stackaufbau: formlist, venv, fenv, docstring, declspecs.
  1482.      {var reg5 boolean compile_decl = FALSE; # Flag, ob eine (COMPILE)-Deklaration vorkam
  1483.       var reg2 object body = formlist; # Rest der Formenliste
  1484.       while (consp(body))
  1485.         {  pushSTACK(body); # body retten
  1486.          { var reg1 object form = Car(body); # nächste Form
  1487.            # evtl. macroexpandieren (ohne FSUBRs, Symbole zu expandieren):
  1488.            do { macroexp(form,STACK_(3+1),STACK_(2+1)); form = value1; }
  1489.               until (nullp(value2));
  1490.            body = popSTACK();
  1491.           {var reg4 object body_rest = Cdr(body); # body verkürzen
  1492.            if (stringp(form)) # Doc-String gefunden?
  1493.              { if (atomp(body_rest)) # an letzter Stelle der Formenliste?
  1494.                  goto fertig; # ja -> letzte Form kann kein Doc-String sein!
  1495.                if (!nullp(STACK_1)) # schon ein Doc-String dagewesen?
  1496.                  # ja -> mehr als ein Doc-String ist zuviel:
  1497.                  { pushSTACK(STACK_4); # formlist
  1498.                    //: DEUTSCH "In ~ kommen zu viele Doc-Strings vor."
  1499.                    //: ENGLISH "Too many documentation strings in ~"
  1500.                    //: FRANCAIS "Trop de chaînes de documentation dans ~."
  1501.                    fehler(program_error, GETTEXT("Too many documentation strings in ~"));
  1502.                  }
  1503.                STACK_1 = form; # neuer Doc-String
  1504.                body = body_rest;
  1505.              }
  1506.            elif (consp(form) && eq(Car(form),S(declare))) # Deklaration (DECLARE ...) ?
  1507.              { # neue decl-specs einzeln auf STACK_0 consen:
  1508.                pushSTACK(body_rest); # body_rest retten
  1509.                pushSTACK(Cdr(form)); # Liste der neuen decl-specs
  1510.                while (mconsp(STACK_0))
  1511.                  {{var reg3 object declspec = Car(STACK_0); # nächstes decl-spec
  1512.                    # Teste, ob (EQUAL d '(COMPILE)) =
  1513.                    #   (and (consp d) (eq (car d) 'COMPILE) (null (cdr d)))
  1514.                    if (consp(declspec)
  1515.                        && eq(Car(declspec),S(compile))
  1516.                        && nullp(Cdr(declspec))
  1517.                       )
  1518.                      { compile_decl = TRUE; }
  1519.                   }# Diese Deklaration auf STACK_(0+2) consen:
  1520.                   {var reg3 object new_cons = allocate_cons();
  1521.                    Car(new_cons) = Car(STACK_0);
  1522.                    Cdr(new_cons) = STACK_(0+2);
  1523.                    STACK_(0+2) = new_cons;
  1524.                   }# zum nächsten decl-spec:
  1525.                    STACK_0 = Cdr(STACK_0);
  1526.                  }
  1527.                skipSTACK(1);
  1528.                body = popSTACK(); # body := alter body_rest
  1529.              }
  1530.            else
  1531.              { fertig: # fertig mit Durchlaufen der Formenliste
  1532.                #if 0
  1533.                # Das war einmal eine schöne Optimierung, die zweimaliges
  1534.                # Macroexpandieren vermied. Leider ist sie nicht mehr sicher,
  1535.                # denn bei (FUNCTION (LAMBDA ...)), LET, LET*, MULTIPLE-VALUE-BIND
  1536.                # wird das äußere(!) Variablen-Environment übergeben, so daß in
  1537.                # (SYMBOL-MACROLET ((X Y)) (LET ((X (FOO))) (SETF X ...) ...))
  1538.                # der SETF-Macro ein verkehrtes venv übergeben bekäme und zu
  1539.                # (SETQ Y ...) expandieren würde.
  1540.                if (!eq(form,Car(body))) # sofern die Form expandiert wurde,
  1541.                  # ersetze body durch (cons form (cdr body)) :
  1542.                  { pushSTACK(body_rest); pushSTACK(form);
  1543.                    body = allocate_cons();
  1544.                    Car(body) = popSTACK(); # form
  1545.                    Cdr(body) = popSTACK(); # body_rest
  1546.                  }
  1547.                #endif
  1548.                break;
  1549.              }
  1550.         }}}
  1551.       value1 = body;
  1552.       value2 = nreverse(popSTACK()); # decl-spec-Liste
  1553.       value3 = popSTACK(); # Doc-String
  1554.       skipSTACK(3);
  1555.       return compile_decl;
  1556.     }}
  1557.  
  1558. # UP: bindet *EVALHOOK* und *APPLYHOOK* dynamisch an die gegebenen Werte.
  1559. # bindhooks(evalhook_value,applyhook_value);
  1560. # > evalhook_value: Wert für *EVALHOOK*
  1561. # > applyhook_value: Wert für *APPLYHOOK*
  1562. # verändert STACK
  1563. # kann GC auslösen
  1564.   global void bindhooks (object evalhook_value, object applyhook_value);
  1565.   global void bindhooks(evalhook_value,applyhook_value)
  1566.     var reg2 object evalhook_value;
  1567.     var reg3 object applyhook_value;
  1568.     { 
  1569.       # Frame aufbauen:
  1570.       { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  1571.         pushSTACK(Symbol_symvalue(S(evalhookstern)));  # alter Wert von *EVALHOOK*
  1572.         pushSTACK(S(evalhookstern));                # *EVALHOOK*
  1573.         pushSTACK(Symbol_symvalue(S(applyhookstern))); # alter Wert von *APPLYHOOK*
  1574.         pushSTACK(S(applyhookstern));               # *APPLYHOOK*
  1575.         finish_frame(DYNBIND);
  1576.       }
  1577.       # Frame fertig aufgebaut, nun die Werte der Variablen verändern:
  1578.       set_Symbol_symvalue(S(evalhookstern),evalhook_value); # (SETQ *EVALHOOK* evalhook_value)
  1579.       set_Symbol_symvalue(S(applyhookstern),applyhook_value); # (SETQ *APPLYHOOK* applyhook_value)
  1580.       #ifdef DYNBIND_LIST
  1581.       add_frame_to_binding_list(&STACK_0);
  1582.       #endif
  1583.     }
  1584.  
  1585. # UP: bindet *EVALHOOK* und *APPLYHOOK* dynamisch an NIL.
  1586. # bindhooks_NIL();
  1587. # verändert STACK
  1588. # kann GC auslösen
  1589.   #define bindhooks_NIL()  bindhooks(NIL,NIL)
  1590.  
  1591. # UP: Bestimmt den Source-Lambdabody eines Lambdabody.
  1592. # lambdabody_source(lambdabody)
  1593. # > lambdabody: Lambdabody (ein Cons)
  1594. # < ergebnis: Source-Lambdabody (unbound falls keine Source angegeben)
  1595.   local object lambdabody_source (object lambdabody);
  1596.   local object lambdabody_source(lambdabody)
  1597.     var reg3 object lambdabody;
  1598.     { var reg2 object body = Cdr(lambdabody);
  1599.       # body = ((DECLARE (SOURCE ...) ...) ...) ?
  1600.       if (consp(body))
  1601.         { var reg1 object form = Car(body); # erste Form
  1602.           # form = (DECLARE (SOURCE ...) ...) ?
  1603.           if (consp(form) && eq(Car(form),S(declare)))
  1604.             { var reg6 object declspecs = Cdr(form);
  1605.               # declspecs = ((SOURCE ...) ...) ?
  1606.               if (consp(declspecs))
  1607.                 { var reg5 object declspec = Car(declspecs);
  1608.                   # declspec = (SOURCE ...) ?
  1609.                   if (consp(declspec) && eq(Car(declspec),S(source)))
  1610.                     { var reg4 object declspecr = Cdr(declspec);
  1611.                       if (consp(declspecr))
  1612.                         # Source gefunden
  1613.                         { return Car(declspecr); }
  1614.         }   }   }   }
  1615.       return unbound;
  1616.     }
  1617.  
  1618. # UP: Erzeugt zu einem Lambdabody die entsprechende Closure durch Zerlegen
  1619. # der Lambdaliste und eventuelles Macroexpandieren aller Formen.
  1620. # get_closure(lambdabody,name,env)
  1621. # > lambdabody: (lambda-list {decl|doc} {form})
  1622. # > name: Name, ein Symbol oder (SETF symbol)
  1623. # > env: Pointer auf die fünf einzelnen Environments:
  1624. #        env->var_env = VENV, env->fun_env = FENV,
  1625. #        env->block_env = BENV, env->go_env = GENV,
  1626. #        end->decl_env = DENV.
  1627. # < ergebnis: Closure
  1628. # kann GC auslösen
  1629.   global object get_closure (object lambdabody, object name, environment* env);
  1630.   global object get_closure(lambdabody,name,env)
  1631.     var reg10 object lambdabody;
  1632.     var reg10 object name;
  1633.     var reg10 environment* env;
  1634.     { # Lambdabody muß ein Cons sein:
  1635.       if (atomp(lambdabody))
  1636.         { pushSTACK(name);
  1637.           //: DEUTSCH "FUNCTION: Lambda-Liste für ~ fehlt."
  1638.           //: ENGLISH "FUNCTION: lambda-list for ~ is missing"
  1639.           //: FRANCAIS "FUNCTION: La liste lambda pour ~ manque."
  1640.           fehler(program_error, GETTEXT("FUNCTION: lambda-list for ~ is missing"));
  1641.         }
  1642.       # und der CAR muß eine Liste sein:
  1643.       {var reg1 object lambdalist = Car(lambdabody);
  1644.        if (!listp(lambdalist))
  1645.          { pushSTACK(lambdalist);
  1646.            pushSTACK(name);
  1647.            //: DEUTSCH "FUNCTION: Lambda-Liste für ~ muß eine Liste sein, nicht ~"
  1648.            //: ENGLISH "FUNCTION: lambda-list for ~ should be a list, not ~"
  1649.            //: FRANCAIS "FUNCTION: La liste lambda pour ~ doit être une liste et non ~"
  1650.            fehler(program_error, GETTEXT("FUNCTION: lambda-list for ~ should be a list, not ~"));
  1651.       }  }
  1652.       pushSTACK(name);
  1653.       pushSTACK(lambdabody);
  1654.       # Stackaufbau: name, lambdabody.
  1655.       if (parse_dd(Cdr(lambdabody),env->var_env,env->fun_env)) # ({decl|doc} {form}) zerlegen
  1656.         # Es trat eine (COMPILE)-Deklaration auf.
  1657.         { # Lambdabody durch seine Source ersetzen (denn manche Macros
  1658.           # können effizienter compiliert werden als ihre Macro-Expansion):
  1659.           { var reg1 object source = lambdabody_source(STACK_0);
  1660.             if (!eq(source,unbound)) { STACK_0 = source; }
  1661.           }
  1662.           # Environments nesten:
  1663.           { var reg1 environment* stack_env = nest_env(env); # nesten, auf den STACK legen
  1664.             #if !defined(STACK_UP)
  1665.             var environment my_env;
  1666.             my_env = *stack_env; # und hierher übertragen
  1667.             skipSTACK(5); # und wieder vom STACK nehmen
  1668.             pushSTACK(my_env.var_env);
  1669.             pushSTACK(my_env.fun_env);
  1670.             pushSTACK(my_env.block_env);
  1671.             pushSTACK(my_env.go_env);
  1672.             pushSTACK(my_env.decl_env);
  1673.             #endif
  1674.             # Stackaufbau: name, lambdabody, venv, fenv, benv, genv, denv.
  1675.           }
  1676.           # (SYS::COMPILE-LAMBDA name lambdabody venv fenv benv genv denv) ausführen:
  1677.           funcall(S(compile_lambda),7);
  1678.           return value1; # compilierte Closure als Wert
  1679.         }
  1680.       # Interpretierte Closure bauen:
  1681.       { var reg1 object source = lambdabody_source(STACK_0);
  1682.         if (eq(source,unbound))
  1683.           # keine Source angegeben -> Lambdabody expandieren:
  1684.           { # (SYS::%EXPAND-LAMBDABODY-MAIN lambdabody venv fenv) aufrufen:
  1685.             pushSTACK(STACK_0); # Lambdabody als 1. Argument
  1686.             pushSTACK(nest_var(env->var_env)); # Variablen-Environment genestet als 2. Argument
  1687.             pushSTACK(nest_fun(env->fun_env)); # Funktions-Environment genestet als 3. Argument
  1688.             funcall(S(expand_lambdabody_main),3);
  1689.             lambdabody = value1; # expandierter Lambdabody
  1690.           }
  1691.           else
  1692.           # Source angegeben -> sie ersetzt den alten Lambdabody:
  1693.           { lambdabody = STACK_0; # Lambdabody
  1694.             STACK_0 = source; # Source-Lambdabody
  1695.           }
  1696.       }
  1697.       # Nun ist  STACK_0     der Source-Lambdabody,
  1698.       #          lambdabody  der zu verwendende Lambdabody.
  1699.       pushSTACK(Car(lambdabody)); # Lambdaliste
  1700.       parse_dd(Cdr(lambdabody),env->var_env,env->fun_env); # ({decl|doc} {form}) zerlegen
  1701.       pushSTACK(value1); # Body
  1702.       pushSTACK(value2); # Deklarationen
  1703.       pushSTACK(value3); # Doc-String oder NIL
  1704.      {var reg3 object* closure_; # Pointer auf die Closure im STACK
  1705.       # Closure erzeugen (mit NIL gefüllt):
  1706.       {  var reg1 object closure = allocate_srecord(0,Rectype_Closure,iclos_length,closure_type);
  1707.          # und teilweise füllen:
  1708.          TheIclosure(closure)->clos_docstring = popSTACK(); # Doc-String
  1709.        { var reg5 object declarations         = popSTACK(); # Deklarationen
  1710.          TheIclosure(closure)->clos_body      = popSTACK(); # Body
  1711.         {var reg4 object lambdalist           = popSTACK(); # Lambda-Liste
  1712.          TheIclosure(closure)->clos_form      = popSTACK(); # Source-Lambdabody
  1713.          TheIclosure(closure)->clos_name      = STACK_0;    # Name
  1714.          # und retten:
  1715.          STACK_0 = closure;
  1716.          # Stackaufbau: closure.
  1717.          closure_ = &STACK_0; # Pointer auf die Closure im STACK
  1718.          pushSTACK(lambdalist); pushSTACK(declarations);
  1719.       }}}
  1720.       # Environments nesten und genestet in die Closure stecken:
  1721.       {var reg1 environment* stack_env = nest_env(env);
  1722.        var reg2 object closure = *closure_;
  1723.        TheIclosure(closure)->clos_var_env   = stack_env->var_env  ;
  1724.        TheIclosure(closure)->clos_fun_env   = stack_env->fun_env  ;
  1725.        TheIclosure(closure)->clos_block_env = stack_env->block_env;
  1726.        TheIclosure(closure)->clos_go_env    = stack_env->go_env   ;
  1727.        TheIclosure(closure)->clos_decl_env  = stack_env->decl_env ;
  1728.        skipSTACK(5);
  1729.        TheIclosure(closure)->clos_keywords = Fixnum_0; # keywords:=0, solange &KEY fehlt
  1730.       }
  1731.       # Stackaufbau: closure, lambdalist, declarations.
  1732.       {var reg10 uintL spec_count = 0; # Anzahl der dynamischen Referenzen
  1733.        var reg10 uintL req_count  = 0; # Anzahl der required-Parameter
  1734.        var reg10 uintL opt_count  = 0; # Anzahl der optional-Parameter
  1735.        var reg10 uintL key_count  = 0; # Anzahl der Keyword-Parameter
  1736.        var reg10 uintL aux_count  = 0; # Anzahl der &AUX-Variablen
  1737.        var reg9  uintL var_count  = 0; # Gesamtzahl der auf dem STACK liegenden Variablen
  1738.        {var reg4 object declarations = popSTACK();
  1739.         # Deklarationen verarbeiten:
  1740.         # Dynamisch referenzierte Variablen aus der decl-spec-Liste declarations
  1741.         # herauslesen und auf dem STACK ablegen. Sonstige zu beachtende
  1742.         # Deklarationen verändern das Deklarations-Environment der Closure.
  1743.         while (consp(declarations)) # alle decl-specs abgearbeitet?
  1744.           { var reg1 object declspec = Car(declarations);
  1745.             # declspec muß Liste sein:
  1746.             if (atomp(declspec))
  1747.               { pushSTACK(declspec);
  1748.                 //: DEUTSCH "FUNCTION: ~ ist keine erlaubte Deklaration."
  1749.                 //: ENGLISH "FUNCTION: illegal declaration ~"
  1750.                 //: FRANCAIS "FUNCTION: ~ n'est pas une déclaration licite."
  1751.                 fehler(program_error, GETTEXT("FUNCTION: illegal declaration ~"));
  1752.               }
  1753.             # SPECIAL-Deklaration verarbeiten:
  1754.             if (eq(Car(declspec),S(special))) # SPECIAL-Deklaration ?
  1755.               { declspec = Cdr(declspec);
  1756.                 while (consp(declspec))
  1757.                   { var reg2 object sym = Car(declspec);
  1758.                     if (!symbolp(sym))
  1759.                       { pushSTACK(sym);
  1760.                         //: DEUTSCH "FUNCTION: ~ ist kein Symbol, wurde aber als SPECIAL deklariert."
  1761.                         //: ENGLISH "FUNCTION: ~ is not a symbol, cannot be declared SPECIAL"
  1762.                         //: FRANCAIS "FUNCTION: ~ n'est pas un symbôle mais fut déclaré SPECIAL."
  1763.                         fehler(program_error, GETTEXT("FUNCTION: ~ is not a symbol, cannot be declared SPECIAL"));
  1764.                       }
  1765.                     # Symbol im STACK ablegen:
  1766.                     check_STACK(); pushSTACK(sym); spec_count++; var_count++;
  1767.                     declspec = Cdr(declspec);
  1768.               }   }
  1769.             # sonstige Deklaration verarbeiten:
  1770.             pushSTACK(Cdr(declarations)); # declarations verkürzen und retten
  1771.             {var reg2 object denv = TheIclosure(*closure_)->clos_decl_env;
  1772.              denv = augment_decl_env(declspec,denv);
  1773.              TheIclosure(*closure_)->clos_decl_env = denv;
  1774.             }
  1775.             declarations = popSTACK();
  1776.        }  }
  1777.        {var reg2 object lambdalist = *(closure_ STACKop -1); # restliche Lambdaliste
  1778.         var reg1 object item; # Element der Lambdaliste
  1779.         # Macro:
  1780.         # NEXT_ITEM(&OPTIONAL_label,&REST_label,&KEY_label,
  1781.         #           &ALLOW-OTHER-KEYS_label,&AUX_label,Ende_label)
  1782.         # verkürzt den Lambdalistenrest, bringt das nächste Element nach item
  1783.         # und springt im Falle eines der 6 angegebenen Lambdalistenmarker an
  1784.         # die entsprechenden Stellen.
  1785.           #define NEXT_ITEM(opt_label,rest_label,key_label,allow_label,aux_label,end_label)  \
  1786.             { if (atomp(lambdalist)) goto end_label; # Lambda-Liste zu Ende?              \
  1787.               item = Car(lambdalist); # nächstes Element                                  \
  1788.               lambdalist = Cdr(lambdalist); # Liste verkürzen                             \
  1789.               if (eq(item,S(LLoptional)))         goto opt_label;   # &OPTIONAL ?         \
  1790.               if (eq(item,S(LLrest)))             goto rest_label;  # &REST ?             \
  1791.               if (eq(item,S(LLkey)))              goto key_label;   # &KEY ?              \
  1792.               if (eq(item,S(LLallow_other_keys))) goto allow_label; # &ALLOW-OTHER-KEYS ? \
  1793.               if (eq(item,S(LLaux)))              goto aux_label;   # &AUX ?              \
  1794.             }
  1795.         req: # required-Parameter abarbeiten und auf dem STACK ablegen:
  1796.         loop
  1797.           { NEXT_ITEM(opt,rest,key,badLLkey,aux,ende);
  1798.             if (!symbolp(item)) goto fehler_symbol;
  1799.             if (constantp(TheSymbol(item))) goto fehler_constant;
  1800.             # Variable im STACK ablegen:
  1801.             check_STACK();
  1802.             pushSTACK(item); pushSTACK(Fixnum_0); req_count++; var_count++;
  1803.           }
  1804.         opt: # &OPTIONAL-Parameter abarbeiten, auf dem STACK ablegen und
  1805.              # Init-Formen in die Closure stecken:
  1806.         loop
  1807.           { NEXT_ITEM(badLLkey,rest,key,badLLkey,aux,ende);
  1808.            {var reg7 object init_form;
  1809.             # Parse Variablenspezifikation in item:
  1810.             #   var  oder  (var [init [svar]])
  1811.             # Lege var und evtl. svar auf den STACK, setze in var evtl.
  1812.             # das svar_bit. Liefert auch init (oder NIL) in init_form.
  1813.             check_STACK();
  1814.             if (atomp(item))
  1815.               { if (!symbolp(item)) goto fehler_symbol;
  1816.                 if (constantp(TheSymbol(item))) goto fehler_constant;
  1817.                 # Variable im STACK ablegen:
  1818.                 pushSTACK(item); pushSTACK(Fixnum_0); opt_count++; var_count++;
  1819.                 init_form = NIL; # Default-Init
  1820.               }
  1821.               else
  1822.               { var reg4 object item_rest = Cdr(item);
  1823.                 item = Car(item); # erstes Listenelement: var
  1824.                 if (!symbolp(item)) goto fehler_symbol;
  1825.                 if (constantp(TheSymbol(item))) goto fehler_constant;
  1826.                 # Variable im STACK ablegen:
  1827.                 pushSTACK(item); pushSTACK(Fixnum_0); opt_count++; var_count++;
  1828.                 if (consp(item_rest))
  1829.                   { init_form = Car(item_rest); # zweites Listenelement: init
  1830.                     item_rest = Cdr(item_rest);
  1831.                     if (consp(item_rest))
  1832.                       { if (mconsp(Cdr(item_rest)))
  1833.                           # varspec ist zu lang
  1834.                           { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  1835.                             //: DEUTSCH "FUNCTION: Zu lange Variablenspezifikation nach &OPTIONAL: ~"
  1836.                             //: ENGLISH "FUNCTION: too long variable specification after &OPTIONAL: ~"
  1837.                             //: FRANCAIS "FUNCTION: Spécification de variable trop longue après &OPTIONAL : ~"
  1838.                             fehler(program_error, GETTEXT("FUNCTION: too long variable specification after &OPTIONAL: ~"));
  1839.                           }
  1840.                         item = Car(item_rest); # drittes Listenelement: svar
  1841.                         if (!symbolp(item)) goto fehler_symbol;
  1842.                         if (constantp(TheSymbol(item))) goto fehler_constant;
  1843.                         # svar-Bit für var setzen:
  1844.                         STACK_0 = fixnum_inc(STACK_0,bit(svar_bit));
  1845.                         # Variable im STACK ablegen:
  1846.                         pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
  1847.                   }   }
  1848.                   else
  1849.                   { init_form = NIL; } # Default-Init
  1850.               }
  1851.             # init_form vor (clos_opt_inits closure) pushen:
  1852.             pushSTACK(lambdalist); pushSTACK(init_form);
  1853.             { var reg5 object new_cons = allocate_cons();
  1854.               Car(new_cons) = popSTACK();
  1855.              {var reg6 object closure = *closure_;
  1856.               Cdr(new_cons) = TheIclosure(closure)->clos_opt_inits;
  1857.               TheIclosure(closure)->clos_opt_inits = new_cons;
  1858.             }}
  1859.             lambdalist = popSTACK();
  1860.           }}
  1861.         rest: # &REST-Parameter abarbeiten und auf dem Stack ablegen:
  1862.         { NEXT_ITEM(badrest,badrest,badrest,badrest,badrest,badrest);
  1863.           if (!symbolp(item)) goto fehler_symbol;
  1864.           if (constantp(TheSymbol(item))) goto fehler_constant;
  1865.           # Variable im STACK ablegen:
  1866.           pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
  1867.           # Rest-Flag auf T setzen:
  1868.           TheIclosure(*closure_)->clos_rest_flag = T;
  1869.         }
  1870.         { NEXT_ITEM(badLLkey,badLLkey,key,badLLkey,aux,ende);
  1871.           pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  1872.           //: DEUTSCH "FUNCTION: Nach &REST var muß &KEY oder &AUX oder Listenende folgen: ~"
  1873.           //: ENGLISH "FUNCTION: &REST var must be followed by &KEY or &AUX or end of list: ~"
  1874.           //: FRANCAIS "FUNCTION: &KEY, &AUX ou fin de liste doit suivre une variable &REST : ~."
  1875.           fehler(program_error, GETTEXT("FUNCTION: &REST var must be followed by &KEY or &AUX or end of list: ~"));
  1876.         }
  1877.         badrest:
  1878.           pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  1879.           //: DEUTSCH "FUNCTION: Nach &REST muß Variable folgen: ~"
  1880.           //: ENGLISH "FUNCTION: &REST must be followed by a variable: ~"
  1881.           //: FRANCAIS "FUNCTION: Une variable doit suivre &REST : ~"
  1882.           fehler(program_error, GETTEXT("FUNCTION: &REST must be followed by a variable: ~"));
  1883.         key: # &KEY-Parameter abarbeiten, auf dem STACK ablegen
  1884.              # und Init-Formen in die Closure stecken:
  1885.         TheIclosure(*closure_)->clos_keywords = NIL; # keywords:=NIL
  1886.         loop
  1887.           { NEXT_ITEM(badLLkey,badLLkey,badLLkey,allow,aux,ende);
  1888.            {var reg8 object keyword;
  1889.             var reg7 object init_form;
  1890.             # Parse Variablenspezifikation in item:
  1891.             #   var  oder  (var [init [svar]])  oder ((key var) [init [svar]])
  1892.             # Lege var und evtl. svar auf den STACK, setze in var evtl.
  1893.             # das svar_bit. Liefert auch das Keyword in keyword und
  1894.             # init (oder NIL) in init_form.
  1895.             check_STACK();
  1896.             if (atomp(item))
  1897.               { if (!symbolp(item)) goto fehler_symbol;
  1898.                 if (constantp(TheSymbol(item))) goto fehler_constant;
  1899.                 # Variable im STACK ablegen:
  1900.                 pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
  1901.                 # Keyword holen:
  1902.                 pushSTACK(lambdalist);
  1903.                 keyword = intern_keyword(Symbol_name(item));
  1904.                 lambdalist = popSTACK();
  1905.                 # Default-Init:
  1906.                 init_form = NIL;
  1907.               }
  1908.               else
  1909.               { var reg4 object item_rest = Cdr(item); # ([init [svar]])
  1910.                 item = Car(item); # erstes Listenelement: var oder (key var)
  1911.                 if (atomp(item))
  1912.                   # item = var
  1913.                   { if (!symbolp(item)) goto fehler_symbol;
  1914.                     if (constantp(TheSymbol(item))) goto fehler_constant;
  1915.                     # Variable im STACK ablegen:
  1916.                     pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
  1917.                     # Keyword holen:
  1918.                     pushSTACK(item_rest); pushSTACK(lambdalist);
  1919.                     keyword = intern_keyword(Symbol_name(item));
  1920.                     lambdalist = popSTACK(); item_rest = popSTACK();
  1921.                   }
  1922.                   else
  1923.                   # item = (key var)
  1924.                   { keyword = Car(item); # key
  1925.                     # sollte ein Keyword sein:
  1926.                     if (!(symbolp(keyword) && keywordp(keyword)))
  1927.                       { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  1928.                         pushSTACK(keyword);
  1929.                         //: DEUTSCH "FUNCTION: ~ in ~ ist kein Keyword."
  1930.                         //: ENGLISH "FUNCTION: ~ in ~ is not a keyword"
  1931.                         //: FRANCAIS "FUNCTION: ~ dans ~ n'est pas un mot-clé."
  1932.                         fehler(program_error, GETTEXT("FUNCTION: ~ in ~ is not a keyword"));
  1933.                       }
  1934.                     item = Cdr(item); # (var)
  1935.                     if (!(consp(item) && matomp(Cdr(item))))
  1936.                       goto fehler_keyspec;
  1937.                     item = Car(item); # var
  1938.                     if (!symbolp(item)) goto fehler_symbol;
  1939.                     if (constantp(TheSymbol(item))) goto fehler_constant;
  1940.                     # Variable im STACK ablegen:
  1941.                     pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
  1942.                   }
  1943.                 if (consp(item_rest))
  1944.                   { init_form = Car(item_rest); # zweites Listenelement: init
  1945.                     item_rest = Cdr(item_rest); # ([svar])
  1946.                     if (consp(item_rest))
  1947.                       { if (mconsp(Cdr(item_rest))) goto fehler_keyspec;
  1948.                         item = Car(item_rest); # drittes Listenelement: svar
  1949.                         if (!symbolp(item)) goto fehler_symbol;
  1950.                         if (constantp(TheSymbol(item))) goto fehler_constant;
  1951.                         # svar-Bit in var setzen:
  1952.                         STACK_0 = fixnum_inc(STACK_0,bit(svar_bit));
  1953.                         # Variable im STACK ablegen:
  1954.                         pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
  1955.                   }   }
  1956.                   else
  1957.                   { init_form = NIL; } # Default-Init
  1958.               }
  1959.             # keyword vor (clos_keywords closure) pushen und
  1960.             # init_form vor (clos_key_inits closure) pushen:
  1961.             pushSTACK(lambdalist); pushSTACK(init_form); pushSTACK(keyword);
  1962.             { var reg5 object new_cons = allocate_cons();
  1963.               Car(new_cons) = popSTACK();
  1964.              {var reg6 object closure = *closure_;
  1965.               Cdr(new_cons) = TheIclosure(closure)->clos_keywords;
  1966.               TheIclosure(closure)->clos_keywords = new_cons;
  1967.             }}
  1968.             { var reg5 object new_cons = allocate_cons();
  1969.               Car(new_cons) = popSTACK();
  1970.              {var reg6 object closure = *closure_;
  1971.               Cdr(new_cons) = TheIclosure(closure)->clos_key_inits;
  1972.               TheIclosure(closure)->clos_key_inits = new_cons;
  1973.             }}
  1974.             lambdalist = popSTACK();
  1975.           }}
  1976.         fehler_keyspec:
  1977.           pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  1978.           //: DEUTSCH "FUNCTION: Variablenspezifikation nach &KEY ist nicht korrekt: ~"
  1979.           //: ENGLISH "FUNCTION: incorrect variable specification after &KEY: ~"
  1980.           //: FRANCAIS "FUNCTION: Spécification de variable incorrecte après &KEY : ~"
  1981.           fehler(program_error, GETTEXT("FUNCTION: incorrect variable specification after &KEY: ~"));
  1982.         allow: # &ALLOW-OTHER-KEYS abarbeiten:
  1983.         { TheIclosure(*closure_)->clos_allow_flag = T; # Flag auf T setzen
  1984.           NEXT_ITEM(badLLkey,badLLkey,badLLkey,badLLkey,aux,ende);
  1985.           pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  1986.           //: DEUTSCH "FUNCTION: Auf &ALLOW-OTHER-KEYS muß &AUX oder Listenende folgen: ~"
  1987.           //: ENGLISH "FUNCTION: &ALLOW-OTHER-KEYS must be followed by &AUX or end of list: ~"
  1988.           //: FRANCAIS "FUNCTION: &AUX ou fin de liste doit suivre &ALLOW-OTHER-KEYS : ~"
  1989.           fehler(program_error, GETTEXT("FUNCTION: &ALLOW-OTHER-KEYS must be followed by &AUX or end of list: ~"));
  1990.         }
  1991.         aux: # &AUX-Parameter abarbeiten, auf dem STACK ablegen und
  1992.              # Init-Formen in die Closure stecken:
  1993.         loop
  1994.           { NEXT_ITEM(badLLkey,badLLkey,badLLkey,badLLkey,badLLkey,ende);
  1995.            {var reg7 object init_form;
  1996.             # Parse Variablenspezifikation in item:
  1997.             #   var  oder  (var [init])
  1998.             # Lege var auf den STACK.
  1999.             # Liefert auch init (oder NIL) in init_form.
  2000.             check_STACK();
  2001.             if (atomp(item))
  2002.               { if (!symbolp(item)) goto fehler_symbol;
  2003.                 if (constantp(TheSymbol(item))) goto fehler_constant;
  2004.                 # Variable im STACK ablegen:
  2005.                 pushSTACK(item); pushSTACK(Fixnum_0); aux_count++; var_count++;
  2006.                 init_form = NIL; # Default-Init
  2007.               }
  2008.               else
  2009.               { var reg4 object item_rest = Cdr(item);
  2010.                 item = Car(item); # erstes Listenelement: var
  2011.                 if (!symbolp(item)) goto fehler_symbol;
  2012.                 if (constantp(TheSymbol(item))) goto fehler_constant;
  2013.                 # Variable im STACK ablegen:
  2014.                 pushSTACK(item); pushSTACK(Fixnum_0); aux_count++; var_count++;
  2015.                 if (consp(item_rest))
  2016.                   { init_form = Car(item_rest); # zweites Listenelement: init
  2017.                     if (mconsp(Cdr(item_rest)))
  2018.                       # varspec ist zu lang
  2019.                       { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  2020.                         //: DEUTSCH "FUNCTION: Zu lange Variablenspezifikation nach &AUX: ~"
  2021.                         //: ENGLISH "FUNCTION: too long variable specification after &AUX: ~"
  2022.                         //: FRANCAIS "FUNCTION: Spécification de variable trop longue après &AUX : ~"
  2023.                         fehler(program_error, GETTEXT("FUNCTION: too long variable specification after &AUX: ~"));
  2024.                   }   }
  2025.                   else
  2026.                   { init_form = NIL; } # Default-Init
  2027.               }
  2028.             # init_form vor (clos_aux_inits closure) pushen:
  2029.             pushSTACK(lambdalist); pushSTACK(init_form);
  2030.             { var reg5 object new_cons = allocate_cons();
  2031.               Car(new_cons) = popSTACK();
  2032.              {var reg6 object closure = *closure_;
  2033.               Cdr(new_cons) = TheIclosure(closure)->clos_aux_inits;
  2034.               TheIclosure(closure)->clos_aux_inits = new_cons;
  2035.             }}
  2036.             lambdalist = popSTACK();
  2037.           }}
  2038.         # Gesammelte Fehlermeldungen:
  2039.         badLLkey:
  2040.           pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  2041.           pushSTACK(item);
  2042.           //: DEUTSCH "FUNCTION: Lambda-Listen-Keyword ~ an der falschen Stelle: ~"
  2043.           //: ENGLISH "FUNCTION: badly placed lambda-list keyword ~: ~"
  2044.           //: FRANCAIS "FUNCTION: Mot clé de liste lambda ~ mal placé : ~"
  2045.           fehler(program_error, GETTEXT("FUNCTION: badly placed lambda-list keyword ~: ~"));
  2046.         fehler_symbol:
  2047.           pushSTACK(item);
  2048.           //: DEUTSCH "FUNCTION: ~ ist kein Symbol und kann daher nicht als Variable verwendet werden."
  2049.           //: ENGLISH "FUNCTION: ~ is not a symbol, may not be used as a variable"
  2050.           //: FRANCAIS "FUNCTION: ~ n'est pas un symbole et ne peut donc pas être utilisé comme variable."
  2051.           fehler(program_error, GETTEXT("FUNCTION: ~ is not a symbol, may not be used as a variable"));
  2052.         fehler_constant:
  2053.           pushSTACK(item);
  2054.           //: DEUTSCH "FUNCTION: ~ ist eine Konstante und kann daher nicht als Variable verwendet werden."
  2055.           //: ENGLISH "FUNCTION: ~ is a constant, may not be used as a variable"
  2056.           //: FRANCAIS "FUNCTION: ~ est une constante et ne peut donc pas être utilisée comme variable."
  2057.           fehler(error, GETTEXT("FUNCTION: ~ is a constant, may not be used as a variable"));
  2058.         ende: # Listenende erreicht
  2059.         #undef NEXT_ITEM
  2060.         if (((uintL)~(uintL)0 > lp_limit_1) && (var_count > lp_limit_1)) # Zu viele Parameter?
  2061.           { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  2062.             //: DEUTSCH "FUNCTION: Zu viele Parameter in der Lambda-Liste ~"
  2063.             //: ENGLISH "FUNCTION: too many parameters in the lambda-list ~"
  2064.             //: FRANCAIS "FUNCTION: Trop de paramètres dans la liste lambda ~"
  2065.             fehler(program_error, GETTEXT("FUNCTION: too many parameters in the lambda-list ~"));
  2066.           }
  2067.         # Da nun var_count <= lp_limit_1, passen alle counts in ein uintC.
  2068.         if (!nullp(lambdalist)) # Lambda-Liste eine Dotted List?
  2069.           { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
  2070.             //: DEUTSCH "FUNCTION: Ein Punkt in der Lambda-Liste ist nur bei Macros erlaubt, nicht hier: ~"
  2071.             //: ENGLISH "FUNCTION: a dot in a lambda-list is allowed only for macros, not here: ~"
  2072.             //: FRANCAIS "FUNCTION: Un point dans une liste lambda n'est permis que pour des macros, pas ici : ~"
  2073.             fehler(program_error, GETTEXT("FUNCTION: a dot in a lambda-list is allowed only for macros, not here: ~"));
  2074.           }
  2075.         # Variablen zu einem Vektor zusammenfassen und in die Closure,
  2076.         # Variablenflags zu einem Byte-Vektor zusammenfassen und in die Closure:
  2077.         pushSTACK(allocate_bit_vector(intBsize*(var_count-spec_count))); # Byte-Vektor erzeugen
  2078.         { var reg8 object vars = allocate_vector(var_count); # Vektor erzeugen
  2079.           var reg8 object varflags = popSTACK();
  2080.           # Variablen in den Vektor schreiben (letzte hinten, erste vorne):
  2081.           { var reg4 object* ptr = &TheSvector(vars)->data[var_count];
  2082.             var reg5 uintB* ptrflags = &TheSbvector(varflags)->data[var_count-spec_count];
  2083.             var reg6 uintC count;
  2084.             dotimesC(count,var_count-spec_count,
  2085.               { *--ptrflags = (uintB)posfixnum_to_L(popSTACK());
  2086.                 *--ptr = popSTACK();
  2087.               });
  2088.             dotimesC(count,spec_count, { *--ptr = popSTACK(); } );
  2089.           }
  2090.          {var reg4 object closure = *closure_;
  2091.           TheIclosure(closure)->clos_vars     = vars;
  2092.           TheIclosure(closure)->clos_varflags = varflags;
  2093.         # Anzahlen in die Closure eintragen:
  2094.           TheIclosure(closure)->clos_spec_anz = fixnum(spec_count);
  2095.           TheIclosure(closure)->clos_req_anz  = fixnum(req_count);
  2096.           TheIclosure(closure)->clos_opt_anz  = fixnum(opt_count);
  2097.           TheIclosure(closure)->clos_key_anz  = fixnum(key_count);
  2098.           TheIclosure(closure)->clos_aux_anz  = fixnum(aux_count);
  2099.         # Im Variablen-Vektor sind die ersten spec_count Variablen die
  2100.         # SPECIAL-Deklarierten. In jeder übrigen Variablen wird das DYNAM_BIT
  2101.         # gesetzt, falls sie unter den SPECIAL-deklarierten vorkommt.
  2102.           if (!(spec_count==0))
  2103.             { # Schleife über die übrigen Variablen:
  2104.               var reg9 object* othervarptr = &TheSvector(vars)->data[spec_count];
  2105.               var reg9 uintB* othervarflagsptr = &TheSbvector(varflags)->data[0];
  2106.               var reg9 uintC count1;
  2107.               dotimesC(count1,var_count-spec_count,
  2108.                 { var reg7 object othervar = *othervarptr++; # nächste Variable
  2109.                   # Suche sie in den SPECIAL-deklarierten Variablen:
  2110.                   {var reg5 object* specvarptr = &TheSvector(vars)->data[0];
  2111.                    var reg6 uintC count2;
  2112.                    dotimespC(count2,spec_count,
  2113.                      { if (eq(*specvarptr++,othervar)) # gefunden?
  2114.                          # ja -> also ist die Variable othervar dynamisch zu binden.
  2115.                          { *othervarflagsptr |= bit(dynam_bit); break; }
  2116.                      });
  2117.                   }
  2118.                   othervarflagsptr++;
  2119.                 });
  2120.             }
  2121.         # Schließlich noch die akkumulierten Listen in der Closure umdrehen:
  2122.           nreverse(TheIclosure(closure)->clos_opt_inits);
  2123.           nreverse(TheIclosure(closure)->clos_keywords);
  2124.           nreverse(TheIclosure(closure)->clos_key_inits);
  2125.           nreverse(TheIclosure(closure)->clos_aux_inits);
  2126.         # Fertig.
  2127.         # Stackaufbau: closure, lambdalist.
  2128.           skipSTACK(2);
  2129.           return closure;
  2130.         }}
  2131.     }}}}
  2132.  
  2133. # UP: Wandelt ein Argument in eine Funktion um.
  2134. # coerce_function(obj)
  2135. # > obj: Objekt
  2136. # > subr_self: Aufrufer (ein SUBR)
  2137. # < ergebnis: Objekt als Funktion (SUBR oder Closure)
  2138. # kann GC auslösen
  2139.   global object coerce_function (object obj);
  2140.   global object coerce_function(obj)
  2141.     var reg1 object obj;
  2142.     { # obj sollte ein SUBR, eine Closure oder ein Lambdaausdruck sein.
  2143.       if (subrp(obj)) { return obj; } # SUBR ist OK
  2144.       elif (closurep(obj)) { return obj; } # Closure ist OK
  2145.       elif (consp(obj) && eq(Car(obj),S(lambda))) # Cons (LAMBDA . ...) ?
  2146.         # Lambda-Ausdruck wird sofort in eine Closure umgewandelt:
  2147.         { # leeres Environment für get_closure:
  2148.           var reg2 environment* env5;
  2149.           make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env5 = );
  2150.           # Closure bilden aus lambdabody = (cdr obj), name = :LAMBDA :
  2151.          {var reg3 object closure = get_closure(Cdr(obj),S(Klambda),env5);
  2152.           skipSTACK(5);
  2153.           return closure;
  2154.         }}
  2155.       #ifdef DYNAMIC_FFI
  2156.       elif (ffunctionp(obj)) { return obj; } # Foreign-Function ist OK
  2157.       #endif
  2158.       else
  2159.         { pushSTACK(obj);
  2160.           pushSTACK(TheSubr(subr_self)->name);
  2161.           //: DEUTSCH "~: ~ ist keine Funktion."
  2162.           //: ENGLISH "~: ~ is not a function"
  2163.           //: FRANCAIS "~: ~ n'est pas une fonction."
  2164.           fehler(error, GETTEXT("~: ~ is not a function"));
  2165.         }
  2166.     }
  2167.  
  2168. #ifdef DEBUG_EVAL
  2169.  
  2170. # Emit some trace output for a function call, to *funcall-trace-output*.
  2171. # trace_call(fun,type_of_call,caller_type);
  2172. # > object fun: function being called, a SUBR/FSUBR/Closure
  2173. # > uintB type_of_call: 'A' for apply, 'F' for funcall, 'B' for bytecode
  2174. # > uintB caller_type: 'F' for fsubr, 'S' for subr,
  2175. #                      'C' for cclosure, 'I' for iclosure
  2176. # kann GC auslösen
  2177.   local void trace_call (object fun, uintB type_of_call, uintB caller_type);
  2178.   local void trace_call(fun,type_of_call,caller_type)
  2179.     var reg1 object fun;
  2180.     var reg3 uintB type_of_call;
  2181.     var reg4 uintB caller_type;
  2182.     { var reg2 object stream = Symbol_value(S(funcall_trace_output)); # SYS::*FUNCALL-TRACE-OUTPUT*
  2183.       # No output until *funcall-trace-output* has been initialized:
  2184.       if (!streamp(stream)) return;
  2185.       pushSTACK(stream);
  2186.       if (cclosurep(fun))
  2187.         { pushSTACK(TheCclosure(fun)->clos_name);
  2188.           write_schar(&STACK_1,'c');
  2189.         }
  2190.       elif (closurep(fun))
  2191.         { pushSTACK(TheClosure(fun)->clos_name);
  2192.           write_schar(&STACK_1,'C');
  2193.         }
  2194.       elif (subrp(fun))
  2195.         { pushSTACK(TheSubr(fun)->name);
  2196.           write_schar(&STACK_1,'S');
  2197.         }
  2198.       elif (fsubrp(fun))
  2199.         { pushSTACK(TheFsubr(fun)->name);
  2200.           write_schar(&STACK_1,'F');
  2201.         }
  2202.       else
  2203.         { pushSTACK(NIL);
  2204.           write_schar(&STACK_1,'?');
  2205.         }
  2206.       write_schar(&STACK_1,type_of_call); # output type of call
  2207.       write_schar(&STACK_1,caller_type);  # output caller
  2208.       write_schar(&STACK_1,'[');
  2209.       prin1(&STACK_1,STACK_0);            # output function name
  2210.       write_schar(&STACK_1,']');
  2211.       terpri(&STACK_1);
  2212.       skipSTACK(2);
  2213.     }
  2214.  
  2215. #endif
  2216.  
  2217. # fehler_zuviel_caller(fun);
  2218. # > fun: Funktion
  2219.   nonreturning_function(local, fehler_zuviel_caller, (object fun, object caller_fun));
  2220.   local void fehler_zuviel_caller(fun, caller_fun)
  2221.     var reg1 object fun;
  2222.     var reg1 object caller_fun;
  2223.     { pushSTACK(fun);
  2224.       pushSTACK(caller_fun);
  2225.       //: DEUTSCH "~: Zu viele Argumente für ~"
  2226.       //: ENGLISH "~: too many arguments given to ~"
  2227.       //: FRANCAIS "~: Trop d'arguments pour ~"
  2228.       fehler(error, GETTEXT("~: too many arguments given to ~"));
  2229.     }
  2230.  
  2231. # Fehlermeldung bei unpaarigen Keyword-Argumenten
  2232. # fehler_key_unpaarig(fun);
  2233. # > fun: Funktion
  2234.   nonreturning_function(local, fehler_key_unpaarig, (object fun));
  2235.   local void fehler_key_unpaarig(fun)
  2236.     var reg1 object fun;
  2237.     { pushSTACK(fun);
  2238.       //: DEUTSCH "EVAL/APPLY: Keyword-Argumente für ~ sind nicht paarig."
  2239.       //: ENGLISH "EVAL/APPLY: keyword arguments for ~ should occur pairwise"
  2240.       //: FRANCAIS "EVAL/APPLY: Les arguments mot-clé de ~ ne sont pas par paires."
  2241.       fehler(error, GETTEXT("EVAL/APPLY: keyword arguments for ~ should occur pairwise"));
  2242.     }
  2243.  
  2244. # Fehlermeldung bei zu vielen Keyword-Argumenten
  2245. # fehler_zuviel_eval_apply(fun);
  2246. # > fun: Funktion
  2247.   nonreturning_function(local, fehler_zuviel_eval_apply, (object fun));
  2248.   local void fehler_zuviel_eval_apply(fun)
  2249.     var reg1 object fun;
  2250.     { pushSTACK(fun);
  2251.       //: DEUTSCH "EVAL/APPLY: Zu viele Argumente für ~"
  2252.       //: ENGLISH "EVAL/APPLY: too many arguments given to ~"
  2253.       //: FRANCAIS "EVAL/APPLY: Trop d'arguments pour ~"
  2254.       fehler(error, GETTEXT("EVAL/APPLY: too many arguments given to ~"));
  2255.     }
  2256. #define fehler_key_zuviel fehler_zuviel_eval_apply
  2257.  
  2258. # Fehlermeldung bei fehlerhaftem Keyword
  2259. # fehler_key_notkw(kw);
  2260. # > kw: Nicht-Keyword
  2261.   nonreturning_function(local, fehler_key_notkw, (object kw));
  2262.   local void fehler_key_notkw(kw)
  2263.     var reg1 object kw;
  2264.     { pushSTACK(kw); # Wert für Slot DATUM von TYPE-ERROR
  2265.       pushSTACK(S(keyword)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  2266.       pushSTACK(kw);
  2267.       //: DEUTSCH "EVAL/APPLY: ~ ist kein Keyword."
  2268.       //: ENGLISH "EVAL/APPLY: ~ is not a keyword"
  2269.       //: FRANCAIS "EVAL/APPLY: ~ n'est pas un mot-clé."
  2270.       fehler(type_error, GETTEXT("EVAL/APPLY: ~ is not a keyword"));
  2271.     }
  2272.  
  2273. # Fehlermeldung bei fehlerhaftem Keyword
  2274. # fehler_key_badkw(fun,kw,kwlist);
  2275. # > fun: Funktion
  2276. # > kw: unzulässiges Keyword
  2277. # > kwlist: Liste der zugelassenen Keywords
  2278.   nonreturning_function(local, fehler_key_badkw, (object fun, object kw, object kwlist));
  2279.   local void fehler_key_badkw(fun,kw,kwlist)
  2280.     var reg2 object fun;
  2281.     var reg3 object kw;
  2282.     var reg1 object kwlist;
  2283.     { pushSTACK(kwlist);
  2284.       pushSTACK(fun);
  2285.       pushSTACK(kw);
  2286.       //: DEUTSCH "EVAL/APPLY: Das Keyword ~ ist bei ~ nicht erlaubt. Die möglichen Keywords sind ~"
  2287.       //: ENGLISH "EVAL/APPLY: keyword ~ is illegal for ~. The possible keywords are ~"
  2288.       //: FRANCAIS "EVAL/APPLY: Le mot-clé ~ n'est pas permis pour ~. Possibles sont ~"
  2289.       fehler(error, GETTEXT("EVAL/APPLY: keyword ~ is illegal for ~. The possible keywords are ~"));
  2290.     }
  2291.  
  2292. # Test auf unerlaubte Keywords
  2293. # check_for_illegal_keywords(allow_flag,fehler_statement);
  2294. # > uintC argcount: Anzahl der Keyword/Value-Paare
  2295. # > object* rest_args_pointer: Pointer über die 2*argcount restlichen Argumente
  2296. # > boolean allow_flag: Flag, ob &ALLOW-OTHER-KEYS angegeben war
  2297. # > for_every_keyword: Macro, der alle Keywords durchläuft und an 'keyword'
  2298. #                      zuweist.
  2299. # > fehler_statement: Statement, das meldet, daß bad_keyword illegal ist.
  2300.   #define check_for_illegal_keywords(allow_flag_expr,fehler_statement)  \
  2301.     { var reg6 object* argptr = rest_args_pointer; # Pointer in die Argumente \
  2302.       var reg8 object bad_keyword = nullobj; # erstes unerlaubtes Keyword oder nullobj \
  2303.       var reg4 boolean allow_flag = # Flag für allow-other-keys (ob           \
  2304.         # &ALLOW-OTHER-KEYS angegeben war oder ':ALLOW-OTHER-KEY T' vorkam)   \
  2305.         (allow_flag_expr);                                                    \
  2306.       var reg9 uintC check_count;                                             \
  2307.       dotimesC(check_count,argcount,                                          \
  2308.         { var reg3 object kw = NEXT(argptr); # nächstes Argument              \
  2309.           var reg7 object val = NEXT(argptr); # und Wert dazu                 \
  2310.           # muß ein Symbol, sollte ein Keyword sein:                          \
  2311.           if (!symbolp(kw))                                                   \
  2312.             { fehler_key_notkw(kw); }                                         \
  2313.           if (!allow_flag) # andere Keywords erlaubt? ja -> ok                \
  2314.             { if (eq(kw,S(Kallow_other_keys))) #  Kommt :ALLOW-OTHER-KEYS ?   \
  2315.                 { if (!nullp(val)) { allow_flag = TRUE; } }                   \
  2316.                 else                                                          \
  2317.                 # bis hierher war nicht :ALLOW-OTHER-KEYS da, und NOALLOW     \
  2318.                 { if (eq(bad_keyword,nullobj)) # bisher alle Keywords ok?     \
  2319.                     # muß testen, ob das Keyword kw erlaubt ist.              \
  2320.                     { for_every_keyword(                                      \
  2321.                         { if (eq(keyword,kw)) goto kw_ok; }                   \
  2322.                         );                                                    \
  2323.                       # Keyword kw war nicht erlaubt.                         \
  2324.                       bad_keyword = kw;                                       \
  2325.                       kw_ok: ;                                                \
  2326.             }   }   }                                                         \
  2327.         });                                                                   \
  2328.       if (!allow_flag)                                                        \
  2329.         if (!eq(bad_keyword,nullobj))                                         \
  2330.           # falsches Keyword aufgetreten                                      \
  2331.           { if (!keywordp(bad_keyword))                                       \
  2332.               { fehler_key_notkw(bad_keyword); }                              \
  2333.               else                                                            \
  2334.               { fehler_statement }                                            \
  2335.           }                                                                   \
  2336.     }
  2337.  
  2338. # Zu einem Keyword 'keyword' das Paar Key.Wert suchen:
  2339. # find_keyword_value( notfound_statement, found_statement );
  2340. # > keyword: Keyword
  2341. # > uintC argcount: Anzahl der Keyword/Value-Paare
  2342. # > object* rest_args_pointer: Pointer über die 2*argcount restlichen Argumente
  2343. # > notfound_statement: Was zu tun ist, wenn nicht gefunden
  2344. # > found_statement: Was zu tun ist, wenn Wert value gefunden
  2345.   #define find_keyword_value(notfound_statement,found_statement)  \
  2346.     { var reg1 object* argptr = rest_args_pointer;                          \
  2347.       var reg2 uintC find_count;                                            \
  2348.       dotimesC(find_count,argcount,                                         \
  2349.         { if (eq(NEXT(argptr),keyword)) goto kw_found; # richtiges Keyword? \
  2350.           NEXT(argptr);                                                     \
  2351.         });                                                                 \
  2352.       if (TRUE)                                                             \
  2353.         # nicht gefunden                                                    \
  2354.         { notfound_statement }                                              \
  2355.         else                                                                \
  2356.         kw_found: # gefunden                                                \
  2357.         { var reg1 object value = NEXT(argptr);                             \
  2358.           found_statement                                                   \
  2359.         }                                                                   \
  2360.     }
  2361.  
  2362. # UP: Wendet eine interpretierte Closure auf Argumente an.
  2363. # funcall_iclosure(closure,args_pointer,argcount);
  2364. # > closure: Closure
  2365. # > args_pointer: Pointer über die Argumente (im Stack)
  2366. # > argcount: Anzahl der Argumente
  2367. # < mv_count/mv_space: Werte
  2368. # < STACK: aufgeräumt, = args_pointer
  2369. # kann GC auslösen
  2370.   local Values funcall_iclosure (object closure, object* args_pointer, uintC argcount);
  2371.   local Values funcall_iclosure(closure,args_pointer,argcount)
  2372.     var reg5 object closure;
  2373.     var reg8 object* args_pointer;
  2374.     var reg9 uintC argcount;
  2375.     { # 1. Schritt: APPLY-Frame zu Ende aufbauen:
  2376.       var jmp_buf my_jmp_buf;
  2377.       #ifdef DEBUG_EVAL
  2378.       if (sym_streamp(S(funcall_trace_output)))
  2379.         { pushSTACK(closure); trace_call(closure,'F','I'); closure = popSTACK(); }
  2380.       #endif
  2381.       { var reg1 object* top_of_frame = args_pointer; # Pointer übern Frame
  2382.         pushSTACK(closure);
  2383.         finish_entry_frame(APPLY,&!my_jmp_buf,_EMA_,
  2384.           { if (mv_count==0) # nach Wiedereintritt: Form übergeben?
  2385.               { closure = STACK_(frame_closure); # selben APPLY nochmals versuchen
  2386.                 args_pointer = topofframe(STACK_0);
  2387.                 argcount = STACK_item_count(STACK STACKop frame_args,args_pointer);
  2388.               }
  2389.               else
  2390.               { setSTACK(STACK = topofframe(STACK_0)); # STACK aufräumen # oder unwind() ??
  2391.                 eval_noenv(value1); return; # übergebene Form evaluieren
  2392.           }   }
  2393.           );
  2394.       }
  2395.      {var reg10 object* closure_ = &STACK_(frame_closure); # Pointer auf die Closure
  2396.       var reg1 object* frame_pointer; # Pointer in den Frame
  2397.       # 2. Schritt: Variablenbindungsframe aufbauen:
  2398.       { var reg8 object* top_of_frame = STACK; # Pointer übern Frame
  2399.         var reg6 object vars = TheIclosure(closure)->clos_vars; # Vektor mit Variablennamen
  2400.         var reg7 uintL var_count = TheSvector(vars)->length; # Anzahl der Variablen
  2401.         get_space_on_STACK(var_count * 2 * sizeof(object)); # Platz reservieren
  2402.         { var reg3 object* varptr = &TheSvector(vars)->data[0]; # Pointer auf Variablen im Vektor
  2403.           var reg9 uintC spec_count = posfixnum_to_L(TheIclosure(closure)->clos_spec_anz);
  2404.           var reg4 uintC count;
  2405.           # erst die Special-Referenzen:
  2406.           dotimesC(count,spec_count,
  2407.             { # Bindung mit "Wert" specdecl:
  2408.               pushSTACK(specdecl);
  2409.               pushSTACK_symbolwithflags(*varptr++,wbit(active_bit_o)); # Bindung schon mal als aktiv vormerken
  2410.             });
  2411.           frame_pointer = args_end_pointer;
  2412.          {var reg3 uintB* varflagsptr = &TheSbvector(TheIclosure(closure)->clos_varflags)->data[0];
  2413.           dotimesC(count,var_count-spec_count,
  2414.             { pushSTACK(NIL); # NIL als vorläufiger Wert
  2415.              {var reg2 object next_var = *varptr++; # nächste Variable
  2416.               var reg1 oint next_varflags = (oint)(*varflagsptr++)<<oint_symbolflags_shift; # mit evtl. dynam_bit, svar_bit
  2417.               if (special_var_p(TheSymbol(next_var))) # SPECIAL-proklamiert?
  2418.                 { next_varflags |= wbit(dynam_bit_o); } # -> dynamisch binden
  2419.               pushSTACK_symbolwithflags(next_var,next_varflags);
  2420.             }});
  2421.         }}
  2422.         # VAR_ENV der Closure wird NEXT_ENV im Frame:
  2423.         pushSTACK(TheIclosure(closure)->clos_var_env);
  2424.         pushSTACK(as_object(var_count)); # var_count Bindungen, alle noch ungenestet
  2425.         finish_frame(VAR);
  2426.       }
  2427.       # STACK zeigt nun unter den Variablenbindungs-Frame.
  2428.       # frame_pointer = Pointer in den Variablenbindungsframe, über die erste
  2429.       # noch inaktive Bindung, unter die bereits aktiven SPECIAL-Referenzen.
  2430.       {var reg10 object new_var_env = make_framepointer(STACK);
  2431.        # Dieser Frame wird nachher zum neuen VAR_ENV.
  2432.       # 3. Schritt: aktuelle Environments binden:
  2433.        make_ENV5_frame();
  2434.       # Das Closure-Environment aktivieren:
  2435.        aktenv.var_env   = new_var_env; # Variablenbindungsframe
  2436.        aktenv.fun_env   = TheIclosure(closure)->clos_fun_env;
  2437.        aktenv.block_env = TheIclosure(closure)->clos_block_env;
  2438.        aktenv.go_env    = TheIclosure(closure)->clos_go_env;
  2439.        aktenv.decl_env  = TheIclosure(closure)->clos_decl_env;
  2440.       }
  2441.       # Stackaufbau:
  2442.       #   APPLY-Frame
  2443.       #   Variablenbindungsframe
  2444.       #   ENV-Frame
  2445.       # 4. Schritt: Parameter abarbeiten:
  2446.       { check_SP();
  2447.         # Macro zum Binden von Variablen im Variablenframe:
  2448.         # Bindet die nächste Variable an value, erniedrigt frame_pointer um 2 bzw. 3.
  2449.         # (Benutzt, daß varframe_binding_mark = 0 !)
  2450.  
  2451.         #define bind_next_var(value,markptr_zuweisung)  \
  2452.           { frame_pointer skipSTACKop -varframe_binding_size;                                  \
  2453.            {var reg2 object* markptr = markptr_zuweisung &Before(frame_pointer);               \
  2454.             if (*(oint*)(markptr) & wbit(dynam_bit_o))                                         \
  2455.               # dynamische Bindung aktivieren:                                                 \
  2456.               { var reg3 object sym = *(markptr STACKop varframe_binding_sym); # Variable      \
  2457.                 *(markptr STACKop varframe_binding_value) = Symbolflagged_value(sym); # alten Wert in den Frame \
  2458.                 *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren                  \
  2459.                 set_Symbolflagged_value_on(sym,value,markptr); # neuen Wert in die Wertzelle            \
  2460.                 closure = *closure_; \
  2461.               }                                                                                \
  2462.               else                                                                             \
  2463.               # statische Bindung aktivieren:                                                  \
  2464.               { *(markptr STACKop varframe_binding_value) = (value); # neuen Wert in den Frame \
  2465.                 *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren                  \
  2466.               }                                                                                \
  2467.           } }
  2468.         # required-Parameter abarbeiten:
  2469.         # Es ist das jeweils nächste Argument zu holen und im Stack zu binden.
  2470.         { var reg7 uintC count = posfixnum_to_L(TheIclosure(closure)->clos_req_anz);
  2471.           if (count>0)
  2472.             { if (argcount < count)
  2473.                 { pushSTACK(TheIclosure(closure)->clos_name);
  2474.                   //: DEUTSCH "EVAL/APPLY: Zu wenig Argumente für ~"
  2475.                   //: ENGLISH "EVAL/APPLY: too few arguments given to ~"
  2476.                   //: FRANCAIS "EVAL/APPLY: Trop peu d'arguments pour ~"
  2477.                   fehler(error, GETTEXT("EVAL/APPLY: too few arguments given to ~"));
  2478.                 }
  2479.               argcount -= count;
  2480.               dotimespC(count,count,
  2481.                 { var reg6 object next_arg = NEXT(args_pointer); # nächstes Argument
  2482.                   bind_next_var(next_arg,_EMA_); # nächste Variable binden
  2483.                 });
  2484.         }   }
  2485.         # optionale Parameter abarbeiten:
  2486.         # Es ist jeweils das nächste Argument zu holen; falls keines vorliegt,
  2487.         # eine Init-Form auszuführen; dann im Stack zu binden.
  2488.         { var reg8 uintC count = posfixnum_to_L(TheIclosure(closure)->clos_opt_anz);
  2489.           if (count==0) goto optional_ende;
  2490.          {var reg7 object inits = TheIclosure(closure)->clos_opt_inits; # Init-Formen
  2491.           var reg9 object *inits_ptr;
  2492.           pushSTACK(inits);
  2493.           inits_ptr = &STACK_0;
  2494.           do { if (argcount==0) goto optional_aus;
  2495.                argcount--;
  2496.               {var reg7 object next_arg = NEXT(args_pointer); # nächstes Argument
  2497.                {var reg6 object* optmarkptr;
  2498.                 bind_next_var(next_arg,optmarkptr=); # nächste Variable binden
  2499.                 if (*(oint*)optmarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
  2500.                   { *(oint*)optmarkptr &= ~wbit(svar_bit_o);
  2501.                     bind_next_var(T,_EMA_); # ja -> an T binden
  2502.                }  }
  2503.                *inits_ptr=(Cdr(*inits_ptr)); # Init-Formen-Liste verkürzen
  2504.                count--;
  2505.              }}
  2506.              until (count==0);
  2507.           skipSTACK(1);
  2508.           goto optional_ende;
  2509.           optional_aus: ; # Hier sind die optionalen Argumente ausgegangen.
  2510.          }# Ab hier alle Init-Formen der optionalen Parameter ausführen:
  2511.           dotimespC(count,count,
  2512.             { var reg7 object inits = STACK_0; # restliche Initformen
  2513.               STACK_0 = Cdr(inits);
  2514.               inits = (eval(Car(inits)),value1); # nächste Initform, ausgewertet
  2515.              {var reg6 object* optmarkptr;
  2516.               bind_next_var(inits,optmarkptr=); # nächste Variable binden
  2517.               if (*(oint*)optmarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
  2518.                 { *(oint*)optmarkptr &= ~wbit(svar_bit_o);
  2519.                   bind_next_var(NIL,_EMA_); # ja -> an NIL binden
  2520.              }  }
  2521.             });
  2522.           closure = *closure_;
  2523.           # &REST-Parameter ohne Argumente initialisieren:
  2524.           if (!nullp(TheIclosure(closure)->clos_rest_flag)) # Rest-Flag?
  2525.             { bind_next_var(NIL,_EMA_); } # ja -> an NIL binden
  2526.           # &KEY-Parameter ohne Argumente initialisieren:
  2527.           count = posfixnum_to_L(TheIclosure(closure)->clos_key_anz); # Anzahl Keyword-Parameter
  2528.           if (count>0)
  2529.             { STACK_0 = TheIclosure(closure)->clos_key_inits; # zugehörige Init-Formen
  2530.               dotimespC(count,count,
  2531.                 { var reg7 object inits = STACK_0; # restliche Initformen
  2532.                   STACK_0 = Cdr(inits);
  2533.                   inits = (eval(Car(inits)),value1); # nächste Initform, ausgewertet
  2534.                  {var reg6 object* keymarkptr;
  2535.                   bind_next_var(inits,keymarkptr=); # nächste Variable binden
  2536.                   if (*(oint*)keymarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
  2537.                     { *(oint*)keymarkptr &= ~wbit(svar_bit_o);
  2538.                       bind_next_var(NIL,_EMA_); # ja -> an NIL binden
  2539.                  }  }
  2540.                 });
  2541.               closure = *closure_;
  2542.             }
  2543.           skipSTACK(1); # restliche Init-Formen vergessen
  2544.           goto aux; # weiter zu den AUX-Variablen
  2545.         }
  2546.         optional_ende:
  2547.         # &KEY-Parameter und &REST-Parameter vorbereiten:
  2548.         if (mnumberp(TheIclosure(closure)->clos_keywords) # keyword eine Zahl?
  2549.             && nullp(TheIclosure(closure)->clos_rest_flag) # und kein Rest-Parameter?
  2550.            )
  2551.           # ja -> weder &KEY noch &REST angegeben
  2552.           { if (argcount>0) # noch Argumente da -> Fehler
  2553.               fehler_zuviel_eval_apply(TheIclosure(closure)->clos_name);
  2554.           }
  2555.           else
  2556.           # &KEY oder &REST vorhanden.
  2557.           { # &REST-Parameter abarbeiten:
  2558.             if (!nullp(TheIclosure(closure)->clos_rest_flag)) # Rest-Parameter vorhanden?
  2559.               # ja -> übrige Argumente zu einer Liste zusammenfassen:
  2560.               { pushSTACK(NIL); # Listenanfang
  2561.                 if (argcount>0)
  2562.                   {var reg3 object* ptr = args_pointer STACKop -(uintP)argcount;
  2563.                    var reg4 uintC count;
  2564.                    dotimespC(count,argcount,
  2565.                      { var reg2 object new_cons = allocate_cons();
  2566.                        Car(new_cons) = BEFORE(ptr);
  2567.                        Cdr(new_cons) = STACK_0;
  2568.                        STACK_0 = new_cons;
  2569.                      });
  2570.                     closure = *closure_;
  2571.                   }
  2572.                {var reg6 object list = popSTACK(); # Gesamtliste
  2573.                 bind_next_var(list,_EMA_); # &REST-Parameter an diese Liste binden
  2574.               }}
  2575.             # &KEY-Parameter abarbeiten:
  2576.             if (!mnumberp(TheIclosure(closure)->clos_keywords))
  2577.               # Keyword-Parameter vorhanden
  2578.               { var reg10 object* rest_args_pointer = args_pointer;
  2579.                 # argcount = Anzahl restlicher Argumente
  2580.                 # argcount halbieren, gibt die Anzahl der Paare Key.Wert:
  2581.                 if (!((argcount%2)==0))
  2582.                   # Anzahl war ungerade -> nicht paarig:
  2583.                   { fehler_key_unpaarig(TheIclosure(closure)->clos_name); }
  2584.                 argcount = argcount/2;
  2585.                 # Test auf unerlaubte Keywords:
  2586.                 { var reg10 object keywords = TheIclosure(closure)->clos_keywords;
  2587.                   #define for_every_keyword(statement)  \
  2588.                     { var reg2 object keywordsr = keywords;         \
  2589.                       while (consp(keywordsr))                      \
  2590.                         { var reg1 object keyword = Car(keywordsr); \
  2591.                           statement;                                \
  2592.                           keywordsr = Cdr(keywordsr);               \
  2593.                     }   }
  2594.                   check_for_illegal_keywords(
  2595.                     !nullp(TheIclosure(closure)->clos_allow_flag),
  2596.                     { fehler_key_badkw(TheIclosure(closure)->clos_name,
  2597.                                        bad_keyword,
  2598.                                        TheIclosure(closure)->clos_keywords);
  2599.                     }
  2600.                     );
  2601.                   #undef for_every_keyword
  2602.                 # Jetzt die Key-Werte zuordnen und die Key-Inits auswerten:
  2603.                  {var auto object key_inits = TheIclosure(closure)->clos_key_inits;
  2604.                   var reg10 uintC count;
  2605.                   var reg3 object *keywords_ptr;
  2606.                   var reg4 object *key_inits_ptr;
  2607.                   var reg6 object *svar_value_ptr;
  2608.  
  2609.                   pushSTACK(keywords); keywords_ptr=&STACK_0;
  2610.                   pushSTACK(key_inits); key_inits_ptr=&STACK_0;
  2611.                   pushSTACK(NIL); svar_value_ptr=&STACK_0;
  2612.                   dotimesC(count,posfixnum_to_L(TheIclosure(closure)->clos_key_anz),
  2613.                     { var reg8 object keyword = Car(*keywords_ptr); # Keyword
  2614.                       var reg7 object var_value;
  2615.                       # Zu diesem Keyword das Paar Key.Wert suchen:
  2616.                       find_keyword_value(
  2617.                         # nicht gefunden, muß den Init auswerten:
  2618.                         { var_value = (eval(Car(*key_inits_ptr)),value1);
  2619.                           *svar_value_ptr=NIL; # NIL für evtl. supplied-p-Parameter
  2620.                         },
  2621.                         # gefunden -> Wert nehmen:
  2622.                         { var_value = value;
  2623.                           *svar_value_ptr=T; # T für evtl. supplied-p-Parameter
  2624.                         }
  2625.                         );
  2626.                       {var reg6 object* keymarkptr;
  2627.                        bind_next_var(var_value,keymarkptr=); # Keyword-Variable binden
  2628.                        if (*(oint*)keymarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
  2629.                          { *(oint*)keymarkptr &= ~wbit(svar_bit_o);
  2630.                            bind_next_var(*svar_value_ptr,_EMA_); # ja -> an NIL bzw. T binden
  2631.                       }  }
  2632.                       *keywords_ptr=Cdr(*keywords_ptr);
  2633.                       *key_inits_ptr=Cdr(*key_inits_ptr);
  2634.                     });
  2635.                   skipSTACK(3);
  2636.                 }}
  2637.                 closure = *closure_;
  2638.           }   }
  2639.         aux: # &AUX-Parameter behandeln:
  2640.         { var reg7 uintC count = posfixnum_to_L(TheIclosure(closure)->clos_aux_anz);
  2641.           if (count>0)
  2642.             { pushSTACK(TheIclosure(closure)->clos_aux_inits); # Init-Formen für &AUX-Variablen
  2643.               dotimespC(count,count,
  2644.                 { var reg6 object inits = STACK_0;
  2645.                   STACK_0 = Cdr(inits);
  2646.                   inits = (eval(Car(inits)),value1); # nächstes Init auswerten
  2647.                   bind_next_var(inits,_EMA_); # und Variable daran binden
  2648.                 });
  2649.               skipSTACK(1); # restliche Init-Formen vergessen
  2650.               closure = *closure_;
  2651.         }   }
  2652.         #undef bind_next_var
  2653.       }
  2654.       # 5. Schritt: Body auswerten:
  2655.       implicit_progn(TheIclosure(closure)->clos_body,NIL);
  2656.       unwind(); # ENV-Frame auflösen
  2657.       unwind(); # Variablenbindungsframe auflösen
  2658.       unwind(); # APPLY-Frame auflösen
  2659.       # fertig
  2660.     }}
  2661.  
  2662. # UP: Besorgt die Zuordnung der Key-Argumente bei SUBRs.
  2663. # Nur aufzurufen, falls key_flag /= subr_nokey.
  2664. # > fun: Funktion, ein SUBR
  2665. # > argcount: Argumentezahl nach den optionalen
  2666. # > STACK_(argcount-1),...,STACK_0: die argcount Argumente nach den optionalen
  2667. # > key_args_pointer: Pointer über die Key-Parameter im STACK
  2668. # > rest_args_pointer: Pointer über die restlichen Argumente im STACK
  2669. # < STACK: korrekt gesetzt
  2670. # verändert STACK
  2671.   local void match_subr_key (object fun, uintL argcount, object* key_args_pointer, object* rest_args_pointer);
  2672.   local void match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer)
  2673.     var reg6 object fun;
  2674.     var reg9 uintL argcount;
  2675.     var reg10 object* key_args_pointer;
  2676.     var reg10 object* rest_args_pointer;
  2677.     { # argcount halbieren, gibt die Anzahl der Paare Key.Wert:
  2678.       if (!((argcount%2)==0))
  2679.         # Anzahl war ungerade -> nicht paarig:
  2680.         { fehler_key_unpaarig(fun); }
  2681.       if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
  2682.         { fehler_key_zuviel(fun); }
  2683.       # Da nun argcount <= ca_limit_1, passen alle count's in ein uintC.
  2684.       argcount = argcount/2;
  2685.       # Test auf unerlaubte Keywords:
  2686.       { var reg10 object* keywords_pointer = &TheSvector(TheSubr(fun)->keywords)->data[0];
  2687.         var reg10 uintC key_anz = TheSubr(fun)->key_anz;
  2688.         #define for_every_keyword(statement)  \
  2689.           { var reg1 object* keywordptr = keywords_pointer; \
  2690.             var reg2 uintC count;                           \
  2691.             dotimesC(count,key_anz,                         \
  2692.               { var reg1 object keyword = *keywordptr++;    \
  2693.                 statement;                                  \
  2694.               });                                           \
  2695.           }
  2696.         check_for_illegal_keywords(
  2697.           TheSubr(fun)->key_flag == subr_key_allow,
  2698.           { pushSTACK(bad_keyword); # fehlerhaftes Keyword retten
  2699.             # Keyword-Vektor in eine Liste umwandeln:
  2700.             # (SYS::COERCE-SEQUENCE kwvec 'LIST)
  2701.             coerce_sequence(TheSubr(fun)->keywords,S(list));
  2702.            {var reg1 object kwlist = value1;
  2703.             fehler_key_badkw(fun,popSTACK(),kwlist);
  2704.           }}
  2705.           );
  2706.         #undef for_every_keyword
  2707.       # Jetzt Argumente und Parameter zuordnen:
  2708.        {var reg4 object* keywordptr = keywords_pointer;
  2709.         var reg5 object* key_args_ptr = key_args_pointer;
  2710.         var reg7 uintC count;
  2711.         dotimesC(count,key_anz,
  2712.           { var reg3 object keyword = *keywordptr++; # Keyword
  2713.             # Zu diesem Keyword das Paar Key.Wert suchen:
  2714.             find_keyword_value(
  2715.               # nicht gefunden -> Wert bleibt #<UNBOUND> :
  2716.               { NEXT(key_args_ptr); },
  2717.               # gefunden -> Wert eintragen:
  2718.               { NEXT(key_args_ptr) = value; }
  2719.               );
  2720.           });
  2721.       }}
  2722.       # evtl. Rest-Parameter versorgen:
  2723.       if (TheSubr(fun)->rest_flag == subr_norest)
  2724.         # SUBR ohne &REST-Flag: restliche Argumente vergessen:
  2725.         { set_args_end_pointer(rest_args_pointer); }
  2726.         # SUBR mit &REST-Flag: restliche Argumente im Stack belassen
  2727.     }
  2728.  
  2729. # UP: Besorgt die Zuordnung zwischen Argumentliste und Keyword-Parametern
  2730. # und eventuellem Rest-Parameter einer compilierten Closure.
  2731. # > closure: compilierte Closure mit &KEY-Parametern
  2732. # > argcount: Argumentezahl nach den optionalen
  2733. # > STACK_(argcount-1),...,STACK_0: die argcount Argumente nach den optionalen
  2734. # > key_args_pointer: Pointer über die Key-Parameter im STACK
  2735. #                     (evtl. auch Pointer unter den Rest-Parameter im STACK,
  2736. #                      der = #<UNBOUND> ist, falls er noch zu versorgen ist)
  2737. # > rest_args_pointer: Pointer über die restlichen Argumente im STACK
  2738. # < STACK: korrekt gesetzt
  2739. # < ergebnis: closure
  2740. # verändert STACK
  2741. # kann GC auslösen
  2742.   local object match_cclosure_key (object closure, uintL argcount, object* key_args_pointer, object* rest_args_pointer);
  2743.   local object match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer)
  2744.     var reg10 object closure;
  2745.     var reg9 uintL argcount;
  2746.     var reg10 object* key_args_pointer;
  2747.     var reg9 object* rest_args_pointer;
  2748.     { # argcount halbieren, gibt die Anzahl der Paare Key.Wert:
  2749.       if (!((argcount%2)==0))
  2750.         # Anzahl war ungerade -> nicht paarig:
  2751.         { fehler_key_unpaarig(closure); }
  2752.       if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
  2753.         { fehler_key_zuviel(closure); }
  2754.       # Da nun argcount <= ca_limit_1, passen alle count's in ein uintC.
  2755.       argcount = argcount/2;
  2756.      {var reg10 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
  2757.       {var reg9 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keywords
  2758.        var reg10 uintL keywords_offset = *(uintW*)(&TheSbvector(codevec)->data[CCHD+8]); # Offset der Keywords in FUNC
  2759.        var reg6 object* keywords_pointer = # zeigt aufs erste Keyword
  2760.          (TheSbvector(codevec)->data[CCHD+4] & bit(4) # generische Funktion?
  2761.           ? &TheSvector(TheCclosure(closure)->clos_consts[0])->data[keywords_offset]
  2762.           : &TheCclosure(closure)->clos_consts[keywords_offset]
  2763.          );
  2764.       # Test auf unerlaubte Keywords:
  2765.         #define for_every_keyword(statement)  \
  2766.           { var reg1 object* keywordptr = keywords_pointer; \
  2767.             var reg2 uintC count;                        \
  2768.             dotimesC(count,key_anz,                      \
  2769.               { var reg1 object keyword = *keywordptr++; \
  2770.                 statement;                               \
  2771.               });                                        \
  2772.           }
  2773.         check_for_illegal_keywords(
  2774.           !((TheSbvector(codevec)->data[CCHD+4] & bit(6)) == 0),
  2775.           { pushSTACK(bad_keyword); # retten
  2776.             # Liste der erlaubten Keywords bilden:
  2777.             for_every_keyword( { pushSTACK(keyword); } );
  2778.            {var reg7 object kwlist = listof(key_anz);
  2779.             bad_keyword = popSTACK();
  2780.             # und Fehler melden:
  2781.             fehler_key_badkw(closure,bad_keyword,kwlist);
  2782.           }}
  2783.           );
  2784.         #undef for_every_keyword
  2785.       # Jetzt Argumente und Parameter zuordnen:
  2786.        {var reg4 object* keywordptr = keywords_pointer;
  2787.         var reg5 object* key_args_ptr = key_args_pointer;
  2788.         var reg6 uintC count;
  2789.         dotimesC(count,key_anz,
  2790.           { var reg3 object keyword = *keywordptr++; # Keyword
  2791.             # Zu diesem Keyword das Paar Key.Wert suchen:
  2792.             find_keyword_value(
  2793.               # nicht gefunden -> Wert bleibt #<UNBOUND> :
  2794.               { NEXT(key_args_ptr); },
  2795.               # gefunden -> Wert eintragen:
  2796.               { NEXT(key_args_ptr) = value; }
  2797.               );
  2798.           });
  2799.       }}
  2800.       # evtl. Rest-Parameter versorgen:
  2801.       if (TheSbvector(codevec)->data[CCHD+4] & bit(0)) # Rest-Flag?
  2802.         # Closure mit Keywords und &REST-Flag:
  2803.         { var reg2 object* rest_arg_ = &BEFORE(key_args_pointer); # Pointer auf den REST-Parameter
  2804.           if (eq(*rest_arg_,unbound))
  2805.             # muß noch gefüllt werden: Liste basteln
  2806.             { *rest_arg_ = closure; # Closure retten
  2807.              {var reg1 object rest_arg = NIL;
  2808.               until (args_end_pointer == rest_args_pointer)
  2809.                 { pushSTACK(rest_arg);
  2810.                   rest_arg = allocate_cons();
  2811.                   Cdr(rest_arg) = popSTACK();
  2812.                   Car(rest_arg) = popSTACK();
  2813.                 }
  2814.               closure = *rest_arg_; # Closure zurück
  2815.               *rest_arg_ = rest_arg;
  2816.             }}
  2817.             else
  2818.             # restliche Argumente vergessen:
  2819.             { set_args_end_pointer(rest_args_pointer); }
  2820.         }
  2821.         else
  2822.         # Closure ohne &REST-Flag: restliche Argumente vergessen:
  2823.         { set_args_end_pointer(rest_args_pointer); }
  2824.       return closure;
  2825.     }}
  2826.  
  2827.  
  2828. #           ----------------------- E V A L -----------------------
  2829.  
  2830. # später:
  2831.   local Values eval1 (object form);
  2832.   local Values eval_fsubr (object fun, object args);
  2833.   local Values eval_applyhook (object fun);
  2834.   local Values eval_subr (object fun);
  2835.   local Values eval_closure (object fun);
  2836.   #ifdef DYNAMIC_FFI
  2837.   local Values eval_ffunction (object fun);
  2838.   #endif
  2839.  
  2840. # UP: Wertet eine Form im aktuellen Environment aus.
  2841. # eval(form);
  2842. # > form: Form
  2843. # < mv_count/mv_space: Werte
  2844. # kann GC auslösen
  2845.   global Values eval (object form);
  2846.   global Values eval(form)
  2847.     var reg2 object form;
  2848.     { start:
  2849.       # Test auf Tastatur-Interrupt:
  2850.       interruptp(
  2851.         { pushSTACK(form); # form retten
  2852.           pushSTACK(S(eval)); tast_break(); # Break-Schleife aufrufen
  2853.           form = popSTACK();
  2854.           goto start;
  2855.         });
  2856.      {var jmp_buf my_jmp_buf;
  2857.       # EVAL-Frame aufbauen:
  2858.       { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  2859.         pushSTACK(form); # Form
  2860.         finish_entry_frame(EVAL,&!my_jmp_buf,_EMA_,
  2861.           { if (mv_count==0) # nach Wiedereintritt: Form übergeben?
  2862.               { form = STACK_(frame_form); } # selbe Form nochmal evaluieren
  2863.               else
  2864.               { form = STACK_(frame_form) = value1; } # übergebene Form evaluieren
  2865.           });
  2866.       }
  2867.       # Test auf *EVALHOOK*:
  2868.       { var reg1 object evalhook_value = Symbol_value(S(evalhookstern)); # *EVALHOOK*
  2869.         if (nullp(evalhook_value)) # *EVALHOOK* = NIL ?
  2870.           # ja -> normal weiter-evaluieren
  2871.           { pushSTACK(Symbol_value(S(applyhookstern))); eval1(form); }
  2872.           else
  2873.           { # *EVALHOOK*, *APPLYHOOK* an NIL binden:
  2874.             var reg2 object *form_ptr;
  2875.             var reg3 object *evalhook_value_ptr;
  2876.             pushSTACK(form); form_ptr=&STACK_0;
  2877.             pushSTACK(evalhook_value); evalhook_value_ptr=&STACK_0;
  2878.             bindhooks_NIL();
  2879.             evalhook_value = *evalhook_value_ptr;
  2880.             form = *form_ptr;
  2881.             pushSTACK(form); # Form als 1. Argument
  2882.             pushSTACK(evalhook_value); # Funktion retten
  2883.             # (FUNCALL *EVALHOOK* form env) ausführen:
  2884.            {var reg4 environment* stack_env = nest_aktenv(); # Environments in den Stack,
  2885.             var reg3 object env = allocate_vector(5); # in neu allozierten Vektor
  2886.             *(environment*)(&TheSvector(env)->data[0]) = *stack_env; # hineinschieben
  2887.             skipSTACK(5);
  2888.             evalhook_value = popSTACK(); # Funktion zurück
  2889.             pushSTACK(env); # gesamtes Environment als 2. Argument
  2890.             funcall(evalhook_value,2);
  2891.             # alte Werte von *EVALHOOK*, *APPLYHOOK* zurück:
  2892.             unwind();
  2893.             skipSTACK(2);
  2894.             # EVAL-Frame auflösen:
  2895.             unwind();
  2896.       }   }}
  2897.     }}
  2898.  
  2899. # UP: Wertet eine Form im aktuellen Environment aus. Nimmt dabei auf
  2900. # *EVALHOOK* und *APPLYHOOK* keine Rücksicht.
  2901. # eval_no_hooks(form);
  2902. # > form: Form
  2903. # < mv_count/mv_space: Werte
  2904. # kann GC auslösen
  2905.   global Values eval_no_hooks (object form);
  2906.   global Values eval_no_hooks(form)
  2907.     var reg2 object form;
  2908.     { var jmp_buf my_jmp_buf;
  2909.       # EVAL-Frame aufbauen:
  2910.       { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
  2911.         pushSTACK(form); # Form
  2912.         finish_entry_frame(EVAL,&!my_jmp_buf,_EMA_,
  2913.           { if (mv_count==0) # nach Wiedereintritt: Form übergeben?
  2914.               { form = STACK_(frame_form); } # selbe Form nochmal evaluieren
  2915.               else
  2916.               { form = STACK_(frame_form) = value1; } # übergebene Form evaluieren
  2917.           });
  2918.       }
  2919.       # weiterevaluieren, *APPLYHOOK* als NIL betrachten:
  2920.       { pushSTACK(NIL); eval1(form); }
  2921.     }
  2922.  
  2923. # UP: Wertet eine Form im aktuellen Environment aus.
  2924. # Nimmt dabei auf *EVALHOOK* keine Rücksicht, und erwartet den Wert von
  2925. # *APPLYHOOK*.
  2926. # Der EVAL-Frame muß bereits aufgebaut sein; er wird dann abgebaut.
  2927. # eval1(form);
  2928. # > form: Form
  2929. # > STACK_3..STACK_1: EVAL-Frame, mit Form in STACK_3
  2930. # > STACK_0: Wert von *APPLYHOOK*
  2931. # < mv_count/mv_space: Werte
  2932. # verändert STACK
  2933. # kann GC auslösen
  2934.   local Values eval1(form)
  2935.     var reg1 object form;
  2936.     { if (atomp(form))
  2937.         { if (symbolp(form))
  2938.             { # Form ist Symbol
  2939.               value1 = sym_value(form,aktenv.var_env); # Wert im aktuellen Environment
  2940.               if (eq(value1,unbound))
  2941.                 { pushSTACK(form); # Wert für Slot NAME von CELL-ERROR
  2942.                   pushSTACK(form);
  2943.                   //: DEUTSCH "EVAL: Die Variable ~ hat keinen Wert."
  2944.                   //: ENGLISH "EVAL: variable ~ has no value"
  2945.                   //: FRANCAIS "EVAL: La variable ~ n'a pas de valeur."
  2946.                   fehler(unbound_variable, GETTEXT("EVAL: variable ~ has no value"));
  2947.                 }
  2948.               elif (symbolmacrop(value1)) # Symbol-Macro?
  2949.                 # ja -> expandieren und erneut evaluieren:
  2950.                 { skipSTACK(1); # Wert von *APPLYHOOK* vergessen
  2951.                   check_SP(); check_STACK();
  2952.                   eval(TheSymbolmacro(value1)->symbolmacro_expansion); # Expansion evaluieren
  2953.                   unwind(); # EVAL-Frame auflösen
  2954.                 }
  2955.               else
  2956.                 { mv_count=1; # value1 als Wert
  2957.                   skipSTACK(1);
  2958.                   unwind(); # EVAL-Frame auflösen
  2959.                 }
  2960.             }
  2961.           else
  2962.             # self-evaluating form
  2963.             { value1 = form; mv_count=1; # form als Wert
  2964.               skipSTACK(1);
  2965.               unwind(); # EVAL-Frame auflösen
  2966.             }
  2967.         }
  2968.         else
  2969.         # Form ist ein Cons
  2970.         { # Feststellen, ob Macro-call, evtl. expandieren:
  2971.           macroexp(form,aktenv.var_env,aktenv.fun_env); form = value1;
  2972.           if (!nullp(value2)) # expandiert ?
  2973.             # jetzt erst richtig evaluieren:
  2974.             { skipSTACK(1); # Wert von *APPLYHOOK* vergessen
  2975.               check_SP(); check_STACK();
  2976.               eval(form); # expandierte Form evaluieren
  2977.               unwind(); # EVAL-Frame auflösen
  2978.             }
  2979.             else
  2980.             { var reg2 object fun = Car(form); # Funktionsbezeichnung
  2981.               if (funnamep(fun))
  2982.                 { # Funktionsdefinition im Environment holen:
  2983.                   fun = sym_function(fun,aktenv.fun_env);
  2984.                   # je nach Typ der Funktion verzweigen:
  2985.                   # unbound / SUBR/FSUBR/Closure / Macro-Cons
  2986.                   switch (typecode(fun))
  2987.                     { case_subr: # SUBR
  2988.                         pushSTACK(Cdr(form)); # Argumentliste
  2989.                         if (!nullp(STACK_1)) goto applyhook;
  2990.                         eval_subr(fun);
  2991.                         break;
  2992.                       case_closure: # Closure
  2993.                         pushSTACK(Cdr(form)); # Argumentliste
  2994.                         closure: # fun ist eine Closure
  2995.                         if (!nullp(STACK_1)) goto applyhook;
  2996.                         eval_closure(fun);
  2997.                         break;
  2998.                       applyhook: # Wert von *APPLYHOOK* ist /= NIL.
  2999.                         eval_applyhook(fun);
  3000.                         break;
  3001.                       case_orecord:
  3002.                         if (TheRecord(fun)->rectype == Rectype_Fsubr)
  3003.                           # Fsubr
  3004.                           { eval_fsubr(fun,Cdr(form)); break; }
  3005.                         #ifdef DYNAMIC_FFI
  3006.                         if (TheRecord(fun)->rectype == Rectype_Ffunction)
  3007.                           # Foreign-Function
  3008.                           { pushSTACK(Cdr(form)); # Argumentliste
  3009.                             if (!nullp(STACK_1)) goto applyhook;
  3010.                             eval_ffunction(fun);
  3011.                             break;
  3012.                           }
  3013.                         #endif
  3014.                       default:
  3015.                         pushSTACK(Car(form)); # Wert für Slot NAME von CELL-ERROR
  3016.                         pushSTACK(STACK_0);
  3017.                         //: DEUTSCH "EVAL: Die Funktion ~ ist undefiniert."
  3018.                         //: ENGLISH "EVAL: undefined function ~"
  3019.                         //: FRANCAIS "EVAL: La fonction ~ n'est pas définie."
  3020.                         fehler(undefined_function, GETTEXT("EVAL: undefined function ~"));
  3021.                 }   }
  3022.               elif (consp(fun) && eq(Car(fun),S(lambda))) # Lambda-Ausdruck?
  3023.                 { pushSTACK(Cdr(form)); # Argumentliste
  3024.                   fun = get_closure(Cdr(fun),S(Klambda),&aktenv); # Closure im aktuellen Environment erzeugen
  3025.                   goto closure; # und diese auf die Argumente anwenden, wie oben
  3026.                 }
  3027.               else
  3028.                 { pushSTACK(fun);
  3029.                   //: DEUTSCH "EVAL: ~ ist keine Funktionsbezeichnung."
  3030.                   //: ENGLISH "EVAL: ~ is not a function name"
  3031.                   //: FRANCAIS "EVAL: ~ n'est pas un nom de fonction."
  3032.                   fehler(error, GETTEXT("EVAL: ~ is not a function name"));
  3033.                 }
  3034.             }
  3035.         }
  3036.     }
  3037.  
  3038. # In EVAL: Wendet ein FSUBR auf eine Argumentliste an, räumt den STACK auf
  3039. # und liefert die Werte.
  3040. # eval_fsubr(fun,args);
  3041. # > fun: ein FSUBR
  3042. # > args: Argumentliste
  3043. # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*.
  3044. # < STACK: aufgeräumt
  3045. # < mv_count/mv_space: Werte
  3046. # verändert STACK
  3047. # kann GC auslösen
  3048.   local Values eval_fsubr(fun,args)
  3049.     var reg2 object fun;
  3050.     var reg1 object args;
  3051.     { skipSTACK(1); # Wert von *APPLYHOOK* vergessen
  3052.       check_SP(); check_STACK();
  3053.      #if STACKCHECKS
  3054.      {var reg3 object* STACKbefore = STACK;
  3055.      #endif
  3056.       # Argumente in den STACK legen:
  3057.       switch ((uintW)posfixnum_to_L(TheFsubr(fun)->argtype))
  3058.         { # Macro für 1 required-Parameter:
  3059.           #define REQ_PAR()  \
  3060.             { if (atomp(args)) goto fehler_zuwenig;                   \
  3061.               pushSTACK(Car(args)); # nächster Parameter in den STACK \
  3062.               args = Cdr(args);                                       \
  3063.             }
  3064.           case (uintW)fsubr_argtype_2_0_nobody:
  3065.             # FSUBR mit 2 required-Parametern
  3066.             REQ_PAR();
  3067.           case (uintW)fsubr_argtype_1_0_nobody:
  3068.             # FSUBR mit 1 required-Parameter
  3069.             REQ_PAR();
  3070.             if (!nullp(args)) goto fehler_zuviel;
  3071.             break;
  3072.           case (uintW)fsubr_argtype_2_1_nobody:
  3073.             # FSUBR mit 2 required-Parametern und 1 optional-Parameter
  3074.             REQ_PAR();
  3075.           case (uintW)fsubr_argtype_1_1_nobody:
  3076.             # FSUBR mit 1 required-Parameter und 1 optional-Parameter
  3077.             REQ_PAR();
  3078.             if (consp(args))
  3079.               { pushSTACK(Car(args)); # optionalen Parameter in den STACK
  3080.                 args = Cdr(args);
  3081.                 if (!nullp(args)) goto fehler_zuviel;
  3082.               }
  3083.               else
  3084.               { pushSTACK(unbound); # unbound stattdessen in den STACK
  3085.                 if (!nullp(args)) goto fehler_dotted;
  3086.               }
  3087.             break;
  3088.           case (uintW)fsubr_argtype_2_body:
  3089.             # FSUBR mit 2 required-Parametern und Body-Parameter
  3090.             REQ_PAR();
  3091.           case (uintW)fsubr_argtype_1_body:
  3092.             # FSUBR mit 1 required-Parameter und Body-Parameter
  3093.             REQ_PAR();
  3094.           case (uintW)fsubr_argtype_0_body:
  3095.             # FSUBR mit 0 required-Parametern und Body-Parameter
  3096.             pushSTACK(args); # restlichen Body in den STACK
  3097.             break;
  3098.           default: NOTREACHED
  3099.           fehler_zuwenig: # Argumentliste args ist vorzeitig ein Atom
  3100.             if (!nullp(args)) goto fehler_dotted;
  3101.             # STACK bis zum aufrufenden EVAL-Frame aufräumen:
  3102.             until (mtypecode(STACK_0) & bit(frame_bit_t)) { skipSTACK(1); }
  3103.             { var reg4 object form = STACK_(frame_form); # Form aus dem EVAL-Frame
  3104.               pushSTACK(form);
  3105.               pushSTACK(Car(form));
  3106.               //: DEUTSCH "EVAL: Zu wenig Parameter für Spezialform ~: ~"
  3107.               //: ENGLISH "EVAL: too few parameters for special-form ~: ~"
  3108.               //: FRANCAIS "EVAL: Trop peu de paramètres pour la forme spéciale ~ : ~"
  3109.               fehler(program_error, GETTEXT("EVAL: too few parameters for special-form ~: ~"));
  3110.             }
  3111.           fehler_zuviel: # Argumentliste args ist am Schluß nicht NIL
  3112.             if (atomp(args)) goto fehler_dotted;
  3113.             # STACK bis zum aufrufenden EVAL-Frame aufräumen:
  3114.             until (mtypecode(STACK_0) & bit(frame_bit_t)) { skipSTACK(1); }
  3115.             { var reg4 object form = STACK_(frame_form); # Form aus dem EVAL-Frame
  3116.               pushSTACK(form);
  3117.               pushSTACK(Car(form));
  3118.               //: DEUTSCH "EVAL: Zu viele Parameter für Spezialform ~: ~"
  3119.               //: ENGLISH "EVAL: too many parameters for special-form ~: ~"
  3120.               //: FRANCAIS "EVAL: Trop de paramètres pour la forme spéciale ~ : ~"
  3121.               fehler(program_error, GETTEXT("EVAL: too many parameters for special-form ~: ~"));
  3122.             }
  3123.           fehler_dotted: # Argumentliste args endet mit Atom /= NIL
  3124.             # STACK bis zum aufrufenden EVAL-Frame aufräumen:
  3125.             until (mtypecode(STACK_0) & bit(frame_bit_t)) { skipSTACK(1); }
  3126.             { var reg4 object form = STACK_(frame_form); # Form aus dem EVAL-Frame
  3127.               pushSTACK(form);
  3128.               pushSTACK(Car(form));
  3129.               //: DEUTSCH "EVAL: Parameterliste für Spezialform ~ ist dotted: ~"
  3130.               //: ENGLISH "EVAL: dotted parameter list for special form ~: ~"
  3131.               //: FRANCAIS "EVAL: La liste de paramètres pour la forme spéciale ~ est pointée."
  3132.               fehler(program_error, GETTEXT("EVAL: dotted parameter list for special form ~: ~"));
  3133.             }
  3134.           #undef REQ_PAR
  3135.         }
  3136.       # FSUBR selbst aufrufen:
  3137.       subr_self = fun;
  3138.       (*(fsubr_function*)TheMachine(TheFsubr(fun)->function))();
  3139.      #if STACKCHECKS
  3140.       if (!(STACK == STACKbefore)) # STACK so wie vorher?
  3141.         { abort(); } # nein -> ab in den Debugger
  3142.      }
  3143.      #endif
  3144.       unwind(); # EVAL-Frame auflösen
  3145.     }
  3146.  
  3147. # In EVAL: Wendet *APPLYHOOK* auf eine Funktion (SUBR oder Closure) und
  3148. # eine Argumentliste an, räumt den STACK auf und liefert die Werte.
  3149. # eval_applyhook(fun);
  3150. # > fun: Funktion, ein SUBR oder eine Closure
  3151. # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK* (/= NIL), Argumentliste.
  3152. # < STACK: aufgeräumt
  3153. # < mv_count/mv_space: Werte
  3154. # verändert STACK
  3155. # kann GC auslösen
  3156.   local Values eval_applyhook(fun)
  3157.     var reg5 object fun;
  3158.     { 
  3159.       var reg4 object *args_ptr = &STACK_0;
  3160.       var reg3 object *applyhook_value_ptr = &STACK_1;
  3161.       var reg2 object *fun_ptr;
  3162.       pushSTACK(fun); fun_ptr = &STACK_0;
  3163.  
  3164.       check_SP();
  3165.  
  3166.       # *EVALHOOK*, *APPLYHOOK* an NIL binden:
  3167.       bindhooks_NIL();
  3168.       #ifndef X3J13_005
  3169.       # (FUNCALL *APPLYHOOK* fun args env) ausführen:
  3170.       pushSTACK(*fun_ptr); # Funktion als 1. Argument
  3171.       pushSTACK(*args_ptr); # Argumentliste als 2. Argument
  3172.       pushSTACK(*applyhook_value_ptr); # Funktion retten
  3173.       {var reg2 environment* stack_env = nest_aktenv(); # Environments in den Stack,
  3174.        var reg1 object env = allocate_vector(5); # in neu allozierten Vektor
  3175.        *(environment*)(&TheSvector(env)->data[0]) = *stack_env; # hineinschieben
  3176.        skipSTACK(5);
  3177.       }
  3178.       { var reg3 object applyhook_value = popSTACK();
  3179.         pushSTACK(env); # gesamtes Environment als 3. Argument
  3180.         funcall(applyhook_value,3);
  3181.       }
  3182.       #else
  3183.       # (FUNCALL *APPLYHOOK* fun args) ausführen:
  3184.       pushSTACK(*fun_ptr); # Funktion als 1. Argument
  3185.       pushSTACK(*args_ptr); # Argumentliste als 2. Argument
  3186.       funcall(*applyhook_value_ptr,2);
  3187.       #endif
  3188.       # alte Werte von *EVALHOOK*, *APPLYHOOK* zurück:
  3189.       unwind();
  3190.       # EVAL-Frame auflösen:
  3191.       skipSTACK(3);
  3192.       unwind();
  3193.     }
  3194.  
  3195. # In EVAL: Fehler bei zu wenig Argumenten
  3196.   nonreturning_function(local, fehler_eval_zuwenig, (object fun));
  3197.   local void fehler_eval_zuwenig(fun)
  3198.     var reg2 object fun;
  3199.     { var reg1 object form = STACK_(frame_form); # Form
  3200.       pushSTACK(form);
  3201.       pushSTACK(fun);
  3202.       //: DEUTSCH "EVAL: Zu wenig Argumente für ~: ~"
  3203.       //: ENGLISH "EVAL: too few arguments given to ~: ~"
  3204.       //: FRANCAIS "EVAL: Trop peu d'arguments pour ~ : ~"
  3205.       fehler(program_error, GETTEXT("EVAL: too few arguments given to ~: ~"));
  3206.     }
  3207.  
  3208. # In EVAL: Fehler bei zu vielen Argumenten
  3209.   nonreturning_function(local, fehler_eval_zuviel, (object fun));
  3210.   local void fehler_eval_zuviel(fun)
  3211.     var reg2 object fun;
  3212.     { var reg1 object form = STACK_(frame_form); # Form
  3213.       pushSTACK(form);
  3214.       pushSTACK(fun);
  3215.       //: DEUTSCH "EVAL: Zu viele Argumente für ~: ~"
  3216.       //: ENGLISH "EVAL: too many arguments given to ~: ~"
  3217.       //: FRANCAIS "EVAL: Trop d'arguments pour ~ : ~"
  3218.       fehler(program_error, GETTEXT("EVAL: too many arguments given to ~: ~"));
  3219.     }
  3220.  
  3221. # In EVAL: Fehler bei punktierter Argumentliste
  3222.   nonreturning_function(local, fehler_eval_dotted, (object fun));
  3223.   local void fehler_eval_dotted(fun)
  3224.     var reg2 object fun;
  3225.     { var reg1 object form = STACK_(frame_form); # Form
  3226.       pushSTACK(form);
  3227.       pushSTACK(fun);
  3228.       //: DEUTSCH "EVAL: Argumentliste für ~ ist dotted: ~"
  3229.       //: ENGLISH "EVAL: argument list given to ~ is dotted: ~"
  3230.       //: FRANCAIS "EVAL: La liste d'arguments passée à ~ est pointée."
  3231.       fehler(program_error, GETTEXT("EVAL: argument list given to ~ is dotted: ~"));
  3232.     }
  3233.  
  3234. # In EVAL: Wendet ein SUBR auf eine Argumentliste an, räumt den STACK auf
  3235. # und liefert die Werte.
  3236. # eval_subr(fun);
  3237. # > fun: Funktion, ein SUBR
  3238. # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*, Argumentliste.
  3239. # < STACK: aufgeräumt
  3240. # < mv_count/mv_space: Werte
  3241. # verändert STACK
  3242. # kann GC auslösen
  3243.   local Values eval_subr(fun)
  3244.     var reg2 object fun;
  3245.     { var reg1 object args = popSTACK(); # Argumentliste
  3246.       skipSTACK(1); # Wert von *APPLYHOOK* vergessen
  3247.       check_SP(); check_STACK();
  3248.      {var reg1 object* args_pointer = args_end_pointer; # Pointer über die Argumente
  3249.       var reg1 object* rest_args_pointer; # Pointer über die restlichen Argumente
  3250.       var reg1 uintL argcount; # Anzahl der restlichen Argumente
  3251.       # Argumente ausgewertet in den STACK legen:
  3252.       # erst ein Dispatch für die wichtigsten Fälle:
  3253.       switch (TheSubr(fun)->argtype)
  3254.         { # Macro für ein required-Argument:
  3255.           #define REQ_ARG()  \
  3256.             { if (atomp(args)) goto fehler_zuwenig;                \
  3257.               pushSTACK(Cdr(args)); # restliche Argumente          \
  3258.               eval(Car(args)); # nächstes Argument auswerten       \
  3259.               args = STACK_0; STACK_0 = value1; # und in den STACK \
  3260.             }
  3261.           # Macro für das n-letzte optional-Argument:
  3262.           #define OPT_ARG(n)  \
  3263.             { if (atomp(args)) goto unbound_optional_##n ;         \
  3264.               pushSTACK(Cdr(args)); # restliche Argumente          \
  3265.               eval(Car(args)); # nächstes Argument auswerten       \
  3266.               args = STACK_0; STACK_0 = value1; # und in den STACK \
  3267.             }
  3268.           case (uintW)subr_argtype_6_0:
  3269.             # SUBR mit 6 required-Argumenten
  3270.             REQ_ARG();
  3271.           case (uintW)subr_argtype_5_0:
  3272.             # SUBR mit 5 required-Argumenten
  3273.             REQ_ARG();
  3274.           case (uintW)subr_argtype_4_0:
  3275.             # SUBR mit 4 required-Argumenten
  3276.             REQ_ARG();
  3277.           case (uintW)subr_argtype_3_0:
  3278.             # SUBR mit 3 required-Argumenten
  3279.             REQ_ARG();
  3280.           case (uintW)subr_argtype_2_0:
  3281.             # SUBR mit 2 required-Argumenten
  3282.             REQ_ARG();
  3283.           case (uintW)subr_argtype_1_0:
  3284.             # SUBR mit 1 required-Argument
  3285.             REQ_ARG();
  3286.           case (uintW)subr_argtype_0_0:
  3287.             # SUBR ohne Argumente
  3288.             if (!nullp(args)) goto fehler_zuviel;
  3289.             goto apply_subr_norest;
  3290.           case (uintW)subr_argtype_4_1:
  3291.             # SUBR mit 4 required-Argumenten und 1 optional-Argument
  3292.             REQ_ARG();
  3293.           case (uintW)subr_argtype_3_1:
  3294.             # SUBR mit 3 required-Argumenten und 1 optional-Argument
  3295.             REQ_ARG();
  3296.           case (uintW)subr_argtype_2_1:
  3297.             # SUBR mit 2 required-Argumenten und 1 optional-Argument
  3298.             REQ_ARG();
  3299.           case (uintW)subr_argtype_1_1:
  3300.             # SUBR mit 1 required-Argument und 1 optional-Argument
  3301.             REQ_ARG();
  3302.           case (uintW)subr_argtype_0_1:
  3303.             # SUBR mit 1 optional-Argument
  3304.             OPT_ARG(1);
  3305.             if (!nullp(args)) goto fehler_zuviel;
  3306.             goto apply_subr_norest;
  3307.           case (uintW)subr_argtype_2_2:
  3308.             # SUBR mit 2 required-Argumenten und 2 optional-Argumenten
  3309.             REQ_ARG();
  3310.           case (uintW)subr_argtype_1_2:
  3311.             # SUBR mit 1 required-Argument und 2 optional-Argumenten
  3312.             REQ_ARG();
  3313.           case (uintW)subr_argtype_0_2:
  3314.             # SUBR mit 2 optional-Argumenten
  3315.             OPT_ARG(2);
  3316.             OPT_ARG(1);
  3317.             if (!nullp(args)) goto fehler_zuviel;
  3318.             goto apply_subr_norest;
  3319.           case (uintW)subr_argtype_0_5:
  3320.             # SUBR mit 5 optional-Argumenten
  3321.             OPT_ARG(5);
  3322.           case (uintW)subr_argtype_0_4:
  3323.             # SUBR mit 4 optional-Argumenten
  3324.             OPT_ARG(4);
  3325.           case (uintW)subr_argtype_0_3:
  3326.             # SUBR mit 3 optional-Argumenten
  3327.             OPT_ARG(3);
  3328.             OPT_ARG(2);
  3329.             OPT_ARG(1);
  3330.             if (!nullp(args)) goto fehler_zuviel;
  3331.             goto apply_subr_norest;
  3332.           unbound_optional_5: # Noch 5 optionale Argumente, aber atomp(args)
  3333.             pushSTACK(unbound);
  3334.           unbound_optional_4: # Noch 4 optionale Argumente, aber atomp(args)
  3335.             pushSTACK(unbound);
  3336.           unbound_optional_3: # Noch 3 optionale Argumente, aber atomp(args)
  3337.             pushSTACK(unbound);
  3338.           unbound_optional_2: # Noch 2 optionale Argumente, aber atomp(args)
  3339.             pushSTACK(unbound);
  3340.           unbound_optional_1: # Noch 1 optionales Argument, aber atomp(args)
  3341.             pushSTACK(unbound);
  3342.             if (!nullp(args)) goto fehler_dotted;
  3343.             goto apply_subr_norest;
  3344.           case (uintW)subr_argtype_3_0_rest:
  3345.             # SUBR mit 3 required-Argumenten und weiteren Argumenten
  3346.             REQ_ARG();
  3347.           case (uintW)subr_argtype_2_0_rest:
  3348.             # SUBR mit 2 required-Argumenten und weiteren Argumenten
  3349.             REQ_ARG();
  3350.           case (uintW)subr_argtype_1_0_rest:
  3351.             # SUBR mit 1 required-Argument und weiteren Argumenten
  3352.             REQ_ARG();
  3353.           case (uintW)subr_argtype_0_0_rest:
  3354.             # SUBR mit weiteren Argumenten
  3355.             rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
  3356.             # alle weiteren Argumente auswerten und in den Stack:
  3357.             argcount = 0; # Zähler für die restlichen Argumente
  3358.             while (consp(args))
  3359.               { check_STACK();
  3360.                 pushSTACK(Cdr(args)); # restliche Argumente
  3361.                 eval(Car(args)); # nächstes Argument auswerten
  3362.                 args = STACK_0; STACK_0 = value1; # und in den STACK
  3363.                 argcount++;
  3364.               }
  3365.             goto apply_subr_rest;
  3366.           case (uintW)subr_argtype_4_0_key:
  3367.             # SUBR mit 4 required-Argumenten und Keyword-Argumenten
  3368.             REQ_ARG();
  3369.           case (uintW)subr_argtype_3_0_key:
  3370.             # SUBR mit 3 required-Argumenten und Keyword-Argumenten
  3371.             REQ_ARG();
  3372.           case (uintW)subr_argtype_2_0_key:
  3373.             # SUBR mit 2 required-Argumenten und Keyword-Argumenten
  3374.             REQ_ARG();
  3375.           case (uintW)subr_argtype_1_0_key:
  3376.             # SUBR mit 1 required-Argument und Keyword-Argumenten
  3377.             REQ_ARG();
  3378.           case (uintW)subr_argtype_0_0_key:
  3379.             # SUBR mit Keyword-Argumenten
  3380.             if (atomp(args)) goto unbound_optional_key_0;
  3381.             goto apply_subr_key;
  3382.           case (uintW)subr_argtype_1_1_key:
  3383.             # SUBR mit 1 required-Argument, 1 optional-Argument und Keyword-Argumenten
  3384.             REQ_ARG();
  3385.           case (uintW)subr_argtype_0_1_key:
  3386.             # SUBR mit 1 optional-Argument und Keyword-Argumenten
  3387.             OPT_ARG(key_1);
  3388.             if (atomp(args)) goto unbound_optional_key_0;
  3389.             goto apply_subr_key;
  3390.           case (uintW)subr_argtype_1_2_key:
  3391.             # SUBR mit 1 required-Argument, 2 optional-Argumenten und Keyword-Argumenten
  3392.             REQ_ARG();
  3393.             OPT_ARG(key_2);
  3394.             OPT_ARG(key_1);
  3395.             if (atomp(args)) goto unbound_optional_key_0;
  3396.             goto apply_subr_key;
  3397.           unbound_optional_key_2: # Noch 2 optionale Argumente, aber atomp(args)
  3398.             pushSTACK(unbound);
  3399.           unbound_optional_key_1: # Noch 1 optionales Argument, aber atomp(args)
  3400.             pushSTACK(unbound);
  3401.           unbound_optional_key_0: # Vor den Keywords ist atomp(args)
  3402.             { var reg1 uintC count;
  3403.               dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
  3404.             }
  3405.             if (!nullp(args)) goto fehler_dotted;
  3406.             goto apply_subr_norest;
  3407.           default: NOTREACHED
  3408.           #undef OPT_ARG
  3409.           #undef REQ_ARG
  3410.         }
  3411.       # Nun die allgemeine Version:
  3412.       # Platz auf dem STACK reservieren:
  3413.       get_space_on_STACK(sizeof(object) *
  3414.                          (uintL)(TheSubr(fun)->req_anz +
  3415.                                  TheSubr(fun)->opt_anz +
  3416.                                  TheSubr(fun)->key_anz));
  3417.       # required Parameter auswerten und in den Stack ablegen:
  3418.       { var reg1 uintC count;
  3419.         dotimesC(count,TheSubr(fun)->req_anz,
  3420.           { if (atomp(args)) goto fehler_zuwenig; # Argumentliste zu Ende?
  3421.             pushSTACK(Cdr(args)); # restliche Argumentliste
  3422.             eval(Car(args)); # nächstes Argument auswerten
  3423.             args = STACK_0; STACK_0 = value1; # und in den Stack
  3424.           });
  3425.       }
  3426.       # optionale Parameter auswerten und in den Stack ablegen:
  3427.       { var reg1 uintC count = TheSubr(fun)->opt_anz;
  3428.         loop
  3429.           { if (atomp(args)) break; # Argumentliste zu Ende?
  3430.             if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
  3431.             count--;
  3432.             pushSTACK(Cdr(args)); # restliche Argumentliste
  3433.             eval(Car(args)); # nächstes Argument auswerten
  3434.             args = STACK_0; STACK_0 = value1; # und in den Stack
  3435.           }
  3436.         # Argumentliste beendet.
  3437.         # Alle weiteren count optionalen Parameter bekommen den "Wert"
  3438.         # #<UNBOUND>, auch die Keyword-Parameter:
  3439.         dotimesC(count,count + TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
  3440.         if (TheSubr(fun)->rest_flag == subr_rest) # &REST-Flag?
  3441.           # ja -> 0 zusätzliche Argumente:
  3442.           { argcount = 0; rest_args_pointer = args_end_pointer; }
  3443.           # nein -> nichts zu tun
  3444.         goto los;
  3445.       }
  3446.       optionals_ok:
  3447.       # Rest- und Keyword-Parameter behandeln.
  3448.       # args = restliche Argumentliste (noch nicht zu Ende)
  3449.       if (TheSubr(fun)->key_flag == subr_nokey)
  3450.         # SUBR ohne KEY
  3451.         { if (TheSubr(fun)->rest_flag == subr_norest)
  3452.             # SUBR ohne REST oder KEY -> Argumentliste müßte zu Ende sein
  3453.             { goto fehler_zuviel; }
  3454.             else
  3455.             # SUBR mit nur REST, ohne KEY: Behandlung der restlichen Argumente
  3456.             { rest_args_pointer = args_end_pointer;
  3457.               argcount = 0; # Zähler für die restlichen Argumente
  3458.               do { check_STACK();
  3459.                    pushSTACK(Cdr(args)); # restliche Argumentliste
  3460.                    eval(Car(args)); # nächstes Argument auswerten
  3461.                    args = STACK_0; STACK_0 = value1; # und in den Stack
  3462.                    argcount++;
  3463.                  }
  3464.                  while (consp(args));
  3465.               if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
  3466.                 { goto fehler_zuviel; }
  3467.         }   }
  3468.         else
  3469.         # SUBR mit Keywords.
  3470.         apply_subr_key:
  3471.         # args = restliche Argumentliste (noch nicht zu Ende)
  3472.         # Erst die Keyword-Parameter mit #<UNBOUND> vorbesetzen, dann
  3473.         # die restlichen Argumente auswerten und im Stack ablegen, dann
  3474.         # die Keywords zuordnen:
  3475.         { var reg1 object* key_args_pointer = args_end_pointer; # Pointer über Keyword-Parameter
  3476.           # alle Keyword-Parameter mit #<UNBOUND> vorbesetzen:
  3477.           { var reg1 uintC count;
  3478.             dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
  3479.           }
  3480.           rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
  3481.           # alle weiteren Argumente auswerten und in den Stack:
  3482.           argcount = 0; # Zähler für die restlichen Argumente
  3483.           do { check_STACK();
  3484.                pushSTACK(Cdr(args)); # restliche Argumentliste
  3485.                eval(Car(args)); # nächstes Argument auswerten
  3486.                args = STACK_0; STACK_0 = value1; # und in den Stack
  3487.                argcount++;
  3488.              }
  3489.              while (consp(args));
  3490.           if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
  3491.             { goto fehler_zuviel; }
  3492.           # Keywords zuordnen und evtl. restliche Argumente wegwerfen:
  3493.           match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
  3494.         }
  3495.       los: # Funktion anspringen
  3496.       # restliche Argumentliste muß =NIL sein:
  3497.       if (!nullp(args)) goto fehler_dotted;
  3498.       if (TheSubr(fun)->rest_flag == subr_norest)
  3499.         # SUBR ohne &REST-Flag:
  3500.         apply_subr_norest:
  3501.         { subr_self = fun;
  3502.           (*(subr_norest_function*)(TheSubr(fun)->function))();
  3503.         }
  3504.         else
  3505.         # SUBR mit &REST-Flag:
  3506.         apply_subr_rest:
  3507.         { subr_self = fun;
  3508.           (*(subr_rest_function*)(TheSubr(fun)->function))
  3509.            (argcount,rest_args_pointer);
  3510.         }
  3511.       #if STACKCHECKS
  3512.       if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
  3513.         { abort(); } # nein -> ab in den Debugger
  3514.       #endif
  3515.       unwind(); # EVAL-Frame auflösen
  3516.       return; # fertig
  3517.       # Gesammelte Fehlermeldungen:
  3518.       fehler_zuwenig: # Argumentliste args ist vorzeitig ein Atom
  3519.         if (!nullp(args)) goto fehler_dotted;
  3520.         set_args_end_pointer(args_pointer); # STACK aufräumen
  3521.         fehler_eval_zuwenig(TheSubr(fun)->name);
  3522.       fehler_zuviel: # Argumentliste args ist am Schluß nicht NIL
  3523.         if (atomp(args)) goto fehler_dotted;
  3524.         set_args_end_pointer(args_pointer); # STACK aufräumen
  3525.         fehler_eval_zuviel(TheSubr(fun)->name);
  3526.       fehler_dotted: # Argumentliste args endet mit Atom /= NIL
  3527.         set_args_end_pointer(args_pointer); # STACK aufräumen
  3528.         fehler_eval_dotted(TheSubr(fun)->name);
  3529.     }}
  3530.  
  3531. # In EVAL: Wendet eine Closure auf eine Argumentliste an, räumt den STACK auf
  3532. # und liefert die Werte.
  3533. # eval_closure(fun);
  3534. # > fun: Funktion, eine Closure
  3535. # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*, Argumentliste.
  3536. # < STACK: aufgeräumt
  3537. # < mv_count/mv_space: Werte
  3538. # verändert STACK
  3539. # kann GC auslösen
  3540.   local Values eval_closure(closure)
  3541.     var reg2 object closure;
  3542.     { var reg1 object args = popSTACK(); # Argumentliste
  3543.       skipSTACK(1); # Wert von *APPLYHOOK* vergessen
  3544.       # STACK-Aufbau: EVAL-Frame.
  3545.       check_SP(); check_STACK();
  3546.       pushSTACK(closure); # Closure retten
  3547.      {var reg1 object* closure_ = &STACK_0; # und merken, wo sie sitzt
  3548.       if (m_simple_bit_vector_p(TheClosure(closure)->clos_codevec))
  3549.         # closure ist eine compilierte Closure
  3550.         { var reg10 object* STACKbefore = STACK;
  3551.           var reg1 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
  3552.           # Argumente ausgewertet in den STACK legen:
  3553.           # erst ein Dispatch für die wichtigsten Fälle:
  3554.           switch (TheSbvector(codevec)->data[CCHD+5])
  3555.             { # Macro für ein required-Argument:
  3556.               #define REQ_ARG()  \
  3557.                 { if (atomp(args)) goto fehler_zuwenig;                \
  3558.                   pushSTACK(Cdr(args)); # restliche Argumente          \
  3559.                   eval(Car(args)); # nächstes Argument auswerten       \
  3560.                   args = STACK_0; STACK_0 = value1; # und in den STACK \
  3561.                 }
  3562.               # Macro für das n-letzte optional-Argument:
  3563.               #define OPT_ARG(n)  \
  3564.                 { if (atomp(args)) goto unbound_optional_##n ;         \
  3565.                   pushSTACK(Cdr(args)); # restliche Argumente          \
  3566.                   eval(Car(args)); # nächstes Argument auswerten       \
  3567.                   args = STACK_0; STACK_0 = value1; # und in den STACK \
  3568.                 }
  3569.               case (uintB)cclos_argtype_5_0:
  3570.                 # 5 required-Argumente
  3571.                 REQ_ARG();
  3572.               case (uintB)cclos_argtype_4_0:
  3573.                 # 4 required-Argumente
  3574.                 REQ_ARG();
  3575.               case (uintB)cclos_argtype_3_0:
  3576.                 # 3 required-Argumente
  3577.                 REQ_ARG();
  3578.               case (uintB)cclos_argtype_2_0:
  3579.                 # 2 required-Argumente
  3580.                 REQ_ARG();
  3581.               case (uintB)cclos_argtype_1_0:
  3582.                 # 1 required-Argument
  3583.                 REQ_ARG();
  3584.               case (uintB)cclos_argtype_0_0:
  3585.                 # keine Argumente
  3586.                 noch_0_opt_args:
  3587.                 if (!nullp(args)) goto fehler_zuviel;
  3588.                 goto apply_cclosure_nokey;
  3589.               case (uintB)cclos_argtype_4_1:
  3590.                 # 4 required-Argumente und 1 optional-Argument
  3591.                 REQ_ARG();
  3592.               case (uintB)cclos_argtype_3_1:
  3593.                 # 3 required-Argumente und 1 optional-Argument
  3594.                 REQ_ARG();
  3595.               case (uintB)cclos_argtype_2_1:
  3596.                 # 2 required-Argumente und 1 optional-Argument
  3597.                 REQ_ARG();
  3598.               case (uintB)cclos_argtype_1_1:
  3599.                 # 1 required-Argument und 1 optional-Argument
  3600.                 REQ_ARG();
  3601.               case (uintB)cclos_argtype_0_1:
  3602.                 # 1 optional-Argument
  3603.                 noch_1_opt_args:
  3604.                 OPT_ARG(1);
  3605.                 goto noch_0_opt_args;
  3606.               case (uintB)cclos_argtype_3_2:
  3607.                 # 3 required-Argumente und 2 optional-Argumente
  3608.                 REQ_ARG();
  3609.               case (uintB)cclos_argtype_2_2:
  3610.                 # 2 required-Argumente und 2 optional-Argumente
  3611.                 REQ_ARG();
  3612.               case (uintB)cclos_argtype_1_2:
  3613.                 # 1 required-Argument und 2 optional-Argumente
  3614.                 REQ_ARG();
  3615.               case (uintB)cclos_argtype_0_2:
  3616.                 # 2 optional-Argumente
  3617.                 noch_2_opt_args:
  3618.                 OPT_ARG(2);
  3619.                 goto noch_1_opt_args;
  3620.               case (uintB)cclos_argtype_2_3:
  3621.                 # 2 required-Argumente und 3 optional-Argumente
  3622.                 REQ_ARG();
  3623.               case (uintB)cclos_argtype_1_3:
  3624.                 # 1 required-Argument und 3 optional-Argumente
  3625.                 REQ_ARG();
  3626.               case (uintB)cclos_argtype_0_3:
  3627.                 # 3 optional-Argumente
  3628.                 noch_3_opt_args:
  3629.                 OPT_ARG(3);
  3630.                 goto noch_2_opt_args;
  3631.               case (uintB)cclos_argtype_1_4:
  3632.                 # 1 required-Argument und 4 optional-Argumente
  3633.                 REQ_ARG();
  3634.               case (uintB)cclos_argtype_0_4:
  3635.                 # 4 optional-Argumente
  3636.                 noch_4_opt_args:
  3637.                 OPT_ARG(4);
  3638.                 goto noch_3_opt_args;
  3639.               case (uintB)cclos_argtype_0_5:
  3640.                 # 5 optional-Argumente
  3641.                 OPT_ARG(5);
  3642.                 goto noch_4_opt_args;
  3643.               unbound_optional_5: # Noch 5 optionale Argumente, aber atomp(args)
  3644.                 pushSTACK(unbound);
  3645.               unbound_optional_4: # Noch 4 optionale Argumente, aber atomp(args)
  3646.                 pushSTACK(unbound);
  3647.               unbound_optional_3: # Noch 3 optionale Argumente, aber atomp(args)
  3648.                 pushSTACK(unbound);
  3649.               unbound_optional_2: # Noch 2 optionale Argumente, aber atomp(args)
  3650.                 pushSTACK(unbound);
  3651.               unbound_optional_1: # Noch 1 optionales Argument, aber atomp(args)
  3652.                 pushSTACK(unbound);
  3653.                 if (!nullp(args)) goto fehler_dotted;
  3654.                 goto apply_cclosure_nokey;
  3655.               case (uintB)cclos_argtype_4_0_rest:
  3656.                 # 4 required-Argumente, Rest-Parameter
  3657.                 REQ_ARG();
  3658.               case (uintB)cclos_argtype_3_0_rest:
  3659.                 # 3 required-Argumente, Rest-Parameter
  3660.                 REQ_ARG();
  3661.               case (uintB)cclos_argtype_2_0_rest:
  3662.                 # 2 required-Argumente, Rest-Parameter
  3663.                 REQ_ARG();
  3664.               case (uintB)cclos_argtype_1_0_rest:
  3665.                 # 1 required-Argument, Rest-Parameter
  3666.                 REQ_ARG();
  3667.               case (uintB)cclos_argtype_0_0_rest:
  3668.                 # keine Argumente, Rest-Parameter
  3669.                 if (consp(args)) goto apply_cclosure_rest_nokey;
  3670.                 if (!nullp(args)) goto fehler_dotted;
  3671.                 pushSTACK(NIL); # Rest-Parameter := NIL
  3672.                 goto apply_cclosure_nokey;
  3673.               case (uintB)cclos_argtype_4_0_key:
  3674.                 # 4 required-Argumente, Keyword-Argumente
  3675.                 REQ_ARG();
  3676.               case (uintB)cclos_argtype_3_0_key:
  3677.                 # 3 required-Argumente, Keyword-Argumente
  3678.                 REQ_ARG();
  3679.               case (uintB)cclos_argtype_2_0_key:
  3680.                 # 2 required-Argumente, Keyword-Argumente
  3681.                 REQ_ARG();
  3682.               case (uintB)cclos_argtype_1_0_key:
  3683.                 # 1 required-Argument, Keyword-Argumente
  3684.                 REQ_ARG();
  3685.                 noch_0_opt_args_key:
  3686.                 closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
  3687.               case (uintB)cclos_argtype_0_0_key:
  3688.                 # nur Keyword-Argumente
  3689.                 if (atomp(args)) goto unbound_optional_key_0;
  3690.                 goto apply_cclosure_key;
  3691.               case (uintB)cclos_argtype_3_1_key:
  3692.                 # 3 required-Argumente und 1 optional-Argument, Keyword-Argumente
  3693.                 REQ_ARG();
  3694.               case (uintB)cclos_argtype_2_1_key:
  3695.                 # 2 required-Argumente und 1 optional-Argument, Keyword-Argumente
  3696.                 REQ_ARG();
  3697.               case (uintB)cclos_argtype_1_1_key:
  3698.                 # 1 required-Argument und 1 optional-Argument, Keyword-Argumente
  3699.                 REQ_ARG();
  3700.               case (uintB)cclos_argtype_0_1_key:
  3701.                 # 1 optional-Argument, Keyword-Argumente
  3702.                 noch_1_opt_args_key:
  3703.                 OPT_ARG(key_1);
  3704.                 goto noch_0_opt_args_key;
  3705.               case (uintB)cclos_argtype_2_2_key:
  3706.                 # 2 required-Argumente und 2 optional-Argumente, Keyword-Argumente
  3707.                 REQ_ARG();
  3708.               case (uintB)cclos_argtype_1_2_key:
  3709.                 # 1 required-Argument und 2 optional-Argumente, Keyword-Argumente
  3710.                 REQ_ARG();
  3711.               case (uintB)cclos_argtype_0_2_key:
  3712.                 # 2 optional-Argumente, Keyword-Argumente
  3713.                 noch_2_opt_args_key:
  3714.                 OPT_ARG(key_2);
  3715.                 goto noch_1_opt_args_key;
  3716.               case (uintB)cclos_argtype_1_3_key:
  3717.                 # 1 required-Argument und 3 optional-Argumente, Keyword-Argumente
  3718.                 REQ_ARG();
  3719.               case (uintB)cclos_argtype_0_3_key:
  3720.                 # 3 optional-Argumente, Keyword-Argumente
  3721.                 noch_3_opt_args_key:
  3722.                 OPT_ARG(key_3);
  3723.                 goto noch_2_opt_args_key;
  3724.               case (uintB)cclos_argtype_0_4_key:
  3725.                 # 4 optional-Argumente, Keyword-Argumente
  3726.                 OPT_ARG(key_4);
  3727.                 goto noch_3_opt_args_key;
  3728.               unbound_optional_key_4: # Noch 4 optionale Argumente, aber atomp(args)
  3729.                 pushSTACK(unbound);
  3730.               unbound_optional_key_3: # Noch 3 optionale Argumente, aber atomp(args)
  3731.                 pushSTACK(unbound);
  3732.               unbound_optional_key_2: # Noch 2 optionale Argumente, aber atomp(args)
  3733.                 pushSTACK(unbound);
  3734.               unbound_optional_key_1: # Noch 1 optionales Argument, aber atomp(args)
  3735.                 pushSTACK(unbound);
  3736.               unbound_optional_key_0: # Vor den Keywords ist atomp(args)
  3737.                 if (!nullp(args)) goto fehler_dotted;
  3738.                 goto apply_cclosure_key_noargs;
  3739.               case (uintB)cclos_argtype_default:
  3740.                 # Allgemeine Version
  3741.                 break;
  3742.               default: NOTREACHED
  3743.               #undef OPT_ARG
  3744.               #undef REQ_ARG
  3745.             }
  3746.           # Nun die allgemeine Version:
  3747.           { var reg1 uintL req_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]); # Anzahl required Parameter
  3748.             var reg1 uintL opt_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+2]); # Anzahl optionale Parameter
  3749.             var reg1 uintB flags = TheSbvector(codevec)->data[CCHD+4]; # Flags
  3750.             # Platz auf dem STACK reservieren:
  3751.             get_space_on_STACK(sizeof(object) * (req_anz+opt_anz));
  3752.             # required Parameter auswerten und in den Stack ablegen:
  3753.             { var reg1 uintC count;
  3754.               dotimesC(count,req_anz,
  3755.                 { if (atomp(args)) goto fehler_zuwenig; # Argumentliste zu Ende?
  3756.                   pushSTACK(Cdr(args)); # restliche Argumentliste
  3757.                   eval(Car(args)); # nächstes Argument auswerten
  3758.                   args = STACK_0; STACK_0 = value1; # und in den Stack
  3759.                 });
  3760.             }
  3761.             # optionale Parameter auswerten und in den Stack ablegen:
  3762.             { var reg1 uintC count = opt_anz;
  3763.               loop
  3764.                 { if (atomp(args)) break; # Argumentliste zu Ende?
  3765.                   if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
  3766.                   count--;
  3767.                   pushSTACK(Cdr(args)); # restliche Argumentliste
  3768.                   eval(Car(args)); # nächstes Argument auswerten
  3769.                   args = STACK_0; STACK_0 = value1; # und in den Stack
  3770.                 }
  3771.               # Argumentliste beendet.
  3772.               if (!nullp(args)) goto fehler_dotted;
  3773.               # Alle weiteren count optionalen Parameter bekommen den "Wert"
  3774.               # #<UNBOUND>, der &REST-Parameter den Wert NIL,
  3775.               # die Keyword-Parameter den Wert #<UNBOUND> :
  3776.               dotimesC(count,count, { pushSTACK(unbound); } );
  3777.               closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
  3778.               if (flags & bit(0)) # &REST-Flag?
  3779.                 { pushSTACK(NIL); } # ja -> mit NIL initialisieren
  3780.               if (flags & bit(7)) # &KEY-Flag?
  3781.                 apply_cclosure_key_noargs:
  3782.                 { var reg1 uintC count = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
  3783.                   dotimesC(count,count, { pushSTACK(unbound); } ); # mit #<UNBOUND> initialisieren
  3784.                   interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
  3785.                 }
  3786.                 else
  3787.                 { interpret_bytecode(closure,codevec,CCHD+6); } # Bytecode ab Byte 6 abinterpretieren
  3788.               goto fertig;
  3789.             }
  3790.             optionals_ok:
  3791.             # Rest- und Keyword-Parameter behandeln.
  3792.             # args = restliche Argumentliste (noch nicht zu Ende)
  3793.             closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
  3794.             if (flags == 0)
  3795.               # Closure ohne REST oder KEY -> Argumentliste müßte zu Ende sein
  3796.               { goto fehler_zuviel; }
  3797.             elif (flags & bit(7)) # Key-Flag?
  3798.               # Closure mit Keywords.
  3799.               # args = restliche Argumentliste (noch nicht zu Ende)
  3800.               # Erst die Keyword-Parameter mit #<UNBOUND> vorbesetzen, dann
  3801.               # die restlichen Argumente auswerten und im Stack ablegen, dann
  3802.               # die Keywords zuordnen:
  3803.               { # evtl. den Rest-Parameter vorbesetzen:
  3804.                 if (flags & bit(0)) { pushSTACK(unbound); }
  3805.                 apply_cclosure_key: # Closure mit nur &KEY anspringen:
  3806.                {var reg1 object* key_args_pointer = args_end_pointer; # Pointer über Keyword-Parameter
  3807.                 # alle Keyword-Parameter mit #<UNBOUND> vorbesetzen:
  3808.                 { var reg1 uintC count = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]);
  3809.                   dotimesC(count,count, { pushSTACK(unbound); } );
  3810.                 }
  3811.                 {var reg1 object* rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
  3812.                  # alle weiteren Argumente auswerten und in den Stack:
  3813.                  var reg1 uintL argcount = 0; # Zähler für die restlichen Argumente
  3814.                  do { check_STACK();
  3815.                       pushSTACK(Cdr(args)); # restliche Argumentliste
  3816.                       eval(Car(args)); # nächstes Argument auswerten
  3817.                       args = STACK_0; STACK_0 = value1; # und in den Stack
  3818.                       argcount++;
  3819.                     }
  3820.                     while (consp(args));
  3821.                  # Argumentliste beendet.
  3822.                  if (!nullp(args)) goto fehler_dotted;
  3823.                  # Keywords zuordnen, Rest-Parameter bauen
  3824.                  # und evtl. restliche Argumente wegwerfen:
  3825.                  closure = match_cclosure_key(*closure_,argcount,key_args_pointer,rest_args_pointer);
  3826.                  codevec = TheCclosure(closure)->clos_codevec;
  3827.                  interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
  3828.               }}}
  3829.             else
  3830.               apply_cclosure_rest_nokey:
  3831.               # Closure mit nur REST, ohne KEY:
  3832.               # restlichen Argumente einzeln auswerten, zu einer Liste machen
  3833.               # args = restliche Argumentliste (noch nicht zu Ende)
  3834.               { pushSTACK(NIL); # bisher ausgewertete restliche Argumente
  3835.                 pushSTACK(args); # restliche Argumente, unausgewertet
  3836.                 do { args = STACK_0; STACK_0 = Cdr(args);
  3837.                      eval(Car(args)); # nächstes Argument auswerten
  3838.                      pushSTACK(value1);
  3839.                      # und auf die Liste consen:
  3840.                     {var reg1 object new_cons = allocate_cons();
  3841.                      Car(new_cons) = popSTACK();
  3842.                      Cdr(new_cons) = STACK_1;
  3843.                      STACK_1 = new_cons;
  3844.                    }}
  3845.                    while (mconsp(STACK_0));
  3846.                 args = popSTACK();
  3847.                 # Liste STACK_0 umdrehen und als REST-Parameter verwenden:
  3848.                 nreverse(STACK_0);
  3849.                 # Argumentliste beendet.
  3850.                 if (!nullp(args)) goto fehler_dotted;
  3851.                 apply_cclosure_nokey: # Closure ohne &KEY anspringen:
  3852.                 closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
  3853.                 interpret_bytecode(closure,codevec,CCHD+6); # Bytecode ab Byte 6 abinterpretieren
  3854.               }
  3855.             fertig: ;
  3856.           }
  3857.           #if STACKCHECKC
  3858.           if (!(STACK == STACKbefore)) # STACK so wie vorher?
  3859.             { abort(); } # nein -> ab in den Debugger
  3860.           #endif
  3861.           skipSTACK(1); # Closure wegwerfen
  3862.           unwind(); # EVAL-Frame auflösen
  3863.           return; # fertig
  3864.           # Gesammelte Fehlermeldungen:
  3865.           fehler_zuwenig: # Argumentliste args ist vorzeitig ein Atom
  3866.             if (!nullp(args)) goto fehler_dotted;
  3867.             setSTACK(STACK = STACKbefore); # STACK aufräumen
  3868.             closure = popSTACK();
  3869.             fehler_eval_zuwenig(TheCclosure(closure)->clos_name);
  3870.           fehler_zuviel: # Argumentliste args ist am Schluß nicht NIL
  3871.             if (atomp(args)) goto fehler_dotted;
  3872.             setSTACK(STACK = STACKbefore); # STACK aufräumen
  3873.             closure = popSTACK();
  3874.             fehler_eval_zuviel(TheCclosure(closure)->clos_name);
  3875.           fehler_dotted: # Argumentliste args endet mit Atom /= NIL
  3876.             setSTACK(STACK = STACKbefore); # STACK aufräumen
  3877.             closure = popSTACK();
  3878.             fehler_eval_dotted(TheCclosure(closure)->clos_name);
  3879.         }
  3880.         else
  3881.         # closure ist eine interpretierte Closure
  3882.         { var reg7 object* args_pointer = args_end_pointer; # Pointer über die Argumente
  3883.           var reg6 uintC args_on_stack = 0; # Anzahl der Argumente
  3884.           while (consp(args))
  3885.             { pushSTACK(Cdr(args)); # Listenrest retten
  3886.               eval(Car(args)); # nächstes Element auswerten
  3887.               args = STACK_0; STACK_0 = value1; # Auswertungsergebnis in den STACK
  3888.               args_on_stack += 1;
  3889.               if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
  3890.                 goto fehler_zuviel;
  3891.             }
  3892.           funcall_iclosure(*closure_,args_pointer,args_on_stack);
  3893.           skipSTACK(1); # Closure wegwerfen
  3894.           unwind(); # EVAL-Frame auflösen
  3895.           return; # fertig
  3896.         }
  3897.     }}
  3898.  
  3899. #ifdef DYNAMIC_FFI
  3900. # In EVAL: Wendet eine Foreign-Function auf eine Argumentliste an,
  3901. # räumt den STACK auf und liefert die Werte.
  3902. # eval_ffunction(fun);
  3903. # > fun: Funktion, eine Foreign-Function
  3904. # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*, Argumentliste.
  3905. # < STACK: aufgeräumt
  3906. # < mv_count/mv_space: Werte
  3907. # verändert STACK
  3908. # kann GC auslösen
  3909.   local Values eval_ffunction(ffun)
  3910.     var reg3 object ffun;
  3911.     { var reg1 object args = popSTACK(); # Argumentliste
  3912.       skipSTACK(1); # Wert von *APPLYHOOK* vergessen
  3913.       # STACK-Aufbau: EVAL-Frame.
  3914.       # (ffun arg ...) --> (FFI::FOREIGN-CALL-OUT ffun arg ...)
  3915.       check_SP(); check_STACK();
  3916.       pushSTACK(ffun); # Foreign-Funktion als 1. Argument
  3917.       { var reg4 object* args_pointer = args_end_pointer; # Pointer über die Argumente
  3918.         var reg2 uintC args_on_stack = 1; # Anzahl der Argumente
  3919.         while (consp(args))
  3920.           { pushSTACK(Cdr(args)); # Listenrest retten
  3921.             eval(Car(args)); # nächstes Element auswerten
  3922.             args = STACK_0; STACK_0 = value1; # Auswertungsergebnis in den STACK
  3923.             args_on_stack += 1;
  3924.             if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
  3925.               { set_args_end_pointer(args_pointer);
  3926.                 fehler_eval_zuviel(popSTACK());
  3927.               }
  3928.           }
  3929.         funcall(L(foreign_call_out),args_on_stack);
  3930.       }
  3931.       unwind(); # EVAL-Frame auflösen
  3932.       return; # fertig
  3933.     }
  3934. #endif
  3935.  
  3936.  
  3937. #          ----------------------- A P P L Y -----------------------
  3938.  
  3939. # später:
  3940.   local Values apply_subr (object fun, uintC args_on_stack, object other_args);
  3941.   local Values apply_closure (object fun, uintC args_on_stack, object other_args);
  3942.  
  3943. # UP: Wendet eine Funktion auf ihre Argumente an.
  3944. # apply(function,args_on_stack,other_args);
  3945. # > function: Funktion
  3946. # > Argumente: args_on_stack Argumente auf dem STACK,
  3947. #              restliche Argumentliste in other_args
  3948. # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
  3949. # < mv_count/mv_space: Werte
  3950. # verändert STACK, kann GC auslösen
  3951.   global Values apply (object fun, uintC args_on_stack, object other_args);
  3952.   global Values apply(fun,args_on_stack,other_args)
  3953.     var reg2 object fun;
  3954.     var reg4 uintC args_on_stack;
  3955.     var reg3 object other_args;
  3956.     { # fun muß ein SUBR oder eine Closure oder ein Cons (LAMBDA ...) sein:
  3957.       var reg1 tint type = typecode(fun); # Typinfo
  3958.       if (type == subr_type) # SUBR ?
  3959.         { return_Values apply_subr(fun,args_on_stack,other_args); }
  3960.       elif (type == closure_type) # Closure ?
  3961.         { return_Values apply_closure(fun,args_on_stack,other_args); }
  3962.       elif (symbolp(fun)) # Symbol ?
  3963.         # Symbol anwenden: globale Definition Symbol_function(fun) gilt.
  3964.         { type = mtypecode(Symbol_function(fun)); # Typinfo davon
  3965.           if (type == subr_type) # SUBR -> anwenden
  3966.             { return_Values apply_subr(Symbol_function(fun),args_on_stack,other_args); }
  3967.           elif (type == closure_type) # Closure -> anwenden
  3968.             { return_Values apply_closure(Symbol_function(fun),args_on_stack,other_args); }
  3969.           elif (type == orecord_type)
  3970.             {
  3971.               #ifdef DYNAMIC_FFI
  3972.               if (ffunctionp(Symbol_function(fun))) # Foreign-Function ?
  3973.                 { fun = Symbol_function(fun); goto call_ffunction; }
  3974.               #endif
  3975.               # FSUBR -> Fehler
  3976.               pushSTACK(fun);
  3977.               //: DEUTSCH "APPLY: ~ ist eine Spezialform, keine Funktion."
  3978.               //: ENGLISH "APPLY: ~ is a special form, not a function"
  3979.               //: FRANCAIS "APPLY: ~ est une forme spéciale et non une fonction."
  3980.               fehler(error, GETTEXT("APPLY: ~ is a special form, not a function"));
  3981.             }
  3982.           elif (mconsp(Symbol_function(fun))) # Macro-Cons -> Fehler
  3983.             { pushSTACK(fun);
  3984.               //: DEUTSCH "APPLY: ~ ist ein Macro, keine Funktion."
  3985.               //: ENGLISH "APPLY: ~ is a macro, not a function"
  3986.               //: FRANCAIS "APPLY: ~ est un macro et non une fonction."
  3987.               fehler(error, GETTEXT("APPLY: ~ is a macro, not a function"));
  3988.             }
  3989.           else
  3990.             # wenn kein SUBR, keine Closure, kein FSUBR, kein Cons:
  3991.             # Symbol_function(fun) muß #<UNBOUND> sein.
  3992.             undef:
  3993.             { pushSTACK(fun); # Wert für Slot NAME von CELL-ERROR
  3994.               pushSTACK(fun);
  3995.               //: DEUTSCH "APPLY: Die Funktion ~ ist undefiniert."
  3996.               //: ENGLISH "APPLY: the function ~ is undefined"
  3997.               //: FRANCAIS "APPLY: La fonction ~ n'est pas définie."
  3998.               fehler(undefined_function, GETTEXT("APPLY: the function ~ is undefined"));
  3999.             }
  4000.         }
  4001.       elif (funnamep(fun)) # Liste (SETF symbol) ?
  4002.         # globale Definition (symbol-function (get-setf-symbol symbol)) gilt.
  4003.         { var reg5 object symbol = get(Car(Cdr(fun)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
  4004.           if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
  4005.             goto undef; # sonst undefiniert
  4006.           type = mtypecode(Symbol_function(symbol)); # Typinfo davon
  4007.           if (type == closure_type) # Closure -> anwenden
  4008.             { return_Values apply_closure(Symbol_function(symbol),args_on_stack,other_args); }
  4009.           elif (type == subr_type) # SUBR -> anwenden
  4010.             { return_Values apply_subr(Symbol_function(symbol),args_on_stack,other_args); }
  4011.           else
  4012.             # Solche Funktionsnamen können keine FSUBRs oder Macros bezeichnen.
  4013.             # Symbol_function(symbol) wird vermutlich #<UNBOUND> sein.
  4014.             goto undef;
  4015.         }
  4016.       elif (consp(fun) && eq(Car(fun),S(lambda))) # Cons (LAMBDA ...) ?
  4017.         # Lambda-Ausdruck: zu einer Funktion mit leerem Environment machen
  4018.         { pushSTACK(other_args); # Argumentliste retten
  4019.           # leeres Environment bauen:
  4020.          {var reg5 environment* env5;
  4021.           make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env5 = );
  4022.           fun = get_closure(Cdr(fun), # Lambdabody (lambda-list {decl|doc} . body)
  4023.                             S(Klambda), # :LAMBDA als Name
  4024.                             env5); # im leeren Environment
  4025.           skipSTACK(5); # Environment wieder vergessen
  4026.           other_args = popSTACK();
  4027.           # und neu erzeugte Closure anwenden:
  4028.           return_Values apply_closure(fun,args_on_stack,other_args);
  4029.         }}
  4030.       #ifdef DYNAMIC_FFI
  4031.       elif (ffunctionp(fun)) # Foreign-Function ?
  4032.         # (SYS::FOREIGN-CALL-OUT foreign-function . args) aufrufen
  4033.         call_ffunction:
  4034.         { # Dazu erst die Argumente im Stack um 1 nach unten verschieben.
  4035.           var reg6 uintC count;
  4036.           var reg5 object* ptr = &STACK_0;
  4037.           dotimesC(count,args_on_stack,
  4038.             { *(ptr STACKop -1) = *ptr; ptr skipSTACKop 1; }
  4039.             );
  4040.           *(ptr STACKop -1) = fun;
  4041.           skipSTACK(-1);
  4042.           return_Values apply_subr(L(foreign_call_out),args_on_stack+1,other_args);
  4043.         }
  4044.       #endif
  4045.       else
  4046.         { pushSTACK(fun);
  4047.           //: DEUTSCH "APPLY: ~ ist keine Funktionsbezeichnung."
  4048.           //: ENGLISH "APPLY: ~ is not a function name"
  4049.           //: FRANCAIS "APPLY: ~ n'est pas un nom de fonction."
  4050.           fehler(error, GETTEXT("APPLY: ~ is not a function name"));
  4051.         }
  4052.     }
  4053.  
  4054. # Fehler wegen punktierter Argumentliste
  4055. # > name: Name der Funktion
  4056.   nonreturning_function(local, fehler_apply_dotted, (object name));
  4057.   local void fehler_apply_dotted(name)
  4058.     var reg1 object name;
  4059.     { pushSTACK(name);
  4060.       //: DEUTSCH "APPLY: Argumentliste für ~ ist dotted."
  4061.       //: ENGLISH "APPLY: argument list given to ~ is dotted"
  4062.       //: FRANCAIS "APPLY: La liste d'arguments pour ~ est pointée."
  4063.       fehler(error, GETTEXT("APPLY: argument list given to ~ is dotted"));
  4064.     }
  4065.  
  4066. # Fehler wegen zu vielen Argumenten
  4067. # > name: Name der Funktion
  4068.   nonreturning_function(local, fehler_apply_zuviel, (object name));
  4069.   local void fehler_apply_zuviel(name)
  4070.     var reg1 object name;
  4071.     { pushSTACK(name);
  4072.       //: DEUTSCH "APPLY: Zu viele Argumente für ~"
  4073.       //: ENGLISH "APPLY: too many arguments given to ~"
  4074.       //: FRANCAIS "APPLY: Trop d'arguments pour ~"
  4075.       fehler(error, GETTEXT("APPLY: too many arguments given to ~"));
  4076.     }
  4077.  
  4078. # Fehler wegen zu wenig Argumenten
  4079. # > name: Name der Funktion
  4080.   nonreturning_function(local, fehler_apply_zuwenig, (object name));
  4081.   local void fehler_apply_zuwenig(name)
  4082.     var reg1 object name;
  4083.     { pushSTACK(name);
  4084.       //: DEUTSCH "APPLY: Zu wenig Argumente für ~"
  4085.       //: ENGLISH "APPLY: too few arguments given to ~"
  4086.       //: FRANCAIS "APPLY: Trop peu d'arguments pour ~"
  4087.       fehler(error, GETTEXT("APPLY: too few arguments given to ~"));
  4088.     }
  4089.  
  4090. # Fehler wegen zu vielen Argumenten für ein SUBR
  4091. # > fun: Funktion, ein SUBR
  4092.   nonreturning_function(local, fehler_subr_zuviel, (object fun));
  4093.   #define fehler_subr_zuviel(fun)  fehler_apply_zuviel(TheSubr(fun)->name)
  4094.  
  4095. # Fehler wegen zu wenig Argumenten für ein SUBR
  4096. # > fun: Funktion, ein SUBR
  4097.   nonreturning_function(local, fehler_subr_zuwenig, (object fun));
  4098.   #define fehler_subr_zuwenig(fun)  fehler_apply_zuwenig(TheSubr(fun)->name)
  4099.  
  4100. # In APPLY: Wendet ein SUBR auf eine Argumentliste an, räumt den STACK auf
  4101. # und liefert die Werte.
  4102. # apply_subr(fun,args_on_stack,other_args);
  4103. # > fun: Funktion, ein SUBR
  4104. # > Argumente: args_on_stack Argumente auf dem STACK,
  4105. #              restliche Argumentliste in other_args
  4106. # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
  4107. # < mv_count/mv_space: Werte
  4108. # verändert STACK, kann GC auslösen
  4109.   local Values apply_subr(fun,args_on_stack,args)
  4110.     var reg4 object fun;
  4111.     var reg3 uintC args_on_stack;
  4112.     var reg2 object args;
  4113.     {
  4114.       #if STACKCHECKS
  4115.       var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
  4116.       #endif
  4117.       var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
  4118.       var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
  4119.       var reg8 uintL argcount; # Anzahl der restlichen Argumente
  4120.       #ifdef DEBUG_EVAL
  4121.       if (sym_streamp(S(funcall_trace_output)))
  4122.         { pushSTACK(fun); trace_call(fun,'A','S'); fun = popSTACK(); }
  4123.       #endif
  4124.       # Argumente in den STACK legen:
  4125.       # erst ein Dispatch für die wichtigsten Fälle:
  4126.       switch (TheSubr(fun)->argtype)
  4127.         { # Macro für ein required-Argument:
  4128.           #define REQ_ARG()  \
  4129.             { if (args_on_stack>0) { args_on_stack--; }                      \
  4130.               elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
  4131.               else goto fehler_zuwenig;                                      \
  4132.             }
  4133.           # Macro für das n-letzte optional-Argument:
  4134.           #define OPT_ARG(n)  \
  4135.             { if (args_on_stack>0) { args_on_stack--; }                      \
  4136.               elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
  4137.               else goto unbound_optional_##n;                                \
  4138.             }
  4139.           case (uintW)subr_argtype_6_0:
  4140.             # SUBR mit 6 required-Argumenten
  4141.             REQ_ARG();
  4142.           case (uintW)subr_argtype_5_0:
  4143.             # SUBR mit 5 required-Argumenten
  4144.             REQ_ARG();
  4145.           case (uintW)subr_argtype_4_0:
  4146.             # SUBR mit 4 required-Argumenten
  4147.             REQ_ARG();
  4148.           case (uintW)subr_argtype_3_0:
  4149.             # SUBR mit 3 required-Argumenten
  4150.             REQ_ARG();
  4151.           case (uintW)subr_argtype_2_0:
  4152.             # SUBR mit 2 required-Argumenten
  4153.             REQ_ARG();
  4154.           case (uintW)subr_argtype_1_0:
  4155.             # SUBR mit 1 required-Argument
  4156.             REQ_ARG();
  4157.           case (uintW)subr_argtype_0_0:
  4158.             # SUBR ohne Argumente
  4159.             if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
  4160.             goto apply_subr_norest;
  4161.           case (uintW)subr_argtype_4_1:
  4162.             # SUBR mit 4 required-Argumenten und 1 optional-Argument
  4163.             REQ_ARG();
  4164.           case (uintW)subr_argtype_3_1:
  4165.             # SUBR mit 3 required-Argumenten und 1 optional-Argument
  4166.             REQ_ARG();
  4167.           case (uintW)subr_argtype_2_1:
  4168.             # SUBR mit 2 required-Argumenten und 1 optional-Argument
  4169.             REQ_ARG();
  4170.           case (uintW)subr_argtype_1_1:
  4171.             # SUBR mit 1 required-Argument und 1 optional-Argument
  4172.             REQ_ARG();
  4173.           case (uintW)subr_argtype_0_1:
  4174.             # SUBR mit 1 optional-Argument
  4175.             OPT_ARG(1);
  4176.             if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
  4177.             goto apply_subr_norest;
  4178.           case (uintW)subr_argtype_2_2:
  4179.             # SUBR mit 2 required-Argumenten und 2 optional-Argumenten
  4180.             REQ_ARG();
  4181.           case (uintW)subr_argtype_1_2:
  4182.             # SUBR mit 1 required-Argument und 2 optional-Argumenten
  4183.             REQ_ARG();
  4184.           case (uintW)subr_argtype_0_2:
  4185.             # SUBR mit 2 optional-Argumenten
  4186.             OPT_ARG(2);
  4187.             OPT_ARG(1);
  4188.             if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
  4189.             goto apply_subr_norest;
  4190.           case (uintW)subr_argtype_0_5:
  4191.             # SUBR mit 5 optional-Argumenten
  4192.             OPT_ARG(5);
  4193.           case (uintW)subr_argtype_0_4:
  4194.             # SUBR mit 4 optional-Argumenten
  4195.             OPT_ARG(4);
  4196.           case (uintW)subr_argtype_0_3:
  4197.             # SUBR mit 3 optional-Argumenten
  4198.             OPT_ARG(3);
  4199.             OPT_ARG(2);
  4200.             OPT_ARG(1);
  4201.             if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
  4202.             goto apply_subr_norest;
  4203.           unbound_optional_5: # Noch 5 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4204.             pushSTACK(unbound);
  4205.           unbound_optional_4: # Noch 4 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4206.             pushSTACK(unbound);
  4207.           unbound_optional_3: # Noch 3 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4208.             pushSTACK(unbound);
  4209.           unbound_optional_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4210.             pushSTACK(unbound);
  4211.           unbound_optional_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
  4212.             pushSTACK(unbound);
  4213.             goto apply_subr_norest;
  4214.           case (uintW)subr_argtype_3_0_rest:
  4215.             # SUBR mit 3 required-Argumenten und weiteren Argumenten
  4216.             REQ_ARG();
  4217.           case (uintW)subr_argtype_2_0_rest:
  4218.             # SUBR mit 2 required-Argumenten und weiteren Argumenten
  4219.             REQ_ARG();
  4220.           case (uintW)subr_argtype_1_0_rest:
  4221.             # SUBR mit 1 required-Argument und weiteren Argumenten
  4222.             REQ_ARG();
  4223.           case (uintW)subr_argtype_0_0_rest:
  4224.             # SUBR mit weiteren Argumenten
  4225.             if (args_on_stack==0)
  4226.               goto apply_subr_rest_onlylist;
  4227.               else
  4228.               goto apply_subr_rest_withlist;
  4229.           case (uintW)subr_argtype_4_0_key:
  4230.             # SUBR mit 4 required-Argumenten und Keyword-Argumenten
  4231.             REQ_ARG();
  4232.           case (uintW)subr_argtype_3_0_key:
  4233.             # SUBR mit 3 required-Argumenten und Keyword-Argumenten
  4234.             REQ_ARG();
  4235.           case (uintW)subr_argtype_2_0_key:
  4236.             # SUBR mit 2 required-Argumenten und Keyword-Argumenten
  4237.             REQ_ARG();
  4238.           case (uintW)subr_argtype_1_0_key:
  4239.             # SUBR mit 1 required-Argument und Keyword-Argumenten
  4240.             REQ_ARG();
  4241.           case (uintW)subr_argtype_0_0_key:
  4242.             # SUBR mit Keyword-Argumenten
  4243.             if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
  4244.             goto apply_subr_key;
  4245.           case (uintW)subr_argtype_1_1_key:
  4246.             # SUBR mit 1 required-Argument, 1 optional-Argument und Keyword-Argumenten
  4247.             REQ_ARG();
  4248.           case (uintW)subr_argtype_0_1_key:
  4249.             # SUBR mit 1 optional-Argument und Keyword-Argumenten
  4250.             OPT_ARG(key_1);
  4251.             if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
  4252.             goto apply_subr_key;
  4253.           case (uintW)subr_argtype_1_2_key:
  4254.             # SUBR mit 1 required-Argument, 2 optional-Argumenten und Keyword-Argumenten
  4255.             REQ_ARG();
  4256.             OPT_ARG(key_2);
  4257.             OPT_ARG(key_1);
  4258.             if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
  4259.             goto apply_subr_key;
  4260.           unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4261.             pushSTACK(unbound);
  4262.           unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
  4263.             pushSTACK(unbound);
  4264.           unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0 und atomp(args)
  4265.             { var reg1 uintC count;
  4266.               dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
  4267.             }
  4268.             goto apply_subr_norest;
  4269.           default: NOTREACHED
  4270.           #undef OPT_ARG
  4271.           #undef REQ_ARG
  4272.         }
  4273.       # Nun die allgemeine Version:
  4274.      {var reg5 uintC req_anz = TheSubr(fun)->req_anz;
  4275.       var reg6 uintC opt_anz = TheSubr(fun)->opt_anz;
  4276.       var reg7 uintC key_anz = TheSubr(fun)->key_anz;
  4277.       if (args_on_stack < req_anz)
  4278.         # weniger Argumente da als verlangt
  4279.         { req_anz = req_anz - args_on_stack; # soviele müssen noch auf den STACK
  4280.           # Platz auf dem STACK reservieren:
  4281.           get_space_on_STACK(sizeof(object) * (uintL)(req_anz + opt_anz + key_anz));
  4282.           # required Parameter in den Stack ablegen:
  4283.           { var reg1 uintC count;
  4284.             dotimespC(count,req_anz,
  4285.               { if (atomp(args)) { goto fehler_zuwenig; }
  4286.                 pushSTACK(Car(args)); # nächstes Argument ablegen
  4287.                 args = Cdr(args);
  4288.               });
  4289.           }
  4290.           goto optionals_from_list;
  4291.         }
  4292.       args_on_stack -= req_anz; # verbleibende Anzahl
  4293.       if (args_on_stack < opt_anz)
  4294.         # Argumente im Stack reichen nicht für die optionalen
  4295.         { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
  4296.           # Platz auf dem STACK reservieren:
  4297.           get_space_on_STACK(sizeof(object) * (uintL)(opt_anz + key_anz));
  4298.           optionals_from_list:
  4299.           # optionale Parameter in den Stack ablegen:
  4300.           { var reg1 uintC count = opt_anz;
  4301.             loop
  4302.               { if (atomp(args)) break; # Argumentliste zu Ende?
  4303.                 if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
  4304.                 count--;
  4305.                 pushSTACK(Car(args)); # nächstes Argument ablegen
  4306.                 args = Cdr(args);
  4307.               }
  4308.             # Argumentliste beendet.
  4309.             # Alle weiteren count optionalen Parameter bekommen den "Wert"
  4310.             # #<UNBOUND>, auch die Keyword-Parameter:
  4311.             dotimesC(count,count + key_anz, { pushSTACK(unbound); } );
  4312.             if (TheSubr(fun)->rest_flag == subr_rest) # &REST-Flag?
  4313.               # ja -> 0 zusätzliche Argumente:
  4314.               { argcount = 0; rest_args_pointer = args_end_pointer;
  4315.                 goto apply_subr_rest;
  4316.               }
  4317.               else
  4318.               # nein -> nichts zu tun
  4319.               { goto apply_subr_norest; }
  4320.           }
  4321.           optionals_ok: # optionale Argumente OK, (nichtleere) Liste weiter abarbeiten
  4322.           if (TheSubr(fun)->key_flag == subr_nokey)
  4323.             # SUBR ohne KEY
  4324.             { if (TheSubr(fun)->rest_flag == subr_norest)
  4325.                 # SUBR ohne REST oder KEY
  4326.                 { fehler_subr_zuviel(fun); } # zuviele Argumente
  4327.                 else
  4328.                 # SUBR mit nur REST, ohne KEY
  4329.                 apply_subr_rest_onlylist:
  4330.                 { argcount = 0; rest_args_pointer = args_end_pointer;
  4331.                   goto rest_from_list;
  4332.                 }
  4333.             }
  4334.             else
  4335.             # SUBR mit KEY
  4336.             { key_args_pointer = args_end_pointer;
  4337.               { var reg1 uintC count;
  4338.                 dotimesC(count,key_anz, { pushSTACK(unbound); } );
  4339.               }
  4340.               rest_args_pointer = args_end_pointer;
  4341.               argcount = 0;
  4342.               goto key_from_list;
  4343.             }
  4344.         }
  4345.       args_on_stack -= opt_anz; # verbleibende Anzahl
  4346.       if (TheSubr(fun)->key_flag == subr_nokey)
  4347.         # SUBR ohne KEY
  4348.         { if (TheSubr(fun)->rest_flag == subr_norest)
  4349.             # SUBR ohne REST oder KEY
  4350.             { if ((args_on_stack>0) || consp(args)) # noch Argumente?
  4351.                 { fehler_subr_zuviel(fun); }
  4352.               goto apply_subr_norest;
  4353.             }
  4354.             else
  4355.             # SUBR mit nur REST, ohne KEY
  4356.             apply_subr_rest_withlist:
  4357.             { argcount = args_on_stack;
  4358.               rest_args_pointer = args_end_pointer STACKop argcount;
  4359.               rest_from_list: # restliche Argumente aus der Liste nehmen
  4360.               while (consp(args))
  4361.                 { check_STACK(); pushSTACK(Car(args)); # nächstes Argument in den Stack
  4362.                   args = Cdr(args);
  4363.                   argcount++;
  4364.                 }
  4365.               if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1)) # zu viele Argumente?
  4366.                 { goto fehler_zuviel; }
  4367.               goto apply_subr_rest;
  4368.             }
  4369.         }
  4370.         else
  4371.         # SUBR mit Keywords.
  4372.         { if (FALSE)
  4373.             apply_subr_key: { key_anz = TheSubr(fun)->key_anz; }
  4374.           # restliche Argumente im STACK nach unten schieben und dadurch
  4375.           # Platz für die Keyword-Parameter schaffen:
  4376.           argcount = args_on_stack;
  4377.           get_space_on_STACK(sizeof(object) * (uintL)key_anz);
  4378.           {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)key_anz;
  4379.            var reg1 object* ptr1 = args_end_pointer;
  4380.            var reg1 object* ptr2 = new_args_end_pointer;
  4381.            var reg1 uintC count;
  4382.            dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
  4383.            key_args_pointer = ptr1;
  4384.            rest_args_pointer = ptr2;
  4385.            dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
  4386.            set_args_end_pointer(new_args_end_pointer);
  4387.           }
  4388.           key_from_list: # restliche Argumente für Keywords aus der Liste nehmen
  4389.           while (consp(args))
  4390.             { check_STACK(); pushSTACK(Car(args)); # nächstes Argument in den Stack
  4391.               args = Cdr(args);
  4392.               argcount++;
  4393.             }
  4394.           # Keywords zuordnen und evtl. restliche Argumente wegwerfen:
  4395.           match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
  4396.           if (TheSubr(fun)->rest_flag == subr_norest)
  4397.             # SUBR ohne &REST-Flag:
  4398.             apply_subr_norest:
  4399.             { if (!nullp(args)) goto fehler_dotted;
  4400.               subr_self = fun;
  4401.               (*(subr_norest_function*)(TheSubr(fun)->function))();
  4402.             }
  4403.             else
  4404.             # SUBR mit &REST-Flag:
  4405.             apply_subr_rest:
  4406.             { if (!nullp(args)) goto fehler_dotted;
  4407.               subr_self = fun;
  4408.               (*(subr_rest_function*)(TheSubr(fun)->function))
  4409.                (argcount,rest_args_pointer);
  4410.             }
  4411.      }  }
  4412.       #if STACKCHECKS
  4413.       if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
  4414.         { abort(); } # nein -> ab in den Debugger
  4415.       #endif
  4416.       return; # fertig
  4417.       # Gesammelte Fehlermeldungen:
  4418.       fehler_zuwenig: fehler_subr_zuwenig(fun);
  4419.       fehler_zuviel: fehler_subr_zuviel(fun);
  4420.       fehler_dotted: fehler_apply_dotted(TheSubr(fun)->name);
  4421.     }
  4422.  
  4423. # Fehler wegen zu vielen Argumenten für eine Closure
  4424. # > closure: Funktion, eine Closure
  4425.   nonreturning_function(local, fehler_closure_zuviel, (object closure));
  4426.   #define fehler_closure_zuviel(closure)  fehler_apply_zuviel(closure)
  4427.  
  4428. # Fehler wegen zu wenig Argumenten für eine Closure
  4429. # > closure: Funktion, eine Closure
  4430.   nonreturning_function(local, fehler_closure_zuwenig, (object closure));
  4431.   #define fehler_closure_zuwenig(closure)  fehler_apply_zuwenig(closure)
  4432.  
  4433. # In APPLY: Wendet eine Closure auf eine Argumentliste an, räumt den STACK auf
  4434. # und liefert die Werte.
  4435. # apply_closure(fun,args_on_stack,other_args);
  4436. # > fun: Funktion, eine Closure
  4437. # > Argumente: args_on_stack Argumente auf dem STACK,
  4438. #              restliche Argumentliste in other_args
  4439. # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
  4440. # < mv_count/mv_space: Werte
  4441. # verändert STACK, kann GC auslösen
  4442.   local Values apply_closure(closure,args_on_stack,args)
  4443.     var reg5 object closure;
  4444.     var reg3 uintC args_on_stack;
  4445.     var reg2 object args;
  4446.     {
  4447.       #ifdef DEBUG_EVAL
  4448.       if (sym_streamp(S(funcall_trace_output)))
  4449.         { pushSTACK(closure); trace_call(closure,'A','C'); closure = popSTACK(); }
  4450.       #endif
  4451.       if (m_simple_bit_vector_p(TheClosure(closure)->clos_codevec))
  4452.         # closure ist eine compilierte Closure
  4453.         {
  4454.           #if STACKCHECKC
  4455.           var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
  4456.           #endif
  4457.           var reg4 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
  4458.           var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
  4459.           var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
  4460.           var reg8 uintL argcount; # Anzahl der restlichen Argumente
  4461.           check_SP(); check_STACK();
  4462.           # Argumente in den STACK legen:
  4463.           # erst ein Dispatch für die wichtigsten Fälle:
  4464.           switch (TheSbvector(codevec)->data[CCHD+5])
  4465.             { # Macro für ein required-Argument:
  4466.               #define REQ_ARG()  \
  4467.                 { if (args_on_stack>0) { args_on_stack--; }                      \
  4468.                   elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
  4469.                   else goto fehler_zuwenig;                                      \
  4470.                 }
  4471.               # Macro für das n-letzte optional-Argument:
  4472.               #define OPT_ARG(n)  \
  4473.                 { if (args_on_stack>0) { args_on_stack--; }                      \
  4474.                   elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
  4475.                   else goto unbound_optional_##n;                                \
  4476.                 }
  4477.               case (uintB)cclos_argtype_5_0:
  4478.                 # 5 required-Argumente
  4479.                 REQ_ARG();
  4480.               case (uintB)cclos_argtype_4_0:
  4481.                 # 4 required-Argumente
  4482.                 REQ_ARG();
  4483.               case (uintB)cclos_argtype_3_0:
  4484.                 # 3 required-Argumente
  4485.                 REQ_ARG();
  4486.               case (uintB)cclos_argtype_2_0:
  4487.                 # 2 required-Argumente
  4488.                 REQ_ARG();
  4489.               case (uintB)cclos_argtype_1_0:
  4490.                 # 1 required-Argument
  4491.                 REQ_ARG();
  4492.               case (uintB)cclos_argtype_0_0:
  4493.                 # keine Argumente
  4494.                 noch_0_opt_args:
  4495.                 if (args_on_stack>0) goto fehler_zuviel;
  4496.                 if (!nullp(args))
  4497.                   { if (consp(args))
  4498.                       goto fehler_zuviel;
  4499.                       else
  4500.                       goto fehler_dotted;
  4501.                   }
  4502.                 goto apply_cclosure_nokey;
  4503.               case (uintB)cclos_argtype_4_1:
  4504.                 # 4 required-Argumente und 1 optional-Argument
  4505.                 REQ_ARG();
  4506.               case (uintB)cclos_argtype_3_1:
  4507.                 # 3 required-Argumente und 1 optional-Argument
  4508.                 REQ_ARG();
  4509.               case (uintB)cclos_argtype_2_1:
  4510.                 # 2 required-Argumente und 1 optional-Argument
  4511.                 REQ_ARG();
  4512.               case (uintB)cclos_argtype_1_1:
  4513.                 # 1 required-Argument und 1 optional-Argument
  4514.                 REQ_ARG();
  4515.               case (uintB)cclos_argtype_0_1:
  4516.                 # 1 optional-Argument
  4517.                 noch_1_opt_args:
  4518.                 OPT_ARG(1);
  4519.                 goto noch_0_opt_args;
  4520.               case (uintB)cclos_argtype_3_2:
  4521.                 # 3 required-Argumente und 2 optional-Argumente
  4522.                 REQ_ARG();
  4523.               case (uintB)cclos_argtype_2_2:
  4524.                 # 2 required-Argumente und 2 optional-Argumente
  4525.                 REQ_ARG();
  4526.               case (uintB)cclos_argtype_1_2:
  4527.                 # 1 required-Argument und 2 optional-Argumente
  4528.                 REQ_ARG();
  4529.               case (uintB)cclos_argtype_0_2:
  4530.                 # 2 optional-Argumente
  4531.                 noch_2_opt_args:
  4532.                 OPT_ARG(2);
  4533.                 goto noch_1_opt_args;
  4534.               case (uintB)cclos_argtype_2_3:
  4535.                 # 2 required-Argumente und 3 optional-Argumente
  4536.                 REQ_ARG();
  4537.               case (uintB)cclos_argtype_1_3:
  4538.                 # 1 required-Argument und 3 optional-Argumente
  4539.                 REQ_ARG();
  4540.               case (uintB)cclos_argtype_0_3:
  4541.                 # 3 optional-Argumente
  4542.                 noch_3_opt_args:
  4543.                 OPT_ARG(3);
  4544.                 goto noch_2_opt_args;
  4545.               case (uintB)cclos_argtype_1_4:
  4546.                 # 1 required-Argument und 4 optional-Argumente
  4547.                 REQ_ARG();
  4548.               case (uintB)cclos_argtype_0_4:
  4549.                 # 4 optional-Argumente
  4550.                 noch_4_opt_args:
  4551.                 OPT_ARG(4);
  4552.                 goto noch_3_opt_args;
  4553.               case (uintB)cclos_argtype_0_5:
  4554.                 # 5 optional-Argumente
  4555.                 OPT_ARG(5);
  4556.                 goto noch_4_opt_args;
  4557.               unbound_optional_5: # Noch 5 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4558.                 pushSTACK(unbound);
  4559.               unbound_optional_4: # Noch 4 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4560.                 pushSTACK(unbound);
  4561.               unbound_optional_3: # Noch 3 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4562.                 pushSTACK(unbound);
  4563.               unbound_optional_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4564.                 pushSTACK(unbound);
  4565.               unbound_optional_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
  4566.                 pushSTACK(unbound);
  4567.                 if (!nullp(args)) goto fehler_dotted;
  4568.                 goto apply_cclosure_nokey;
  4569.               case (uintB)cclos_argtype_4_0_rest:
  4570.                 # 4 required-Argumente, Rest-Parameter
  4571.                 REQ_ARG();
  4572.               case (uintB)cclos_argtype_3_0_rest:
  4573.                 # 3 required-Argumente, Rest-Parameter
  4574.                 REQ_ARG();
  4575.               case (uintB)cclos_argtype_2_0_rest:
  4576.                 # 2 required-Argumente, Rest-Parameter
  4577.                 REQ_ARG();
  4578.               case (uintB)cclos_argtype_1_0_rest:
  4579.                 # 1 required-Argument, Rest-Parameter
  4580.                 REQ_ARG();
  4581.               case (uintB)cclos_argtype_0_0_rest:
  4582.                 # keine Argumente, Rest-Parameter
  4583.                 goto apply_cclosure_rest_nokey;
  4584.               case (uintB)cclos_argtype_4_0_key:
  4585.                 # 4 required-Argumente, Keyword-Argumente
  4586.                 REQ_ARG();
  4587.               case (uintB)cclos_argtype_3_0_key:
  4588.                 # 3 required-Argumente, Keyword-Argumente
  4589.                 REQ_ARG();
  4590.               case (uintB)cclos_argtype_2_0_key:
  4591.                 # 2 required-Argumente, Keyword-Argumente
  4592.                 REQ_ARG();
  4593.               case (uintB)cclos_argtype_1_0_key:
  4594.                 # 1 required-Argument, Keyword-Argumente
  4595.                 REQ_ARG();
  4596.                 noch_0_opt_args_key:
  4597.               case (uintB)cclos_argtype_0_0_key:
  4598.                 # nur Keyword-Argumente
  4599.                 if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
  4600.                 goto apply_cclosure_key_withlist;
  4601.               case (uintB)cclos_argtype_3_1_key:
  4602.                 # 3 required-Argumente und 1 optional-Argument, Keyword-Argumente
  4603.                 REQ_ARG();
  4604.               case (uintB)cclos_argtype_2_1_key:
  4605.                 # 2 required-Argumente und 1 optional-Argument, Keyword-Argumente
  4606.                 REQ_ARG();
  4607.               case (uintB)cclos_argtype_1_1_key:
  4608.                 # 1 required-Argument und 1 optional-Argument, Keyword-Argumente
  4609.                 REQ_ARG();
  4610.               case (uintB)cclos_argtype_0_1_key:
  4611.                 # 1 optional-Argument, Keyword-Argumente
  4612.                 noch_1_opt_args_key:
  4613.                 OPT_ARG(key_1);
  4614.                 goto noch_0_opt_args_key;
  4615.               case (uintB)cclos_argtype_2_2_key:
  4616.                 # 2 required-Argumente und 2 optional-Argumente, Keyword-Argumente
  4617.                 REQ_ARG();
  4618.               case (uintB)cclos_argtype_1_2_key:
  4619.                 # 1 required-Argument und 2 optional-Argumente, Keyword-Argumente
  4620.                 REQ_ARG();
  4621.               case (uintB)cclos_argtype_0_2_key:
  4622.                 # 2 optional-Argumente, Keyword-Argumente
  4623.                 noch_2_opt_args_key:
  4624.                 OPT_ARG(key_2);
  4625.                 goto noch_1_opt_args_key;
  4626.               case (uintB)cclos_argtype_1_3_key:
  4627.                 # 1 required-Argument und 3 optional-Argumente, Keyword-Argumente
  4628.                 REQ_ARG();
  4629.               case (uintB)cclos_argtype_0_3_key:
  4630.                 # 3 optional-Argumente, Keyword-Argumente
  4631.                 noch_3_opt_args_key:
  4632.                 OPT_ARG(key_3);
  4633.                 goto noch_2_opt_args_key;
  4634.               case (uintB)cclos_argtype_0_4_key:
  4635.                 # 4 optional-Argumente, Keyword-Argumente
  4636.                 OPT_ARG(key_4);
  4637.                 goto noch_3_opt_args_key;
  4638.               unbound_optional_key_4: # Noch 4 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4639.                 pushSTACK(unbound);
  4640.               unbound_optional_key_3: # Noch 3 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4641.                 pushSTACK(unbound);
  4642.               unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
  4643.                 pushSTACK(unbound);
  4644.               unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
  4645.                 pushSTACK(unbound);
  4646.               unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0 und atomp(args)
  4647.                 if (!nullp(args)) goto fehler_dotted;
  4648.                 goto apply_cclosure_key_noargs;
  4649.               case (uintB)cclos_argtype_default:
  4650.                 # Allgemeine Version
  4651.                 break;
  4652.               default: NOTREACHED
  4653.               #undef OPT_ARG
  4654.               #undef REQ_ARG
  4655.             }
  4656.           # Nun die allgemeine Version:
  4657.          {var reg5 uintC req_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]); # Anzahl required Parameter
  4658.           var reg6 uintC opt_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+2]); # Anzahl optionale Parameter
  4659.           var reg7 uintB flags = TheSbvector(codevec)->data[CCHD+4]; # Flags
  4660.           if (args_on_stack < req_anz)
  4661.             # weniger Argumente da als verlangt
  4662.             { req_anz = req_anz - args_on_stack; # soviele müssen noch auf den STACK
  4663.               # Platz auf dem STACK reservieren:
  4664.               get_space_on_STACK(sizeof(object) * (uintL)(req_anz + opt_anz));
  4665.               # required Parameter in den Stack ablegen:
  4666.               { var reg1 uintC count;
  4667.                 dotimespC(count,req_anz,
  4668.                   { if (atomp(args)) { goto fehler_zuwenig; }
  4669.                     pushSTACK(Car(args)); # nächstes Argument ablegen
  4670.                     args = Cdr(args);
  4671.                   });
  4672.               }
  4673.               goto optionals_from_list;
  4674.             }
  4675.           args_on_stack -= req_anz; # verbleibende Anzahl
  4676.           if (args_on_stack < opt_anz)
  4677.             # Argumente im Stack reichen nicht für die optionalen
  4678.             { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
  4679.               # Platz auf dem STACK reservieren:
  4680.               get_space_on_STACK(sizeof(object) * (uintL)opt_anz);
  4681.               optionals_from_list:
  4682.               # optionale Parameter in den Stack ablegen:
  4683.               { var reg1 uintC count = opt_anz;
  4684.                 loop
  4685.                   { if (atomp(args)) break; # Argumentliste zu Ende?
  4686.                     if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
  4687.                     count--;
  4688.                     pushSTACK(Car(args)); # nächstes Argument ablegen
  4689.                     args = Cdr(args);
  4690.                   }
  4691.                 # Argumentliste beendet.
  4692.                 if (!nullp(args)) goto fehler_dotted;
  4693.                 # Alle weiteren count optionalen Parameter bekommen den "Wert"
  4694.                 # #<UNBOUND>, der &REST-Parameter den Wert NIL,
  4695.                 # die Keyword-Parameter den Wert #<UNBOUND> :
  4696.                 dotimesC(count,count, { pushSTACK(unbound); } );
  4697.                 if (flags & bit(0)) # &REST-Flag?
  4698.                   { pushSTACK(NIL); } # ja -> mit NIL initialisieren
  4699.                 if (flags & bit(7)) # &KEY-Flag?
  4700.                   apply_cclosure_key_noargs:
  4701.                   { var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
  4702.                     get_space_on_STACK(sizeof(object) * (uintL)key_anz);
  4703.                     {var reg1 uintC count;
  4704.                      dotimesC(count,key_anz, { pushSTACK(unbound); } ); # mit #<UNBOUND> initialisieren
  4705.                     }
  4706.                     goto apply_cclosure_key;
  4707.                   }
  4708.                   else
  4709.                   goto apply_cclosure_nokey;
  4710.               }
  4711.               optionals_ok:
  4712.               # Rest- und Keyword-Parameter behandeln.
  4713.               # args = restliche Argumentliste (noch nicht zu Ende)
  4714.               if (flags == 0)
  4715.                 # Closure ohne REST oder KEY -> Argumentliste müßte zu Ende sein
  4716.                 { goto fehler_zuviel; }
  4717.               # evtl. den Rest-Parameter füllen:
  4718.               if (flags & bit(0))
  4719.                 { pushSTACK(args); }
  4720.               if (flags & bit(7)) # Key-Flag?
  4721.                 # Closure mit Keywords.
  4722.                 # args = restliche Argumentliste (noch nicht zu Ende)
  4723.                 # Erst die Keyword-Parameter mit #<UNBOUND> vorbesetzen,
  4724.                 # dann die restlichen Argumente im Stack ablegen,
  4725.                 # dann die Keywords zuordnen:
  4726.                 { key_args_pointer = args_end_pointer; # Pointer über Keyword-Parameter
  4727.                   # alle Keyword-Parameter mit #<UNBOUND> vorbesetzen:
  4728.                   { var reg1 uintC count = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]);
  4729.                     dotimesC(count,count, { pushSTACK(unbound); } );
  4730.                   }
  4731.                   rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
  4732.                   argcount = 0; # Zähler für die restlichen Argumente
  4733.                   goto key_from_list;
  4734.                 }
  4735.                 else
  4736.                 # Closure mit nur REST, ohne KEY:
  4737.                 goto apply_cclosure_nokey;
  4738.             }
  4739.           args_on_stack -= opt_anz; # verbleibende Anzahl
  4740.           if (flags & bit(7)) # Key-Flag?
  4741.             { if (FALSE)
  4742.                 apply_cclosure_key_withlist:
  4743.                 { flags = TheSbvector(codevec)->data[CCHD+4]; } # Flags initialisieren!
  4744.             # Closure mit Keywords
  4745.              {var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
  4746.               # restliche Argumente im STACK nach unten schieben und dadurch
  4747.               # Platz für die Keyword-Parameter (und evtl. Rest-Parameter)
  4748.               # schaffen:
  4749.               var reg1 uintL shift = key_anz;
  4750.               if (flags & bit(0)) { shift++; } # evtl. 1 mehr für Rest-Parameter
  4751.               argcount = args_on_stack;
  4752.               get_space_on_STACK(sizeof(object) * shift);
  4753.               {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)shift;
  4754.                var reg1 object* ptr1 = args_end_pointer;
  4755.                var reg1 object* ptr2 = new_args_end_pointer;
  4756.                var reg1 uintC count;
  4757.                dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
  4758.                if (flags & bit(0)) { NEXT(ptr1) = unbound; } # Rest-Parameter
  4759.                key_args_pointer = ptr1;
  4760.                rest_args_pointer = ptr2;
  4761.                dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
  4762.                set_args_end_pointer(new_args_end_pointer);
  4763.               }
  4764.               key_from_list: # restliche Argumente für Keywords aus der Liste nehmen
  4765.               while (consp(args))
  4766.                 { check_STACK(); pushSTACK(Car(args)); # nächstes Argument in den Stack
  4767.                   args = Cdr(args);
  4768.                   argcount++;
  4769.                 }
  4770.               # Argumentliste beendet.
  4771.               if (!nullp(args)) goto fehler_dotted;
  4772.               # Keywords zuordnen, Rest-Parameter bauen
  4773.               # und evtl. restliche Argumente wegwerfen:
  4774.               closure = match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer);
  4775.               codevec = TheCclosure(closure)->clos_codevec;
  4776.               apply_cclosure_key:
  4777.               interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
  4778.             }}
  4779.           elif (flags & bit(0))
  4780.             apply_cclosure_rest_nokey:
  4781.             # Closure mit nur REST, ohne KEY:
  4782.             { # muß noch args_on_stack Argumente aus dem Stack auf args consen:
  4783.               pushSTACK(args);
  4784.               pushSTACK(closure); # Closure muß gerettet werden
  4785.               dotimesC(args_on_stack,args_on_stack,
  4786.                 { var reg1 object new_cons = allocate_cons();
  4787.                   Cdr(new_cons) = STACK_1;
  4788.                   Car(new_cons) = STACK_2; # nächstes Argument draufconsen
  4789.                   STACK_2 = new_cons;
  4790.                   STACK_1 = STACK_0; skipSTACK(1);
  4791.                 });
  4792.               closure = popSTACK(); codevec = TheCclosure(closure)->clos_codevec;
  4793.               goto apply_cclosure_nokey;
  4794.             }
  4795.           else
  4796.             # Closure ohne REST oder KEY
  4797.             { if ((args_on_stack>0) || consp(args)) # noch Argumente?
  4798.                 goto fehler_zuviel;
  4799.               apply_cclosure_nokey: # Closure ohne &KEY anspringen:
  4800.               interpret_bytecode(closure,codevec,CCHD+6); # Bytecode ab Byte 6 abinterpretieren
  4801.             }
  4802.          }
  4803.           #if STACKCHECKC
  4804.           if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
  4805.             { abort(); } # nein -> ab in den Debugger
  4806.           #endif
  4807.           return; # fertig
  4808.           # Gesammelte Fehlermeldungen:
  4809.           fehler_zuwenig: fehler_closure_zuwenig(closure);
  4810.           fehler_zuviel: fehler_closure_zuviel(closure);
  4811.           fehler_dotted: fehler_apply_dotted(closure);
  4812.         }
  4813.         else
  4814.         # closure ist eine interpretierte Closure
  4815.         { # Platz auf dem STACK reservieren:
  4816.           get_space_on_STACK(sizeof(object) * llength(args));
  4817.           while (consp(args)) # Noch Argumente in der Liste?
  4818.             { pushSTACK(Car(args)); # nächstes Element in den STACK
  4819.               args = Cdr(args);
  4820.               args_on_stack += 1;
  4821.               if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
  4822.                 goto fehler_zuviel;
  4823.             }
  4824.           funcall_iclosure(closure,args_end_pointer STACKop args_on_stack,args_on_stack);
  4825.         }
  4826.     }
  4827.  
  4828.  
  4829. #        ----------------------- F U N C A L L -----------------------
  4830.  
  4831. # später:
  4832.   local Values funcall_subr (object fun, uintC args_on_stack);
  4833.   local Values funcall_closure (object fun, uintC args_on_stack);
  4834.  
  4835. # UP: Wendet eine Funktion auf ihre Argumente an.
  4836. # funcall(function,argcount);
  4837. # > function: Funktion
  4838. # > Argumente: argcount Argumente auf dem STACK
  4839. # < STACK: aufgeräumt (d.h. STACK wird um argcount erhöht)
  4840. # < mv_count/mv_space: Werte
  4841. # verändert STACK, kann GC auslösen
  4842.   global Values funcall (object fun, uintC argcount);
  4843.   global Values funcall(fun,args_on_stack)
  4844.     var reg2 object fun;
  4845.     var reg3 uintC args_on_stack;
  4846.     { # fun muß ein SUBR oder eine Closure oder ein Cons (LAMBDA ...) sein:
  4847.       var reg1 tint type = typecode(fun); # Typinfo
  4848.       if (type == subr_type) # SUBR ?
  4849.         { return_Values funcall_subr(fun,args_on_stack); }
  4850.       elif (type == closure_type) # Closure ?
  4851.         { return_Values funcall_closure(fun,args_on_stack); }
  4852.       elif (symbolp(fun)) # Symbol ?
  4853.         # Symbol anwenden: globale Definition Symbol_function(fun) gilt.
  4854.         { type = mtypecode(Symbol_function(fun)); # Typinfo davon
  4855.           if (type == subr_type) # SUBR -> anwenden
  4856.             { return_Values funcall_subr(Symbol_function(fun),args_on_stack); }
  4857.           elif (type == closure_type) # Closure -> anwenden
  4858.             { return_Values funcall_closure(Symbol_function(fun),args_on_stack); }
  4859.           elif (type == orecord_type)
  4860.             {
  4861.               #ifdef DYNAMIC_FFI
  4862.               if (ffunctionp(Symbol_function(fun))) # Foreign-Function ?
  4863.                 { fun = Symbol_function(fun); goto call_ffunction; }
  4864.               #endif
  4865.               # FSUBR -> Fehler
  4866.               pushSTACK(fun);
  4867.               # dpANS sagt: undefined_function ??
  4868.               //: DEUTSCH "FUNCALL: ~ ist eine Spezialform, keine Funktion."
  4869.               //: ENGLISH "FUNCALL: ~ is a special form, not a function"
  4870.               //: FRANCAIS "FUNCALL: ~ est une forme spéciale et non une fonction."
  4871.               fehler(error, GETTEXT("FUNCALL: ~ is a special form, not a function"));
  4872.             }
  4873.           elif (mconsp(Symbol_function(fun))) # Macro-Cons -> Fehler
  4874.             { pushSTACK(fun);
  4875.               # dpANS sagt: undefined_function ??
  4876.               //: DEUTSCH "FUNCALL: ~ ist ein Macro, keine Funktion."
  4877.               //: ENGLISH "FUNCALL: ~ is a macro, not a function"
  4878.               //: FRANCAIS "FUNCALL: ~ est un macro et non une fonction."
  4879.               fehler(error, GETTEXT("FUNCALL: ~ is a macro, not a function"));
  4880.             }
  4881.           else
  4882.             # wenn kein SUBR, keine Closure, kein FSUBR, kein Cons:
  4883.             # Symbol_function(fun) muß #<UNBOUND> sein.
  4884.             undef:
  4885.             { pushSTACK(fun); # Wert für Slot NAME von CELL-ERROR
  4886.               pushSTACK(fun);
  4887.               //: DEUTSCH "FUNCALL: Die Funktion ~ ist undefiniert."
  4888.               //: ENGLISH "FUNCALL: the function ~ is undefined"
  4889.               //: FRANCAIS "FUNCALL: La fonction ~ n'est pas définie."
  4890.               fehler(undefined_function, GETTEXT("FUNCALL: the function ~ is undefined"));
  4891.             }
  4892.         }
  4893.       elif (funnamep(fun)) # Liste (SETF symbol) ?
  4894.         # globale Definition (symbol-function (get-setf-symbol symbol)) gilt.
  4895.         { var reg5 object symbol = get(Car(Cdr(fun)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
  4896.           if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
  4897.             goto undef; # sonst undefiniert
  4898.           type = mtypecode(Symbol_function(symbol)); # Typinfo davon
  4899.           if (type == closure_type) # Closure -> anwenden
  4900.             { return_Values funcall_closure(Symbol_function(symbol),args_on_stack); }
  4901.           elif (type == subr_type) # SUBR -> anwenden
  4902.             { return_Values funcall_subr(Symbol_function(symbol),args_on_stack); }
  4903.           else
  4904.             # Solche Funktionsnamen können keine FSUBRs oder Macros bezeichnen.
  4905.             # Symbol_function(symbol) wird vermutlich #<UNBOUND> sein.
  4906.             goto undef;
  4907.         }
  4908.       elif (consp(fun) && eq(Car(fun),S(lambda))) # Cons (LAMBDA ...) ?
  4909.         # Lambda-Ausdruck: zu einer Funktion mit leerem Environment machen
  4910.         { # leeres Environment bauen:
  4911.          {var reg5 environment* env5;
  4912.           make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env5 = );
  4913.           fun = get_closure(Cdr(fun), # Lambdabody (lambda-list {decl|doc} . body)
  4914.                             S(Klambda), # :LAMBDA als Name
  4915.                             env5); # im leeren Environment
  4916.           skipSTACK(5); # Environment wieder vergessen
  4917.           # und neu erzeugte Closure anwenden:
  4918.           return_Values funcall_closure(fun,args_on_stack);
  4919.         }}
  4920.       #ifdef DYNAMIC_FFI
  4921.       elif (ffunctionp(fun)) # Foreign-Function ?
  4922.         # (SYS::FOREIGN-CALL-OUT foreign-function . args) aufrufen
  4923.         call_ffunction:
  4924.         { # Dazu erst die Argumente im Stack um 1 nach unten verschieben.
  4925.           var reg6 uintC count;
  4926.           var reg5 object* ptr = &STACK_0;
  4927.           dotimesC(count,args_on_stack,
  4928.             { *(ptr STACKop -1) = *ptr; ptr skipSTACKop 1; }
  4929.             );
  4930.           *(ptr STACKop -1) = fun;
  4931.           skipSTACK(-1);
  4932.           return_Values funcall_subr(L(foreign_call_out),args_on_stack+1);
  4933.         }
  4934.       #endif
  4935.       else
  4936.         { pushSTACK(fun);
  4937.           //: DEUTSCH "FUNCALL: ~ ist keine Funktionsbezeichnung."
  4938.           //: ENGLISH "FUNCALL: ~ is not a function name"
  4939.           //: FRANCAIS "FUNCALL: ~ n'est pas un nom de fonction."
  4940.           fehler(error, GETTEXT("FUNCALL: ~ is not a function name"));
  4941.         }
  4942.     }
  4943.  
  4944. # In FUNCALL: Wendet ein SUBR auf Argumente an, räumt den STACK auf
  4945. # und liefert die Werte.
  4946. # funcall_subr(fun,args_on_stack);
  4947. # > fun: Funktion, ein SUBR
  4948. # > Argumente: args_on_stack Argumente auf dem STACK
  4949. # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
  4950. # < mv_count/mv_space: Werte
  4951. # verändert STACK, kann GC auslösen
  4952.   local Values funcall_subr(fun,args_on_stack)
  4953.     var reg4 object fun;
  4954.     var reg3 uintC args_on_stack;
  4955.     {
  4956.       #if STACKCHECKS
  4957.       var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
  4958.       #endif
  4959.       var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
  4960.       var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
  4961.       var reg8 uintL argcount; # Anzahl der restlichen Argumente
  4962.       #ifdef DEBUG_EVAL
  4963.       if (sym_streamp(S(funcall_trace_output)))
  4964.         { pushSTACK(fun); trace_call(fun,'F','S'); fun = popSTACK(); }
  4965.       #endif
  4966.       # Argumente in den STACK legen:
  4967.       # erst ein Dispatch für die wichtigsten Fälle:
  4968.       switch (TheSubr(fun)->argtype)
  4969.         { case (uintW)subr_argtype_0_0:
  4970.             # SUBR ohne Argumente
  4971.             if (!(args_on_stack==0)) goto fehler_zuviel;
  4972.             goto apply_subr_norest;
  4973.           case (uintW)subr_argtype_1_0:
  4974.             # SUBR mit 1 required-Argument
  4975.             if (!(args_on_stack==1)) goto fehler_anzahl;
  4976.             goto apply_subr_norest;
  4977.           case (uintW)subr_argtype_2_0:
  4978.             # SUBR mit 2 required-Argumenten
  4979.             if (!(args_on_stack==2)) goto fehler_anzahl;
  4980.             goto apply_subr_norest;
  4981.           case (uintW)subr_argtype_3_0:
  4982.             # SUBR mit 3 required-Argumenten
  4983.             if (!(args_on_stack==3)) goto fehler_anzahl;
  4984.             goto apply_subr_norest;
  4985.           case (uintW)subr_argtype_4_0:
  4986.             # SUBR mit 4 required-Argumenten
  4987.             if (!(args_on_stack==4)) goto fehler_anzahl;
  4988.             goto apply_subr_norest;
  4989.           case (uintW)subr_argtype_5_0:
  4990.             # SUBR mit 5 required-Argumenten
  4991.             if (!(args_on_stack==5)) goto fehler_anzahl;
  4992.             goto apply_subr_norest;
  4993.           case (uintW)subr_argtype_6_0:
  4994.             # SUBR mit 6 required-Argumenten
  4995.             if (!(args_on_stack==6)) goto fehler_anzahl;
  4996.             goto apply_subr_norest;
  4997.           case (uintW)subr_argtype_0_1:
  4998.             # SUBR mit 1 optional-Argument
  4999.             if (args_on_stack==1) goto apply_subr_norest;
  5000.             elif (args_on_stack>1) goto fehler_zuviel;
  5001.             else { pushSTACK(unbound); goto apply_subr_norest; }
  5002.           case (uintW)subr_argtype_1_1:
  5003.             # SUBR mit 1 required-Argument und 1 optional-Argument
  5004.             if (args_on_stack==2) goto apply_subr_norest;
  5005.             elif (args_on_stack>2) goto fehler_zuviel;
  5006.             elif (args_on_stack==0) goto fehler_zuwenig;
  5007.             else { pushSTACK(unbound); goto apply_subr_norest; }
  5008.           case (uintW)subr_argtype_2_1:
  5009.             # SUBR mit 2 required-Argumenten und 1 optional-Argument
  5010.             if (args_on_stack==3) goto apply_subr_norest;
  5011.             elif (args_on_stack>3) goto fehler_zuviel;
  5012.             elif (args_on_stack<2) goto fehler_zuwenig;
  5013.             else { pushSTACK(unbound); goto apply_subr_norest; }
  5014.           case (uintW)subr_argtype_3_1:
  5015.             # SUBR mit 3 required-Argumenten und 1 optional-Argument
  5016.             if (args_on_stack==4) goto apply_subr_norest;
  5017.             elif (args_on_stack>4) goto fehler_zuviel;
  5018.             elif (args_on_stack<3) goto fehler_zuwenig;
  5019.             else { pushSTACK(unbound); goto apply_subr_norest; }
  5020.           case (uintW)subr_argtype_4_1:
  5021.             # SUBR mit 4 required-Argumenten und 1 optional-Argument
  5022.             if (args_on_stack==5) goto apply_subr_norest;
  5023.             elif (args_on_stack>5) goto fehler_zuviel;
  5024.             elif (args_on_stack<4) goto fehler_zuwenig;
  5025.             else { pushSTACK(unbound); goto apply_subr_norest; }
  5026.           case (uintW)subr_argtype_0_2:
  5027.             # SUBR mit 2 optional-Argumenten
  5028.             switch (args_on_stack)
  5029.               { case 0: pushSTACK(unbound);
  5030.                 case 1: pushSTACK(unbound);
  5031.                 case 2: goto apply_subr_norest;
  5032.                 default: goto fehler_zuviel;
  5033.               }
  5034.           case (uintW)subr_argtype_1_2:
  5035.             # SUBR mit 1 required-Argument und 2 optional-Argumenten
  5036.             switch (args_on_stack)
  5037.               { case 0: goto fehler_zuwenig;
  5038.                 case 1: pushSTACK(unbound);
  5039.                 case 2: pushSTACK(unbound);
  5040.                 case 3: goto apply_subr_norest;
  5041.                 default: goto fehler_zuviel;
  5042.               }
  5043.           case (uintW)subr_argtype_2_2:
  5044.             # SUBR mit 2 required-Argumenten und 2 optional-Argumenten
  5045.             switch (args_on_stack)
  5046.               { case 0: goto fehler_zuwenig;
  5047.                 case 1: goto fehler_zuwenig;
  5048.                 case 2: pushSTACK(unbound);
  5049.                 case 3: pushSTACK(unbound);
  5050.                 case 4: goto apply_subr_norest;
  5051.                 default: goto fehler_zuviel;
  5052.               }
  5053.           case (uintW)subr_argtype_0_3:
  5054.             # SUBR mit 3 optional-Argumenten
  5055.             switch (args_on_stack)
  5056.               { case 0: pushSTACK(unbound);
  5057.                 case 1: pushSTACK(unbound);
  5058.                 case 2: pushSTACK(unbound);
  5059.                 case 3: goto apply_subr_norest;
  5060.                 default: goto fehler_zuviel;
  5061.               }
  5062.           case (uintW)subr_argtype_0_4:
  5063.             # SUBR mit 4 optional-Argumenten
  5064.             switch (args_on_stack)
  5065.               { case 0: pushSTACK(unbound);
  5066.                 case 1: pushSTACK(unbound);
  5067.                 case 2: pushSTACK(unbound);
  5068.                 case 3: pushSTACK(unbound);
  5069.                 case 4: goto apply_subr_norest;
  5070.                 default: goto fehler_zuviel;
  5071.               }
  5072.           case (uintW)subr_argtype_0_5:
  5073.             # SUBR mit 5 optional-Argumenten
  5074.             switch (args_on_stack)
  5075.               { case 0: pushSTACK(unbound);
  5076.                 case 1: pushSTACK(unbound);
  5077.                 case 2: pushSTACK(unbound);
  5078.                 case 3: pushSTACK(unbound);
  5079.                 case 4: pushSTACK(unbound);
  5080.                 case 5: goto apply_subr_norest;
  5081.                 default: goto fehler_zuviel;
  5082.               }
  5083.           case (uintW)subr_argtype_0_0_rest:
  5084.             # SUBR mit weiteren Argumenten
  5085.             goto apply_subr_rest_ok;
  5086.           case (uintW)subr_argtype_1_0_rest:
  5087.             # SUBR mit 1 required-Argument und weiteren Argumenten
  5088.             if (args_on_stack==0) goto fehler_zuwenig;
  5089.             args_on_stack -= 1;
  5090.             goto apply_subr_rest_ok;
  5091.           case (uintW)subr_argtype_2_0_rest:
  5092.             # SUBR mit 2 required-Argumenten und weiteren Argumenten
  5093.             if (args_on_stack<2) goto fehler_zuwenig;
  5094.             args_on_stack -= 2;
  5095.             goto apply_subr_rest_ok;
  5096.           case (uintW)subr_argtype_3_0_rest:
  5097.             # SUBR mit 3 required-Argumenten und weiteren Argumenten
  5098.             if (args_on_stack<3) goto fehler_zuwenig;
  5099.             args_on_stack -= 3;
  5100.             goto apply_subr_rest_ok;
  5101.           case (uintW)subr_argtype_0_0_key:
  5102.             # SUBR mit Keyword-Argumenten
  5103.             if (args_on_stack==0) goto unbound_optional_key_0;
  5104.             else goto apply_subr_key;
  5105.           case (uintW)subr_argtype_1_0_key:
  5106.             # SUBR mit 1 required-Argument und Keyword-Argumenten
  5107.             if (args_on_stack==1) goto unbound_optional_key_0;
  5108.             elif (args_on_stack<1) goto fehler_zuwenig;
  5109.             else { args_on_stack -= 1; goto apply_subr_key; }
  5110.           case (uintW)subr_argtype_2_0_key:
  5111.             # SUBR mit 2 required-Argumenten und Keyword-Argumenten
  5112.             if (args_on_stack==2) goto unbound_optional_key_0;
  5113.             elif (args_on_stack<2) goto fehler_zuwenig;
  5114.             else { args_on_stack -= 2; goto apply_subr_key; }
  5115.           case (uintW)subr_argtype_3_0_key:
  5116.             # SUBR mit 3 required-Argumenten und Keyword-Argumenten
  5117.             if (args_on_stack==3) goto unbound_optional_key_0;
  5118.             elif (args_on_stack<3) goto fehler_zuwenig;
  5119.             else { args_on_stack -= 3; goto apply_subr_key; }
  5120.           case (uintW)subr_argtype_4_0_key:
  5121.             # SUBR mit 4 required-Argumenten und Keyword-Argumenten
  5122.             if (args_on_stack==4) goto unbound_optional_key_0;
  5123.             elif (args_on_stack<4) goto fehler_zuwenig;
  5124.             else { args_on_stack -= 4; goto apply_subr_key; }
  5125.           case (uintW)subr_argtype_0_1_key:
  5126.             # SUBR mit 1 optional-Argument und Keyword-Argumenten
  5127.             switch (args_on_stack)
  5128.               { case 0: goto unbound_optional_key_1;
  5129.                 case 1: goto unbound_optional_key_0;
  5130.                 default: args_on_stack -= 1; goto apply_subr_key;
  5131.               }
  5132.           case (uintW)subr_argtype_1_1_key:
  5133.             # SUBR mit 1 required-Argument, 1 optional-Argument und Keyword-Argumenten
  5134.             switch (args_on_stack)
  5135.               { case 0: goto fehler_zuwenig;
  5136.                 case 1: goto unbound_optional_key_1;
  5137.                 case 2: goto unbound_optional_key_0;
  5138.                 default: args_on_stack -= 2; goto apply_subr_key;
  5139.               }
  5140.           case (uintW)subr_argtype_1_2_key:
  5141.             # SUBR mit 1 required-Argument, 2 optional-Argumenten und Keyword-Argumenten
  5142.             switch (args_on_stack)
  5143.               { case 0: goto fehler_zuwenig;
  5144.                 case 1: goto unbound_optional_key_2;
  5145.                 case 2: goto unbound_optional_key_1;
  5146.                 case 3: goto unbound_optional_key_0;
  5147.                 default: args_on_stack -= 3; goto apply_subr_key;
  5148.               }
  5149.           unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0
  5150.             pushSTACK(unbound);
  5151.           unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0
  5152.             pushSTACK(unbound);
  5153.           unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0
  5154.             { var reg1 uintC count;
  5155.               dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
  5156.             }
  5157.             goto apply_subr_norest;
  5158.           default: NOTREACHED
  5159.           #undef OPT_ARG
  5160.           #undef REQ_ARG
  5161.         }
  5162.       # Nun die allgemeine Version:
  5163.      {var reg5 uintC req_anz = TheSubr(fun)->req_anz;
  5164.       var reg6 uintC opt_anz = TheSubr(fun)->opt_anz;
  5165.       var reg7 uintC key_anz = TheSubr(fun)->key_anz;
  5166.       if (args_on_stack < req_anz)
  5167.         # weniger Argumente da als verlangt
  5168.         goto fehler_zuwenig;
  5169.       args_on_stack -= req_anz; # verbleibende Anzahl
  5170.       if (args_on_stack <= opt_anz)
  5171.         # Argumente im Stack reichen nicht für die optionalen
  5172.         { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
  5173.           # Platz auf dem STACK reservieren:
  5174.           get_space_on_STACK(sizeof(object) * (uintL)(opt_anz + key_anz));
  5175.           # Alle weiteren count optionalen Parameter bekommen den "Wert"
  5176.           # #<UNBOUND>, auch die Keyword-Parameter:
  5177.           { var reg1 uintC count;
  5178.             dotimesC(count,opt_anz + key_anz, { pushSTACK(unbound); } );
  5179.             if (TheSubr(fun)->rest_flag == subr_rest) # &REST-Flag?
  5180.               # ja -> 0 zusätzliche Argumente:
  5181.               { argcount = 0; rest_args_pointer = args_end_pointer;
  5182.                 goto apply_subr_rest;
  5183.               }
  5184.               else
  5185.               # nein -> nichts zu tun
  5186.               { goto apply_subr_norest; }
  5187.         } }
  5188.       args_on_stack -= opt_anz; # verbleibende Anzahl (> 0)
  5189.       if (TheSubr(fun)->key_flag == subr_nokey)
  5190.         # SUBR ohne KEY
  5191.         { if (TheSubr(fun)->rest_flag == subr_norest)
  5192.             # SUBR ohne REST oder KEY
  5193.             { goto fehler_zuviel; } # noch Argumente!
  5194.             else
  5195.             # SUBR mit nur REST, ohne KEY
  5196.             apply_subr_rest_ok:
  5197.             { argcount = args_on_stack;
  5198.               rest_args_pointer = args_end_pointer STACKop argcount;
  5199.               goto apply_subr_rest;
  5200.             }
  5201.         }
  5202.         else
  5203.         # SUBR mit Keywords.
  5204.         { if (FALSE)
  5205.             apply_subr_key: { key_anz = TheSubr(fun)->key_anz; }
  5206.           # restliche Argumente im STACK nach unten schieben und dadurch
  5207.           # Platz für die Keyword-Parameter schaffen:
  5208.           argcount = args_on_stack; # (> 0)
  5209.           get_space_on_STACK(sizeof(object) * (uintL)key_anz);
  5210.           {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)key_anz;
  5211.            var reg1 object* ptr1 = args_end_pointer;
  5212.            var reg1 object* ptr2 = new_args_end_pointer;
  5213.            var reg1 uintC count;
  5214.            dotimespC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
  5215.            key_args_pointer = ptr1;
  5216.            rest_args_pointer = ptr2;
  5217.            dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
  5218.            set_args_end_pointer(new_args_end_pointer);
  5219.           }
  5220.           # Keywords zuordnen und evtl. restliche Argumente wegwerfen:
  5221.           match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
  5222.           if (TheSubr(fun)->rest_flag == subr_norest)
  5223.             # SUBR ohne &REST-Flag:
  5224.             apply_subr_norest:
  5225.             { subr_self = fun;
  5226.               (*(subr_norest_function*)(TheSubr(fun)->function))();
  5227.             }
  5228.             else
  5229.             # SUBR mit &REST-Flag:
  5230.             apply_subr_rest:
  5231.             { subr_self = fun;
  5232.               (*(subr_rest_function*)(TheSubr(fun)->function))
  5233.                (argcount,rest_args_pointer);
  5234.             }
  5235.      }  }
  5236.       #if STACKCHECKS
  5237.       if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
  5238.         { abort(); } # nein -> ab in den Debugger
  5239.       #endif
  5240.       return; # fertig
  5241.       # Gesammelte Fehlermeldungen:
  5242.       fehler_anzahl:
  5243.         if (args_on_stack < TheSubr(fun)->req_anz)
  5244.           { goto fehler_zuwenig; } # zu wenig Argumente
  5245.           else
  5246.           { goto fehler_zuviel; } # zu viele Argumente
  5247.       fehler_zuwenig: fehler_subr_zuwenig(fun);
  5248.       fehler_zuviel: fehler_subr_zuviel(fun);
  5249.     }
  5250.  
  5251. # In FUNCALL: Wendet eine Closure auf Argumente an, räumt den STACK auf
  5252. # und liefert die Werte.
  5253. # funcall_closure(fun,args_on_stack);
  5254. # > fun: Funktion, eine Closure
  5255. # > Argumente: args_on_stack Argumente auf dem STACK
  5256. # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
  5257. # < mv_count/mv_space: Werte
  5258. # verändert STACK, kann GC auslösen
  5259.   local Values funcall_closure(closure,args_on_stack)
  5260.     var reg5 object closure;
  5261.     var reg3 uintC args_on_stack;
  5262.     {
  5263.       #ifdef DEBUG_EVAL
  5264.       if (sym_streamp(S(funcall_trace_output)))
  5265.         { pushSTACK(closure); trace_call(closure,'F','C'); closure = popSTACK(); }
  5266.       #endif
  5267.       if (m_simple_bit_vector_p(TheClosure(closure)->clos_codevec))
  5268.         # closure ist eine compilierte Closure
  5269.         {
  5270.           #if STACKCHECKC
  5271.           var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
  5272.           #endif
  5273.           var reg4 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
  5274.           var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
  5275.           var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
  5276.           var reg8 uintL argcount; # Anzahl der restlichen Argumente
  5277.           check_SP(); check_STACK();
  5278.           # Argumente in den STACK legen:
  5279.           # erst ein Dispatch für die wichtigsten Fälle:
  5280.           switch (TheSbvector(codevec)->data[CCHD+5])
  5281.             { case (uintB)cclos_argtype_0_0:
  5282.                 # keine Argumente
  5283.                 if (!(args_on_stack==0)) goto fehler_zuviel;
  5284.                 goto apply_cclosure_nokey;
  5285.               case (uintB)cclos_argtype_1_0:
  5286.                 # 1 required-Argument
  5287.                 if (!(args_on_stack==1)) goto fehler_anzahl;
  5288.                 goto apply_cclosure_nokey;
  5289.               case (uintB)cclos_argtype_2_0:
  5290.                 # 2 required-Argumente
  5291.                 if (!(args_on_stack==2)) goto fehler_anzahl;
  5292.                 goto apply_cclosure_nokey;
  5293.               case (uintB)cclos_argtype_3_0:
  5294.                 # 3 required-Argumente
  5295.                 if (!(args_on_stack==3)) goto fehler_anzahl;
  5296.                 goto apply_cclosure_nokey;
  5297.               case (uintB)cclos_argtype_4_0:
  5298.                 # 4 required-Argumente
  5299.                 if (!(args_on_stack==4)) goto fehler_anzahl;
  5300.                 goto apply_cclosure_nokey;
  5301.               case (uintB)cclos_argtype_5_0:
  5302.                 # 5 required-Argumente
  5303.                 if (!(args_on_stack==5)) goto fehler_anzahl;
  5304.                 goto apply_cclosure_nokey;
  5305.               case (uintB)cclos_argtype_0_1:
  5306.                 # 1 optional-Argument
  5307.                 if (args_on_stack==1) goto apply_cclosure_nokey;
  5308.                 elif (args_on_stack>1) goto fehler_zuviel;
  5309.                 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
  5310.               case (uintB)cclos_argtype_1_1:
  5311.                 # 1 required-Argument und 1 optional-Argument
  5312.                 if (args_on_stack==2) goto apply_cclosure_nokey;
  5313.                 elif (args_on_stack>2) goto fehler_zuviel;
  5314.                 elif (args_on_stack==0) goto fehler_zuwenig;
  5315.                 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
  5316.               case (uintB)cclos_argtype_2_1:
  5317.                 # 2 required-Argumente und 1 optional-Argument
  5318.                 if (args_on_stack==3) goto apply_cclosure_nokey;
  5319.                 elif (args_on_stack>3) goto fehler_zuviel;
  5320.                 elif (args_on_stack<2) goto fehler_zuwenig;
  5321.                 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
  5322.               case (uintB)cclos_argtype_3_1:
  5323.                 # 3 required-Argumente und 1 optional-Argument
  5324.                 if (args_on_stack==4) goto apply_cclosure_nokey;
  5325.                 elif (args_on_stack>4) goto fehler_zuviel;
  5326.                 elif (args_on_stack<3) goto fehler_zuwenig;
  5327.                 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
  5328.               case (uintB)cclos_argtype_4_1:
  5329.                 # 4 required-Argumente und 1 optional-Argument
  5330.                 if (args_on_stack==5) goto apply_cclosure_nokey;
  5331.                 elif (args_on_stack>5) goto fehler_zuviel;
  5332.                 elif (args_on_stack<4) goto fehler_zuwenig;
  5333.                 else { pushSTACK(unbound); goto apply_cclosure_nokey; }
  5334.               case (uintB)cclos_argtype_0_2:
  5335.                 # 2 optional-Argumente
  5336.                 switch (args_on_stack)
  5337.                   { case 0: pushSTACK(unbound);
  5338.                     case 1: pushSTACK(unbound);
  5339.                     case 2: goto apply_cclosure_nokey;
  5340.                     default: goto fehler_zuviel;
  5341.                   }
  5342.               case (uintB)cclos_argtype_1_2:
  5343.                 # 1 required-Argument und 2 optional-Argumente
  5344.                 switch (args_on_stack)
  5345.                   { case 0: goto fehler_zuwenig;
  5346.                     case 1: pushSTACK(unbound);
  5347.                     case 2: pushSTACK(unbound);
  5348.                     case 3: goto apply_cclosure_nokey;
  5349.                     default: goto fehler_zuviel;
  5350.                   }
  5351.               case (uintB)cclos_argtype_2_2:
  5352.                 # 2 required-Argumente und 2 optional-Argumente
  5353.                 switch (args_on_stack)
  5354.                   { case 0: case 1: goto fehler_zuwenig;
  5355.                     case 2: pushSTACK(unbound);
  5356.                     case 3: pushSTACK(unbound);
  5357.                     case 4: goto apply_cclosure_nokey;
  5358.                     default: goto fehler_zuviel;
  5359.                   }
  5360.               case (uintB)cclos_argtype_3_2:
  5361.                 # 3 required-Argumente und 2 optional-Argumente
  5362.                 switch (args_on_stack)
  5363.                   { case 0: case 1: case 2: goto fehler_zuwenig;
  5364.                     case 3: pushSTACK(unbound);
  5365.                     case 4: pushSTACK(unbound);
  5366.                     case 5: goto apply_cclosure_nokey;
  5367.                     default: goto fehler_zuviel;
  5368.                   }
  5369.               case (uintB)cclos_argtype_0_3:
  5370.                 # 3 optional-Argumente
  5371.                 switch (args_on_stack)
  5372.                   { case 0: pushSTACK(unbound);
  5373.                     case 1: pushSTACK(unbound);
  5374.                     case 2: pushSTACK(unbound);
  5375.                     case 3: goto apply_cclosure_nokey;
  5376.                     default: goto fehler_zuviel;
  5377.                   }
  5378.               case (uintB)cclos_argtype_1_3:
  5379.                 # 1 required-Argument und 3 optional-Argumente
  5380.                 switch (args_on_stack)
  5381.                   { case 0: goto fehler_zuwenig;
  5382.                     case 1: pushSTACK(unbound);
  5383.                     case 2: pushSTACK(unbound);
  5384.                     case 3: pushSTACK(unbound);
  5385.                     case 4: goto apply_cclosure_nokey;
  5386.                     default: goto fehler_zuviel;
  5387.                   }
  5388.               case (uintB)cclos_argtype_2_3:
  5389.                 # 2 required-Argumente und 3 optional-Argumente
  5390.                 switch (args_on_stack)
  5391.                   { case 0: case 1: goto fehler_zuwenig;
  5392.                     case 2: pushSTACK(unbound);
  5393.                     case 3: pushSTACK(unbound);
  5394.                     case 4: pushSTACK(unbound);
  5395.                     case 5: goto apply_cclosure_nokey;
  5396.                     default: goto fehler_zuviel;
  5397.                   }
  5398.               case (uintB)cclos_argtype_0_4:
  5399.                 # 4 optional-Argumente
  5400.                 switch (args_on_stack)
  5401.                   { case 0: pushSTACK(unbound);
  5402.                     case 1: pushSTACK(unbound);
  5403.                     case 2: pushSTACK(unbound);
  5404.                     case 3: pushSTACK(unbound);
  5405.                     case 4: goto apply_cclosure_nokey;
  5406.                     default: goto fehler_zuviel;
  5407.                   }
  5408.               case (uintB)cclos_argtype_1_4:
  5409.                 # 1 required-Argument und 4 optional-Argumente
  5410.                 switch (args_on_stack)
  5411.                   { case 0: goto fehler_zuwenig;
  5412.                     case 1: pushSTACK(unbound);
  5413.                     case 2: pushSTACK(unbound);
  5414.                     case 3: pushSTACK(unbound);
  5415.                     case 4: pushSTACK(unbound);
  5416.                     case 5: goto apply_cclosure_nokey;
  5417.                     default: goto fehler_zuviel;
  5418.                   }
  5419.               case (uintB)cclos_argtype_0_5:
  5420.                 # 5 optional-Argumente
  5421.                 switch (args_on_stack)
  5422.                   { case 0: pushSTACK(unbound);
  5423.                     case 1: pushSTACK(unbound);
  5424.                     case 2: pushSTACK(unbound);
  5425.                     case 3: pushSTACK(unbound);
  5426.                     case 4: pushSTACK(unbound);
  5427.                     case 5: goto apply_cclosure_nokey;
  5428.                     default: goto fehler_zuviel;
  5429.                   }
  5430.               case (uintB)cclos_argtype_0_0_rest:
  5431.                 # keine Argumente, Rest-Parameter
  5432.                 goto apply_cclosure_rest_nokey;
  5433.               case (uintB)cclos_argtype_1_0_rest:
  5434.                 # 1 required-Argument, Rest-Parameter
  5435.                 if (args_on_stack==0) goto fehler_zuwenig;
  5436.                 args_on_stack -= 1;
  5437.                 goto apply_cclosure_rest_nokey;
  5438.               case (uintB)cclos_argtype_2_0_rest:
  5439.                 # 2 required-Argumente, Rest-Parameter
  5440.                 if (args_on_stack<2) goto fehler_zuwenig;
  5441.                 args_on_stack -= 2;
  5442.                 goto apply_cclosure_rest_nokey;
  5443.               case (uintB)cclos_argtype_3_0_rest:
  5444.                 # 3 required-Argumente, Rest-Parameter
  5445.                 if (args_on_stack<3) goto fehler_zuwenig;
  5446.                 args_on_stack -= 3;
  5447.                 goto apply_cclosure_rest_nokey;
  5448.               case (uintB)cclos_argtype_4_0_rest:
  5449.                 # 4 required-Argumente, Rest-Parameter
  5450.                 if (args_on_stack<4) goto fehler_zuwenig;
  5451.                 args_on_stack -= 4;
  5452.                 goto apply_cclosure_rest_nokey;
  5453.               case (uintB)cclos_argtype_0_0_key:
  5454.                 # nur Keyword-Argumente
  5455.                 if (args_on_stack==0) goto unbound_optional_key_0;
  5456.                 else goto apply_cclosure_key_withargs;
  5457.               case (uintB)cclos_argtype_1_0_key:
  5458.                 # 1 required-Argument, Keyword-Argumente
  5459.                 if (args_on_stack==1) goto unbound_optional_key_0;
  5460.                 elif (args_on_stack<1) goto fehler_zuwenig;
  5461.                 else { args_on_stack -= 1; goto apply_cclosure_key_withargs; }
  5462.               case (uintB)cclos_argtype_2_0_key:
  5463.                 # 2 required-Argumente, Keyword-Argumente
  5464.                 if (args_on_stack==2) goto unbound_optional_key_0;
  5465.                 elif (args_on_stack<2) goto fehler_zuwenig;
  5466.                 else { args_on_stack -= 2; goto apply_cclosure_key_withargs; }
  5467.               case (uintB)cclos_argtype_3_0_key:
  5468.                 # 3 required-Argumente, Keyword-Argumente
  5469.                 if (args_on_stack==3) goto unbound_optional_key_0;
  5470.                 elif (args_on_stack<3) goto fehler_zuwenig;
  5471.                 else { args_on_stack -= 3; goto apply_cclosure_key_withargs; }
  5472.               case (uintB)cclos_argtype_4_0_key:
  5473.                 # 4 required-Argumente, Keyword-Argumente
  5474.                 if (args_on_stack==4) goto unbound_optional_key_0;
  5475.                 elif (args_on_stack<4) goto fehler_zuwenig;
  5476.                 else { args_on_stack -= 4; goto apply_cclosure_key_withargs; }
  5477.               case (uintB)cclos_argtype_0_1_key:
  5478.                 # 1 optional-Argument, Keyword-Argumente
  5479.                 switch (args_on_stack)
  5480.                   { case 0: goto unbound_optional_key_1;
  5481.                     case 1: goto unbound_optional_key_0;
  5482.                     default: args_on_stack -= 1; goto apply_cclosure_key_withargs;
  5483.                   }
  5484.               case (uintB)cclos_argtype_1_1_key:
  5485.                 # 1 required-Argument und 1 optional-Argument, Keyword-Argumente
  5486.                 switch (args_on_stack)
  5487.                   { case 0: goto fehler_zuwenig;
  5488.                     case 1: goto unbound_optional_key_1;
  5489.                     case 2: goto unbound_optional_key_0;
  5490.                     default: args_on_stack -= 2; goto apply_cclosure_key_withargs;
  5491.                   }
  5492.               case (uintB)cclos_argtype_2_1_key:
  5493.                 # 2 required-Argumente und 1 optional-Argument, Keyword-Argumente
  5494.                 switch (args_on_stack)
  5495.                   { case 0: case 1: goto fehler_zuwenig;
  5496.                     case 2: goto unbound_optional_key_1;
  5497.                     case 3: goto unbound_optional_key_0;
  5498.                     default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
  5499.                   }
  5500.               case (uintB)cclos_argtype_3_1_key:
  5501.                 # 3 required-Argumente und 1 optional-Argument, Keyword-Argumente
  5502.                 switch (args_on_stack)
  5503.                   { case 0: case 1: case 2: goto fehler_zuwenig;
  5504.                     case 3: goto unbound_optional_key_1;
  5505.                     case 4: goto unbound_optional_key_0;
  5506.                     default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
  5507.                   }
  5508.               case (uintB)cclos_argtype_0_2_key:
  5509.                 # 2 optional-Argumente, Keyword-Argumente
  5510.                 switch (args_on_stack)
  5511.                   { case 0: goto unbound_optional_key_2;
  5512.                     case 1: goto unbound_optional_key_1;
  5513.                     case 2: goto unbound_optional_key_0;
  5514.                     default: args_on_stack -= 2; goto apply_cclosure_key_withargs;
  5515.                   }
  5516.               case (uintB)cclos_argtype_1_2_key:
  5517.                 # 1 required-Argument und 2 optional-Argumente, Keyword-Argumente
  5518.                 switch (args_on_stack)
  5519.                   { case 0: goto fehler_zuwenig;
  5520.                     case 1: goto unbound_optional_key_2;
  5521.                     case 2: goto unbound_optional_key_1;
  5522.                     case 3: goto unbound_optional_key_0;
  5523.                     default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
  5524.                   }
  5525.               case (uintB)cclos_argtype_2_2_key:
  5526.                 # 2 required-Argumente und 2 optional-Argumente, Keyword-Argumente
  5527.                 switch (args_on_stack)
  5528.                   { case 0: case 1: goto fehler_zuwenig;
  5529.                     case 2: goto unbound_optional_key_2;
  5530.                     case 3: goto unbound_optional_key_1;
  5531.                     case 4: goto unbound_optional_key_0;
  5532.                     default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
  5533.                   }
  5534.               case (uintB)cclos_argtype_0_3_key:
  5535.                 # 3 optional-Argumente, Keyword-Argumente
  5536.                 switch (args_on_stack)
  5537.                   { case 0: goto unbound_optional_key_3;
  5538.                     case 1: goto unbound_optional_key_2;
  5539.                     case 2: goto unbound_optional_key_1;
  5540.                     case 3: goto unbound_optional_key_0;
  5541.                     default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
  5542.                   }
  5543.               case (uintB)cclos_argtype_1_3_key:
  5544.                 # 1 required-Argument und 3 optional-Argumente, Keyword-Argumente
  5545.                 switch (args_on_stack)
  5546.                   { case 0: goto fehler_zuwenig;
  5547.                     case 1: goto unbound_optional_key_3;
  5548.                     case 2: goto unbound_optional_key_2;
  5549.                     case 3: goto unbound_optional_key_1;
  5550.                     case 4: goto unbound_optional_key_0;
  5551.                     default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
  5552.                   }
  5553.               case (uintB)cclos_argtype_0_4_key:
  5554.                 # 4 optional-Argumente, Keyword-Argumente
  5555.                 switch (args_on_stack)
  5556.                   { case 0: goto unbound_optional_key_4;
  5557.                     case 1: goto unbound_optional_key_3;
  5558.                     case 2: goto unbound_optional_key_2;
  5559.                     case 3: goto unbound_optional_key_1;
  5560.                     case 4: goto unbound_optional_key_0;
  5561.                     default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
  5562.                   }
  5563.               unbound_optional_key_4: # Noch 4 optionale Argumente, aber args_on_stack=0
  5564.                 pushSTACK(unbound);
  5565.               unbound_optional_key_3: # Noch 3 optionale Argumente, aber args_on_stack=0
  5566.                 pushSTACK(unbound);
  5567.               unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0
  5568.                 pushSTACK(unbound);
  5569.               unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0
  5570.                 pushSTACK(unbound);
  5571.               unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0
  5572.                 goto apply_cclosure_key_noargs;
  5573.               case (uintB)cclos_argtype_default:
  5574.                 # Allgemeine Version
  5575.                 break;
  5576.               default: NOTREACHED
  5577.             }
  5578.           # Nun die allgemeine Version:
  5579.          {var reg5 uintC req_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]); # Anzahl required Parameter
  5580.           var reg6 uintC opt_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+2]); # Anzahl optionale Parameter
  5581.           var reg7 uintB flags = TheSbvector(codevec)->data[CCHD+4]; # Flags
  5582.           if (args_on_stack < req_anz)
  5583.             # weniger Argumente da als verlangt
  5584.             { goto fehler_zuwenig; }
  5585.           args_on_stack -= req_anz; # verbleibende Anzahl
  5586.           if (args_on_stack <= opt_anz)
  5587.             # Argumente im Stack reichen nicht für die optionalen
  5588.             { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
  5589.               # Platz auf dem STACK reservieren:
  5590.               get_space_on_STACK(sizeof(object) * (uintL)opt_anz);
  5591.               # Alle weiteren count optionalen Parameter bekommen den "Wert"
  5592.               # #<UNBOUND>, der &REST-Parameter den Wert NIL,
  5593.               # die Keyword-Parameter den Wert #<UNBOUND> :
  5594.               { var reg1 uintC count;
  5595.                 dotimesC(count,opt_anz, { pushSTACK(unbound); } );
  5596.               }
  5597.               if (flags & bit(0)) # &REST-Flag?
  5598.                 { pushSTACK(NIL); } # ja -> mit NIL initialisieren
  5599.               if (flags & bit(7)) # &KEY-Flag?
  5600.                 apply_cclosure_key_noargs:
  5601.                 { var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
  5602.                   get_space_on_STACK(sizeof(object) * (uintL)key_anz);
  5603.                   {var reg1 uintC count;
  5604.                    dotimesC(count,key_anz, { pushSTACK(unbound); } ); # mit #<UNBOUND> initialisieren
  5605.                   }
  5606.                   goto apply_cclosure_key;
  5607.                 }
  5608.                 else
  5609.                 goto apply_cclosure_nokey;
  5610.             }
  5611.           args_on_stack -= opt_anz; # verbleibende Anzahl
  5612.           if (flags & bit(7)) # Key-Flag?
  5613.             { if (FALSE)
  5614.                 apply_cclosure_key_withargs:
  5615.                 { flags = TheSbvector(codevec)->data[CCHD+4]; } # Flags initialisieren!
  5616.             # Closure mit Keywords
  5617.              {var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
  5618.               # restliche Argumente im STACK nach unten schieben und dadurch
  5619.               # Platz für die Keyword-Parameter (und evtl. Rest-Parameter)
  5620.               # schaffen:
  5621.               var reg1 uintL shift = key_anz;
  5622.               if (flags & bit(0)) { shift++; } # evtl. 1 mehr für Rest-Parameter
  5623.               argcount = args_on_stack;
  5624.               get_space_on_STACK(sizeof(object) * shift);
  5625.               {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)shift;
  5626.                var reg1 object* ptr1 = args_end_pointer;
  5627.                var reg1 object* ptr2 = new_args_end_pointer;
  5628.                var reg1 uintC count;
  5629.                dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
  5630.                if (flags & bit(0)) { NEXT(ptr1) = unbound; } # Rest-Parameter
  5631.                key_args_pointer = ptr1;
  5632.                rest_args_pointer = ptr2;
  5633.                dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
  5634.                set_args_end_pointer(new_args_end_pointer);
  5635.               }
  5636.               # Keywords zuordnen, Rest-Parameter bauen
  5637.               # und evtl. restliche Argumente wegwerfen:
  5638.               closure = match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer);
  5639.               codevec = TheCclosure(closure)->clos_codevec;
  5640.               apply_cclosure_key:
  5641.               interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
  5642.             }}
  5643.           elif (flags & bit(0))
  5644.             apply_cclosure_rest_nokey:
  5645.             # Closure mit nur REST, ohne KEY:
  5646.             { # muß noch args_on_stack Argumente aus dem Stack zusammenconsen:
  5647.               pushSTACK(NIL);
  5648.               pushSTACK(closure); # Closure muß gerettet werden
  5649.               dotimesC(args_on_stack,args_on_stack,
  5650.                 { var reg1 object new_cons = allocate_cons();
  5651.                   Cdr(new_cons) = STACK_1;
  5652.                   Car(new_cons) = STACK_2; # nächstes Argument draufconsen
  5653.                   STACK_2 = new_cons;
  5654.                   STACK_1 = STACK_0; skipSTACK(1);
  5655.                 });
  5656.               closure = popSTACK(); codevec = TheCclosure(closure)->clos_codevec;
  5657.               goto apply_cclosure_nokey;
  5658.             }
  5659.           else
  5660.             # Closure ohne REST oder KEY
  5661.             { if (args_on_stack>0) # noch Argumente?
  5662.                 goto fehler_zuviel;
  5663.               apply_cclosure_nokey: # Closure ohne &KEY anspringen:
  5664.               interpret_bytecode(closure,codevec,CCHD+6); # Bytecode ab Byte 6 abinterpretieren
  5665.             }
  5666.          }
  5667.           #if STACKCHECKC
  5668.           if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
  5669.             { abort(); } # nein -> ab in den Debugger
  5670.           #endif
  5671.           return; # fertig
  5672.           # Gesammelte Fehlermeldungen:
  5673.           fehler_anzahl:
  5674.             if (args_on_stack < *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]))
  5675.               { goto fehler_zuwenig; } # zu wenig Argumente
  5676.               else
  5677.               { goto fehler_zuviel; } # zu viele Argumente
  5678.           fehler_zuwenig: fehler_closure_zuwenig(closure);
  5679.           fehler_zuviel: fehler_closure_zuviel(closure);
  5680.         }
  5681.         else
  5682.         # closure ist eine interpretierte Closure
  5683.         { funcall_iclosure(closure,args_end_pointer STACKop args_on_stack,args_on_stack); }
  5684.     }
  5685.  
  5686.  
  5687. #      ---------------------- BYTECODE-INTERPRETER ----------------------
  5688.  
  5689. # Interpretiert den Bytecode einer compilierten Closure.
  5690. # interpret_bytecode_(closure,codeptr,byteptr);
  5691. # > closure: compilierte Closure
  5692. # > codeptr: ihr Codevektor, ein Simple-Bit-Vector, pointable
  5693. # > byteptr: Start-Bytecodepointer
  5694. # < mv_count/mv_space: Werte
  5695. # verändert STACK, kann GC auslösen
  5696.   # Syntax lokaler Labels in GNU-C Assembler-Anweisungen:
  5697.   #if defined(GNU) && !defined(NO_ASM)
  5698.     # LD(x) definiert Label mit Nummer x
  5699.     # LR(x,f) referenziert Label mit Nummer x vorwärts
  5700.     # LR(x,b) referenziert Label mit Nummer x rückwärts
  5701.     # Der Sichtbarkeitsbereich der Labels ist nur die eine Assembler-Anweisung.
  5702.     #if defined(I80Z86) && !defined(UNIX_NEXTSTEP)
  5703.       #define LD(nr)  CONCAT("LASM%=X",STRING(nr))
  5704.       #define LR(nr,fb)  CONCAT("LASM%=X",STRING(nr))
  5705.     #else
  5706.       #define LD(nr)  STRING(nr)
  5707.       #define LR(nr,fb)  CONCAT(STRING(nr),STRING(fb))
  5708.     #endif
  5709.   #endif
  5710.   # Den GNU-C dazu überreden, closure und byteptr in Registern zu halten:
  5711.   #ifdef GNU
  5712.     #ifdef MC680X0
  5713.       #define closure_register  "a2"
  5714.       #define byteptr_register  "a3"
  5715.     #endif
  5716.     #ifdef SPARC
  5717.       #define closure_register  "%l0"
  5718.       #define byteptr_register  "%l1"
  5719.     #endif
  5720.     #ifdef I80Z86
  5721.       #if (__GNUC__ >= 2) # Die Namen der Register haben sich verändert
  5722.         #define byteptr_register  "%edi"
  5723.       #else
  5724.         #define byteptr_register  "di"
  5725.       #endif
  5726.     #endif
  5727.     #ifdef CONVEX
  5728.       #define closure_register "a5"
  5729.       #define byteptr_register "a4"
  5730.     #endif
  5731.     #ifdef DECALPHA
  5732.       #define byteptr_register  "$14"
  5733.     #endif
  5734.     #ifdef WIDE_SOFT
  5735.       # Ein `object' paßt nicht in ein einzelnes Register, GCC ist überfordert.
  5736.       #undef closure_register
  5737.     #endif
  5738.   #endif
  5739.   #ifndef closure_register
  5740.     #define closure_in  closure
  5741.   #endif
  5742.   #ifndef byteptr_register
  5743.     #define byteptr_in  byteptr
  5744.   #endif
  5745.   local Values interpret_bytecode_(closure_in,codeptr,byteptr_in)
  5746.     var reg3 object closure_in;
  5747.     var reg8 Sbvector codeptr;
  5748.     var reg1 uintB* byteptr_in;
  5749.     { # Argument closure im Register unterbringen:
  5750.       #ifdef closure_register
  5751.       var reg3 object closure __asm__(closure_register);
  5752.       closure = closure_in;
  5753.       #endif
  5754.      {# Argument byteptr im Register unterbringen:
  5755.       #ifdef byteptr_register
  5756.       var reg1 uintB* byteptr __asm__(byteptr_register);
  5757.       byteptr = byteptr_in;
  5758.       #endif
  5759.       #ifdef DEBUG_EVAL
  5760.       if (sym_streamp(S(funcall_trace_output)))
  5761.         { pushSTACK(closure); trace_call(closure,'B','C'); closure = popSTACK(); }
  5762.       #endif
  5763.       {# Closure im STACK unterbringen, unter die Argumente:
  5764.        var reg5 object* closureptr = (pushSTACK(closure), &STACK_0);
  5765.        #ifndef FAST_SP
  5766.          # Hat man keinen schnellen SP-Zugriff, muß man einen extra Pointer
  5767.          # einführen:
  5768.          var reg10 uintL private_SP_length = (uintL)(*(uintW*)(&codeptr->data[0]));
  5769.          var DYNAMIC_ARRAY(_EMA_,private_SP_space,SPint,private_SP_length);
  5770.          var reg6 SPint* private_SP = &private_SP_space[private_SP_length];
  5771.          #undef SP_
  5772.          #undef _SP_
  5773.          #undef skipSP
  5774.          #undef pushSP
  5775.          #undef popSP
  5776.          #define SP_(n)  (private_SP[n])
  5777.          #define _SP_(n)  &SP_(n)
  5778.          #define skipSP(n)  (private_SP += (n))
  5779.          #define pushSP(item)  (*--private_SP = (item))
  5780.          #define popSP(item_zuweisung)  (item_zuweisung *private_SP++)
  5781.        #endif
  5782.        # var JMPBUF_on_SP(name);  alloziert einen jmp_buf im SP.
  5783.        # FREE_JMPBUF_on_SP();  dealloziert ihn wieder.
  5784.        # finish_entry_frame_1(frametype,returner,reentry_statement);  ist wie
  5785.        # finish_entry_frame(frametype,returner,_EMA_,reentry_statement);  nur daß
  5786.        # auch private_SP gerettet wird.
  5787.        #ifndef FAST_SP
  5788.          #define JMPBUF_on_SP(name)  \
  5789.            jmp_buf* name = (jmp_buf*)(private_SP -= jmpbufsize);
  5790.          #define FREE_JMPBUF_on_SP()  \
  5791.            private_SP += jmpbufsize;
  5792.          #define finish_entry_frame_1(frametype,returner,reentry_statement)  \
  5793.            finish_entry_frame(frametype,&!*returner, # Beim Eintritt: returner = private_SP      \
  5794.              returner = (jmp_buf*) , # returner wird beim Rücksprung wieder gesetzt              \
  5795.              { private_SP = (SPint*)returner; reentry_statement } # und private_SP rekonstruiert \
  5796.              )
  5797.        #else
  5798.          #ifdef SP_DOWN
  5799.            #define JMPBUF_on_SP(name)  \
  5800.              jmp_buf* name;                      \
  5801.              {var reg1 SPint* sp = (SPint*)SP(); \
  5802.               sp -= jmpbufsize;                  \
  5803.               setSP(sp);                         \
  5804.               name = (jmp_buf*)&sp[SPoffset];    \
  5805.              }
  5806.          #endif
  5807.          #ifdef SP_UP
  5808.            #define JMPBUF_on_SP(name)  \
  5809.              jmp_buf* name;                      \
  5810.              {var reg1 SPint* sp = (SPint*)SP(); \
  5811.               name = (jmp_buf*)&sp[SPoffset+1];  \
  5812.               sp += jmpbufsize;                  \
  5813.               setSP(sp);                         \
  5814.              }
  5815.          #endif
  5816.          #define FREE_JMPBUF_on_SP()  \
  5817.            skipSP(jmpbufsize);
  5818.          #define finish_entry_frame_1(frametype,returner,reentry_statement)  \
  5819.            finish_entry_frame(frametype,&!*returner,_EMA_,reentry_statement)
  5820.        #endif
  5821.        #
  5822.        #ifdef FAST_DISPATCH
  5823.          static void* cod_labels[] = {
  5824.                                        #define BYTECODE(code)  &&code,
  5825.                                        #include "bytecode.c"
  5826.                                        #undef BYTECODE
  5827.                                      };
  5828.        #endif
  5829.        #
  5830.        # nächstes Byte abzuinterpretieren
  5831.        # > mv_count/mv_space: aktuelle Werte
  5832.        # > closureptr: Pointer auf die compilierte Closure im Stack
  5833.        # > closure: compilierte Closure
  5834.        # > codeptr: ihr Codevektor, ein Simple-Bit-Vektor, pointable
  5835.        #            (kein LISP-Objekt, aber dennoch GC-gefährdet!)
  5836.        # > byteptr: Pointer auf das nächste Byte im Code
  5837.        #            (kein LISP-Objekt, aber dennoch GC-gefährdet!)
  5838.        next_byte:
  5839.         # Fallunterscheidung nach abzuinterpretierendem Byte
  5840.         #ifndef FAST_DISPATCH
  5841.          switch (*byteptr++)
  5842.          #define CASE  case (uintB)
  5843.         #else # FAST_DISPATCH
  5844.          # Das ist etwa 2% schneller, weil die Index-Überprüfung entfällt.
  5845.          goto *cod_labels[*byteptr++];
  5846.          #define CASE
  5847.          #ifdef FAST_DISPATCH_THREADED
  5848.           # Die Sprunganweisung  goto next_byte;  kann man sich auch sparen:
  5849.           #define next_byte  *cod_labels[*byteptr++]
  5850.          #endif
  5851.         #endif
  5852.           { # Holen der Operanden:
  5853.             #   nächstes Byte:
  5854.             #     Bit 7 = 0 --> Bits 6..0 sind der Operand (7 Bits).
  5855.             #     Bit 7 = 1 --> Bits 6..0 und nächstes Byte bilden den
  5856.             #                   Operanden (15 Bits).
  5857.             #                   Bei Sprungdistanzen: Sollte dieser =0 sein, so
  5858.             #                   bilden die nächsten 4 Bytes den Operanden
  5859.             #                   (32 Bits).
  5860.             #
  5861.             # Macro B_operand(where);
  5862.             # bringt den nächsten Operanden (ein Byte als Unsigned Integer)
  5863.             # nach (uintL)where und rückt dabei den Bytecodepointer weiter.
  5864.               #define B_operand(where)  \
  5865.                 { where = *byteptr++; }
  5866.             #
  5867.             # Macro U_operand(where);
  5868.             # bringt den nächsten Operanden (ein Unsigned Integer)
  5869.             # nach (uintL)where oder (uintC)where
  5870.             # und rückt dabei den Bytecodepointer weiter.
  5871.               #define U_operand(where)  \
  5872.                 { where = *byteptr++; # erstes Byte lesen            \
  5873.                   if ((uintB)where & bit(7)) # Bit 7 gesetzt?        \
  5874.                     { where &= ~bit(7); # ja -> löschen              \
  5875.                       where = where << 8;                            \
  5876.                       where |= *byteptr++; # und nächstes Byte lesen \
  5877.                 }   }
  5878.             #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
  5879.               #undef U_operand
  5880.               #define U_operand(where)  \
  5881.                 __asm__("\
  5882.                   moveq #0,%0   ; \
  5883.                   moveb %1@+,%0 ; \
  5884.                   bpl 1f        ; \
  5885.                   addb %0,%0    ; \
  5886.                   lslw #7,%0    ; \
  5887.                   moveb %1@+,%0 ; \
  5888.                   1:              \
  5889.                   " : "=d" (where), "=a" (byteptr) : "1" (byteptr) )
  5890.             #endif
  5891.             #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
  5892.               #undef U_operand
  5893.               #define U_operand(where)  \
  5894.                 { var reg1 uintL dummy;  \
  5895.                   __asm__("\
  5896.                     ldub [%1],%0       ; \
  5897.                     andcc %0,0x80,%%g0 ; \
  5898.                     be 1f              ; \
  5899.                      add %1,1,%1       ; \
  5900.                     sll %0,25,%2       ; \
  5901.                     ldub [%1],%0       ; \
  5902.                     srl %2,17,%2       ; \
  5903.                     add %1,1,%1        ; \
  5904.                     or %0,%2,%0        ; \
  5905.                     1:                   \
  5906.                     " : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
  5907.                 }
  5908.             #endif
  5909.             #if defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  5910.               # Bei manchen Assemblern muß das Ergebnis in %eax liegen:
  5911.               #if !defined(SUN386) && !defined(UHC) && !defined(UNIX_SINIX)
  5912.                 # GNU-Assembler: in beliebigem Register.
  5913.                 # "testb %edx,%edx" wird als "testb %dl,%dl" assembliert.
  5914.                 #define OUT_EAX  "=q"
  5915.                 #define EAX      "%0"
  5916.                 #define AL       "%0"
  5917.               #else
  5918.                 # sonstiger Assembler: in %eax. "testb %edx,%edx" ist illegal.
  5919.                 #define OUT_EAX  "=a"
  5920.                 #define EAX      "%%eax"
  5921.                 #define AL       "%%al"
  5922.               #endif
  5923.               #undef U_operand
  5924.               #define U_operand(where)  \
  5925.                 __asm__("\
  5926.                   movzbl (%1),"EAX" ; \
  5927.                   incl %1           ; \
  5928.                   testb "AL","AL"   ; \
  5929.                   jge "LR(1,f)"     ; \
  5930.                   andb $127,"AL"    ; \
  5931.                   sall $8,"EAX"     ; \
  5932.                   movb (%1),"AL"    ; \
  5933.                   incl %1           ; \
  5934.                   "LD(1)":            \
  5935.                   " : OUT_EAX (where), "=r" (byteptr) : "1" (byteptr) );
  5936.               # Vorsicht: 1. Der Sun-Assembler kennt diese Syntax für lokale Labels nicht.
  5937.               #              Daher generieren wir unsere lokalen Labels selbst.
  5938.               # Vorsicht: 2. ccr wird verändert. Wie deklariert man das??
  5939.             #endif
  5940.             #
  5941.             # Macro S_operand(where);
  5942.             # bringt den nächsten Operanden (ein Signed Integer)
  5943.             # nach (uintL)where und rückt dabei den Bytecodepointer weiter.
  5944.               #define S_operand(where)  \
  5945.                 { where = *byteptr++; # erstes Byte lesen              \
  5946.                   if ((uintB)where & bit(7))                           \
  5947.                     # Bit 7 war gesetzt                                \
  5948.                     { where = where << 8;                              \
  5949.                       where |= *byteptr++; # nächstes Byte dazunehmen  \
  5950.                       # Sign-Extend von 15 auf 32 Bits:                \
  5951.                       where = (sintL)((sintL)(sintWL)((sintWL)where << (intWLsize-15)) >> (intWLsize-15)); \
  5952.                       if (where == 0)                                  \
  5953.                         # Sonderfall: 2-Byte-Operand = 0 -> 6-Byte-Operand \
  5954.                         { where = (uintL)( ((uintWL)(byteptr[0]) << 8) \
  5955.                                           | (uintWL)(byteptr[1])       \
  5956.                                          ) << 16                       \
  5957.                                 | (uintL)( ((uintWL)(byteptr[2]) << 8) \
  5958.                                           | (uintWL)(byteptr[3])       \
  5959.                                          );                            \
  5960.                           byteptr += 4;                                \
  5961.                     }   }                                              \
  5962.                     else                                               \
  5963.                     # Bit 7 war gelöscht                               \
  5964.                     { # Sign-Extend von 7 auf 32 Bits:                 \
  5965.                       where = (sintL)((sintL)(sintBWL)((sintBWL)where << (intBWLsize-7)) >> (intBWLsize-7)); \
  5966.                     }                                                  \
  5967.                 }
  5968.             #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
  5969.               #undef S_operand
  5970.               #define S_operand(where)  \
  5971.                 __asm__("\
  5972.                   moveb %1@+,%0   ; \
  5973.                   bpl 1f          ; \
  5974.                   lslw #8,%0      ; \
  5975.                   moveb %1@+,%0   ; \
  5976.                   addw %0,%0      ; \
  5977.                   asrw #1,%0      ; \
  5978.                   bne 2f          ; \
  5979.                   moveb %1@(2),%0 ; \
  5980.                   swap %0         ; \
  5981.                   moveb %1@+,%0   ; \
  5982.                   lsll #8,%0      ; \
  5983.                   moveb %1@,%0    ; \
  5984.                   swap %0         ; \
  5985.                   addql #2,%0     ; \
  5986.                   moveb %1@+,%0   ; \
  5987.                   jra 3f          ; \
  5988.                   1:                \
  5989.                   addb %0,%0      ; \
  5990.                   asrb #1,%0      ; \
  5991.                   extw %0         ; \
  5992.                   2:                \
  5993.                   extl %0         ; \
  5994.                   3:                \
  5995.                   " : "=d" (where), "=a" (byteptr) : "1" (byteptr) )
  5996.             #endif
  5997.             #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
  5998.               #undef S_operand
  5999.               #define S_operand(where)  \
  6000.                 { var reg1 uintL dummy;  \
  6001.                   __asm__("\
  6002.                     ldub [%1],%0       ; \
  6003.                     andcc %0,0x80,%%g0 ; \
  6004.                     be 2f              ; \
  6005.                      add %1,1,%1       ; \
  6006.                     sll %0,25,%2       ; \
  6007.                     ldub [%1],%0       ; \
  6008.                     sra %2,17,%2       ; \
  6009.                     orcc %2,%0,%0      ; \
  6010.                     bne 3f             ; \
  6011.                      add %1,1,%1       ; \
  6012.                     ldub [%1],%0       ; \
  6013.                     sll %0,24,%2       ; \
  6014.                     ldub [%1+1],%0     ; \
  6015.                     sll %0,16,%0       ; \
  6016.                     or %2,%0,%2        ; \
  6017.                     ldub [%1+2],%0     ; \
  6018.                     sll %0,8,%0        ; \
  6019.                     or %2,%0,%2        ; \
  6020.                     ldub [%1+3],%0     ; \
  6021.                     or %2,%0,%0        ; \
  6022.                     b 3f               ; \
  6023.                      add %1,4,%1       ; \
  6024.                     2:                   \
  6025.                     sll %0,25,%0       ; \
  6026.                     sra %0,25,%0       ; \
  6027.                     3:                   \
  6028.                     " : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
  6029.                 }
  6030.             #endif
  6031.             #if defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  6032.               #undef S_operand
  6033.               #define S_operand(where)  \
  6034.                 __asm__("\
  6035.                   movzbl (%1),"EAX" ; \
  6036.                   incl %1           ; \
  6037.                   testb "AL","AL"   ; \
  6038.                   jge "LR(1,f)"     ; \
  6039.                   sall $8,"EAX"     ; \
  6040.                   movb (%1),"AL"    ; \
  6041.                   incl %1           ; \
  6042.                   sall $17,"EAX"    ; \
  6043.                   sarl $17,"EAX"    ; \
  6044.                   jne "LR(2,f)"     ; \
  6045.                   movb (%1),"AL"    ; \
  6046.                   sall $8,"EAX"     ; \
  6047.                   movb 1(%1),"AL"   ; \
  6048.                   sall $8,"EAX"     ; \
  6049.                   movb 2(%1),"AL"   ; \
  6050.                   sall $8,"EAX"     ; \
  6051.                   movb 3(%1),"AL"   ; \
  6052.                   addl $4,"EAX"     ; \
  6053.                   jmp "LR(2,f)"     ; \
  6054.                   "LD(1)":            \
  6055.                   sall $25,"EAX"    ; \
  6056.                   sarl $25,"EAX"    ; \
  6057.                   "LD(2)":            \
  6058.                   " : OUT_EAX (where), "=r" (byteptr) : "1" (byteptr) );
  6059.             #endif
  6060.             #
  6061.             # Macro S_operand_ignore();
  6062.             # übergeht den nächsten Operanden (ein Signed Integer)
  6063.             # und rückt dabei den Bytecodepointer weiter.
  6064.               #define S_operand_ignore()  \
  6065.                 { var reg1 uintB where = *byteptr++; # erstes Byte lesen \
  6066.                   if ((uintB)where & bit(7))                             \
  6067.                     # Bit 7 war gesetzt                                  \
  6068.                     { if ((uintB)((where<<1) | *byteptr++) == 0) # nächstes Byte dazu \
  6069.                         # Sonderfall: 2-Byte-Operand = 0 -> 6-Byte-Operand \
  6070.                         { byteptr += 4; }                                \
  6071.                 }   }
  6072.             #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
  6073.               #undef S_operand_ignore
  6074.               #define S_operand_ignore()  \
  6075.                 { var reg1 uintB where; \
  6076.                   __asm__("\
  6077.                     moveb %1@+,%0   ; \
  6078.                     bpl 1f          ; \
  6079.                     addb %0,%0      ; \
  6080.                     orb %1@+,%0     ; \
  6081.                     bne 1f          ; \
  6082.                     addql #4,%1     ; \
  6083.                     1:                \
  6084.                     " : "=d" (where), "=a" (byteptr) : "1" (byteptr) ); \
  6085.                 }
  6086.             #endif
  6087.             #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
  6088.               #undef S_operand_ignore
  6089.               #define S_operand_ignore()  \
  6090.                 { var reg1 uintL where;  \
  6091.                   var reg2 uintL dummy;  \
  6092.                   __asm__("\
  6093.                     ldub [%1],%0       ; \
  6094.                     andcc %0,0x80,%%g0 ; \
  6095.                     be 1f              ; \
  6096.                      add %1,1,%1       ; \
  6097.                     sll %0,1,%2        ; \
  6098.                     ldub [%1],%0       ; \
  6099.                     orcc %2,%0,%0      ; \
  6100.                     bne 1f             ; \
  6101.                      add %1,1,%1       ; \
  6102.                     add %1,4,%1        ; \
  6103.                     1:                   \
  6104.                     " : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
  6105.                 }
  6106.             #endif
  6107.             #
  6108.             # Macro L_operand(where);
  6109.             # bringt den nächsten Operanden (ein Label)
  6110.             # nach (uintB*)where und rückt dabei den Bytecodepointer weiter.
  6111.               #define L_operand(Lwhere)  \
  6112.                 { var reg1 uintL where; # Variable fürs Displacement \
  6113.                   S_operand(where); # Displacement                   \
  6114.                   Lwhere = byteptr + (sintL)where; # addieren        \
  6115.                 }
  6116.             #
  6117.             # Macro L_operand_ignore();
  6118.             # übergeht den nächsten Operanden (ein Label)
  6119.             # und rückt dabei den Bytecodepointer weiter.
  6120.               #define L_operand_ignore()  S_operand_ignore()
  6121.             #
  6122.             # Die einzelnen Bytecodes werden interpretiert:
  6123.             # Dabei ist meist mv_count/mv_space = Werte,
  6124.             # closureptr = Pointer auf die compilierte Closure im Stack,
  6125.             # closure = compilierte Closure,
  6126.             # codeptr = Pointer auf ihren Codevektor,
  6127.             # byteptr = Pointer auf das nächste Byte im Code.
  6128.             # (byteptr ist kein LISP-Objekt, aber dennoch GC-gefährdet! Um es
  6129.             #  GC-invariant zu machen, muß man CODEPTR
  6130.             #  davon subtrahieren. Addiert man dann Fixnum_0 dazu,
  6131.             #  so hat man die Bytenummer als Fixnum.)
  6132.             #if 0
  6133.               #define CODEPTR  (&codeptr->data[0])
  6134.             #else # liefert effizienteren Code
  6135.               #define CODEPTR  (uintB*)(codeptr)
  6136.             #endif
  6137.             #
  6138.             # Kontextinformation aufbewahren:
  6139.             # Wird etwas aufgerufen, das eine GC auslösen kann, so muß dies in ein
  6140.             # with_saved_context( ... ) eingebaut werden.
  6141.               #define with_saved_context(statement)  \
  6142.                 { var reg9 uintL index = byteptr - CODEPTR;                  \
  6143.                   statement;                                                 \
  6144.                   closure = *closureptr; # Closure aus dem Stack holen       \
  6145.                   codeptr = TheSbvector(TheCclosure(closure)->clos_codevec); \
  6146.                   byteptr = CODEPTR + index;                                 \
  6147.                 }
  6148.             #
  6149.             # ------------------- (1) Konstanten -----------------------
  6150.             CASE cod_nil:                    # (NIL)
  6151.               code_nil:
  6152.               value1 = NIL; mv_count = 1;
  6153.               goto next_byte;
  6154.             CASE cod_nil_push:               # (NIL&PUSH)
  6155.               pushSTACK(NIL);
  6156.               goto next_byte;
  6157.             CASE cod_push_nil:               # (PUSH-NIL n)
  6158.               { var reg2 uintC n;
  6159.                 U_operand(n);
  6160.                 dotimesC(n,n, { pushSTACK(NIL); } );
  6161.               }
  6162.               goto next_byte;
  6163.             CASE cod_t:                      # (T)
  6164.               code_t:
  6165.               value1 = T; mv_count = 1;
  6166.               goto next_byte;
  6167.             CASE cod_t_push:                 # (T&PUSH)
  6168.               pushSTACK(T);
  6169.               goto next_byte;
  6170.             CASE cod_const:                  # (CONST n)
  6171.               { var reg2 uintL n;
  6172.                 U_operand(n);
  6173.                 value1 = TheCclosure(closure)->clos_consts[n]; mv_count=1;
  6174.               }
  6175.               goto next_byte;
  6176.             CASE cod_const_push:             # (CONST&PUSH n)
  6177.               { var reg2 uintL n;
  6178.                 U_operand(n);
  6179.                 pushSTACK(TheCclosure(closure)->clos_consts[n]);
  6180.               }
  6181.               goto next_byte;
  6182.             # ------------------- (2) statische Variablen -----------------------
  6183.             CASE cod_load:                   # (LOAD n)
  6184.               { var reg2 uintL n;
  6185.                 U_operand(n);
  6186.                 value1 = STACK_(n); mv_count=1;
  6187.               }
  6188.               goto next_byte;
  6189.             CASE cod_load_push:              # (LOAD&PUSH n)
  6190.               { var reg2 uintL n;
  6191.                 U_operand(n);
  6192.                 pushSTACK(STACK_(n));
  6193.               }
  6194.               goto next_byte;
  6195.             CASE cod_loadi:                  # (LOADI k n)
  6196.               { var reg4 uintL k;
  6197.                 var reg4 uintL n;
  6198.                 U_operand(k);
  6199.                 U_operand(n);
  6200.                {var reg2 object* FRAME = (object*) SP_(k);
  6201.                 value1 = FRAME_(n); mv_count=1;
  6202.               }}
  6203.               goto next_byte;
  6204.             CASE cod_loadi_push:             # (LOADI&PUSH k n)
  6205.               { var reg4 uintL k;
  6206.                 var reg4 uintL n;
  6207.                 U_operand(k);
  6208.                 U_operand(n);
  6209.                {var reg2 object* FRAME = (object*) SP_(k);
  6210.                 pushSTACK(FRAME_(n));
  6211.               }}
  6212.               goto next_byte;
  6213.             CASE cod_loadc:                  # (LOADC n m)
  6214.               { var reg4 uintL n;
  6215.                 var reg2 uintL m;
  6216.                 U_operand(n);
  6217.                 U_operand(m);
  6218.                 value1 = TheSvector(STACK_(n))->data[1+m]; mv_count=1;
  6219.               }
  6220.               goto next_byte;
  6221.             CASE cod_loadc_push:             # (LOADC&PUSH n m)
  6222.               { var reg4 uintL n;
  6223.                 var reg2 uintL m;
  6224.                 U_operand(n);
  6225.                 U_operand(m);
  6226.                 pushSTACK(TheSvector(STACK_(n))->data[1+m]);
  6227.               }
  6228.               goto next_byte;
  6229.             CASE cod_loadv:                  # (LOADV k m)
  6230.               { var reg4 uintC k;
  6231.                 var reg7 uintL m;
  6232.                 U_operand(k);
  6233.                 U_operand(m);
  6234.                {var reg2 object venv = TheCclosure(closure)->clos_venv; # VenvConst
  6235.                 # k mal (svref ... 0) nehmen:
  6236.                 dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
  6237.                 # (svref ... m) holen:
  6238.                 value1 = TheSvector(venv)->data[m]; mv_count=1;
  6239.               }}
  6240.               goto next_byte;
  6241.             CASE cod_loadv_push:             # (LOADV&PUSH k m)
  6242.               { var reg4 uintC k;
  6243.                 var reg7 uintL m;
  6244.                 U_operand(k);
  6245.                 U_operand(m);
  6246.                {var reg2 object venv = TheCclosure(closure)->clos_venv; # VenvConst
  6247.                 # k mal (svref ... 0) nehmen:
  6248.                 dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
  6249.                 # (svref ... m) holen:
  6250.                 pushSTACK(TheSvector(venv)->data[m]);
  6251.               }}
  6252.               goto next_byte;
  6253.             CASE cod_loadic:                 # (LOADIC k n m)
  6254.               { var reg8 uintL k;
  6255.                 var reg7 uintL n;
  6256.                 var reg4 uintL m;
  6257.                 U_operand(k);
  6258.                 U_operand(n);
  6259.                 U_operand(m);
  6260.                {var reg2 object* FRAME = (object*) SP_(k);
  6261.                 value1 = TheSvector(FRAME_(n))->data[1+m]; mv_count=1;
  6262.               }}
  6263.               goto next_byte;
  6264.             CASE cod_store: store:           # (STORE n)
  6265.               { var reg2 uintL n;
  6266.                 U_operand(n);
  6267.                 STACK_(n) = value1; mv_count=1;
  6268.               }
  6269.               goto next_byte;
  6270.             CASE cod_pop_store:              # (POP&STORE n)
  6271.               { var reg2 uintL n;
  6272.                 U_operand(n);
  6273.                {var reg4 object obj = popSTACK();
  6274.                 STACK_(n) = value1 = obj; mv_count=1;
  6275.               }}
  6276.               goto next_byte;
  6277.             CASE cod_storei:                 # (STOREI k n)
  6278.               { var reg4 uintL k;
  6279.                 var reg4 uintL n;
  6280.                 U_operand(k);
  6281.                 U_operand(n);
  6282.                {var reg2 object* FRAME = (object*) SP_(k);
  6283.                 FRAME_(n) = value1; mv_count=1;
  6284.               }}
  6285.               goto next_byte;
  6286.             CASE cod_load_storec:            # (LOAD&STOREC k m n)
  6287.               { var reg2 uintL k;
  6288.                 U_operand(k);
  6289.                 value1 = STACK_(k);
  6290.               }
  6291.             CASE cod_storec:                 # (STOREC n m)
  6292.               { var reg4 uintL n;
  6293.                 var reg2 uintL m;
  6294.                 U_operand(n);
  6295.                 U_operand(m);
  6296.                 TheSvector(STACK_(n))->data[1+m] = value1; mv_count=1;
  6297.               }
  6298.               goto next_byte;
  6299.             CASE cod_storev:                 # (STOREV k m)
  6300.               { var reg4 uintC k;
  6301.                 var reg7 uintL m;
  6302.                 U_operand(k);
  6303.                 U_operand(m);
  6304.                {var reg2 object venv = TheCclosure(closure)->clos_venv; # VenvConst
  6305.                 # k mal (svref ... 0) nehmen:
  6306.                 dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
  6307.                 # (svref ... m) abspeichern:
  6308.                 TheSvector(venv)->data[m] = value1; mv_count=1;
  6309.               }}
  6310.               goto next_byte;
  6311.             CASE cod_storeic:                # (STOREIC k n m)
  6312.               { var reg8 uintL k;
  6313.                 var reg7 uintL n;
  6314.                 var reg4 uintL m;
  6315.                 U_operand(k);
  6316.                 U_operand(n);
  6317.                 U_operand(m);
  6318.                {var reg2 object* FRAME = (object*) SP_(k);
  6319.                 TheSvector(FRAME_(n))->data[1+m] = value1; mv_count=1;
  6320.               }}
  6321.               goto next_byte;
  6322.             # ------------------- (3) dynamische Variablen -----------------------
  6323.             CASE cod_getvalue:               # (GETVALUE n)
  6324.               { var reg4 uintL n;
  6325.                 U_operand(n);
  6326.                {var reg2 object symbol = TheCclosure(closure)->clos_consts[n];
  6327.                 # Der Compiler hat schon überprüft, daß es ein Symbol ist.
  6328.                 if (eq(Symbol_value(symbol),unbound))
  6329.                   { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
  6330.                     pushSTACK(symbol);
  6331.                     //: DEUTSCH "Symbol ~ hat keinen Wert."
  6332.                     //: ENGLISH "symbol ~ has no value"
  6333.                     //: FRANCAIS "Le symbôle ~ n'a pas de valeur."
  6334.                     fehler(unbound_variable, GETTEXT("symbol ~ has no value"));
  6335.                   }
  6336.                 value1 = Symbol_value(symbol); mv_count=1;
  6337.               }}
  6338.               goto next_byte;
  6339.             CASE cod_getvalue_push:          # (GETVALUE&PUSH n)
  6340.               { var reg4 uintL n;
  6341.                 U_operand(n);
  6342.                {var reg2 object symbol = TheCclosure(closure)->clos_consts[n];
  6343.                 # Der Compiler hat schon überprüft, daß es ein Symbol ist.
  6344.                 if (eq(Symbol_value(symbol),unbound))
  6345.                   { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
  6346.                     pushSTACK(symbol);
  6347.                     //: DEUTSCH "Symbol ~ hat keinen Wert."
  6348.                     //: ENGLISH "symbol ~ has no value"
  6349.                     //: FRANCAIS "Le symbôle ~ n'a pas de valeur."
  6350.                     fehler(unbound_variable, GETTEXT("symbol ~ has no value"));
  6351.                   }
  6352.                 pushSTACK(Symbol_value(symbol));
  6353.               }}
  6354.               goto next_byte;
  6355.             CASE cod_setvalue:               # (SETVALUE n)
  6356.               { var reg4 uintL n;
  6357.                 U_operand(n);
  6358.                {var reg2 object symbol = TheCclosure(closure)->clos_consts[n];
  6359.                 # Der Compiler hat schon überprüft, daß es ein Symbol ist.
  6360.                 if (constantp(TheSymbol(symbol)))
  6361.                   { pushSTACK(symbol);
  6362.                     //: DEUTSCH "Zuweisung nicht möglich auf das konstante Symbol ~"
  6363.                     //: ENGLISH "assignment to constant symbol ~ is impossible"
  6364.                     //: FRANCAIS "Une assignation du symbôle constant ~ n'est pas possible."
  6365.                     fehler(error, GETTEXT("assignment to constant symbol ~ is impossible"));
  6366.                   }
  6367.                 set_Symbol_value(symbol,value1); mv_count=1;
  6368.               }}
  6369.               goto next_byte;
  6370.             CASE cod_bind:                   # (BIND n)
  6371.               { var reg2 uintL n;
  6372.                 U_operand(n);
  6373.                 with_saved_context(
  6374.                   dynamic_bind(TheCclosure(closure)->clos_consts[n],value1);
  6375.                   );
  6376.               }
  6377.               goto next_byte;
  6378.             CASE cod_unbind1:                # (UNBIND1)
  6379.               #if STACKCHECKC
  6380.               if (!(mtypecode(STACK_0) == DYNBIND_frame_info))
  6381.                 goto fehler_STACK_putt;
  6382.               #endif
  6383.               # Variablenbindungsframe auflösen:
  6384.               { var reg7 object* new_STACK = topofframe(STACK_0); # Pointer übern Frame
  6385.                 var reg4 object* frame_end = STACKpointable(new_STACK);
  6386.                 var reg2 object* bindingptr = &STACK_1; # Beginn der Bindungen
  6387.                 # bindingptr läuft durch die Bindungen hoch
  6388.                 until (bindingptr == frame_end)
  6389.                   { # alten Wert zurückschreiben:
  6390.                     set_Symbol_symvalue(*(bindingptr STACKop 0),*(bindingptr STACKop 1));
  6391.                     bindingptr skipSTACKop 2; # nächste Bindung
  6392.                   }
  6393.                 #ifdef DYNBIND_LIST
  6394.                 delete_frame_from_binding_list(&STACK_0);
  6395.                 #endif
  6396.                 # STACK neu setzen, dadurch Frame auflösen:
  6397.                 setSTACK(STACK = new_STACK);
  6398.               }
  6399.               goto next_byte;
  6400.             CASE cod_unbind:                 # (UNBIND n)
  6401.               { var reg8 uintC n;
  6402.                 U_operand(n); # n>0
  6403.                {var reg2 object* FRAME = STACK;
  6404.                 do {
  6405.                     #if STACKCHECKC
  6406.                     if (!(mtypecode(FRAME_(0)) == DYNBIND_frame_info))
  6407.                       goto fehler_STACK_putt;
  6408.                     #endif
  6409.                     # Variablenbindungsframe auflösen:
  6410.                     { var reg7 object* new_FRAME = topofframe(FRAME_(0)); # Pointer übern Frame
  6411.                       var reg4 object* frame_end = STACKpointable(new_FRAME);
  6412.                       var reg2 object* bindingptr = &FRAME_(1); # Beginn der Bindungen
  6413.                       # bindingptr läuft durch die Bindungen hoch
  6414.                       until (bindingptr == frame_end)
  6415.                         { # alten Wert zurückschreiben:
  6416.                           set_Symbol_symvalue(*(bindingptr STACKop 0),*(bindingptr STACKop 1));
  6417.                           bindingptr skipSTACKop 2; # nächste Bindung
  6418.                         }
  6419.                       #ifdef DYNBIND_LIST
  6420.                       delete_frame_from_binding_list(&STACK_0);
  6421.                       #endif
  6422.                       FRAME = new_FRAME;
  6423.                    }}
  6424.                    until (--n == 0);
  6425.                 setSTACK(STACK = FRAME); # STACK neu setzen
  6426.               }}
  6427.               goto next_byte;
  6428.             CASE cod_progv:                  # (PROGV)
  6429.               { var reg2 object vallist = value1; # Wertliste
  6430.                 var reg4 object symlist = popSTACK(); # Symbolliste
  6431.                 pushSP((aint)STACK); # STACK in den SP legen
  6432.                 with_saved_context(
  6433.                   progv(symlist,vallist); # Frame aufbauen           
  6434.                   );
  6435.               }
  6436.               goto next_byte;
  6437.             # ------------------- (4) Stackoperationen -----------------------
  6438.             CASE cod_push:                   # (PUSH)
  6439.               pushSTACK(value1);
  6440.               goto next_byte;
  6441.             CASE cod_pop:                    # (POP)
  6442.               value1 = popSTACK(); mv_count=1;
  6443.               goto next_byte;
  6444.             CASE cod_skip:                   # (SKIP n)
  6445.               { var reg2 uintL n;
  6446.                 U_operand(n);
  6447.                 skipSTACK(n);
  6448.               }
  6449.               goto next_byte;
  6450.             CASE cod_skipi:                  # (SKIPI k n)
  6451.               { var reg2 uintL k;
  6452.                 var reg4 uintL n;
  6453.                 U_operand(k);
  6454.                 U_operand(n);
  6455.                 skipSP(k);
  6456.                {var reg2 object* newSTACK;
  6457.                 popSP( newSTACK = (object*) );
  6458.                 setSTACK(STACK = newSTACK STACKop n);
  6459.               }}
  6460.               goto next_byte;
  6461.             CASE cod_skipsp:                 # (SKIPSP k)
  6462.               { var reg2 uintL k;
  6463.                 U_operand(k);
  6464.                 skipSP(k);
  6465.               }
  6466.               goto next_byte;
  6467.             # ------------------- (5) Programmfluß und Sprünge -----------------------
  6468.             CASE cod_skip_ret:               # (SKIP&RET n)
  6469.               { var reg2 uintL n;
  6470.                 U_operand(n);
  6471.                 skipSTACK(n);
  6472.                 goto finished; # Rücksprung zum Aufrufer
  6473.               }
  6474.             #define JMP()  \
  6475.               { var reg2 uintB* label_byteptr; \
  6476.                 L_operand(label_byteptr);      \
  6477.                 byteptr = label_byteptr;       \
  6478.                 goto next_byte;                \
  6479.               }
  6480.             #define NOTJMP()  \
  6481.               { L_operand_ignore(); goto next_byte; }
  6482.             jmp1: mv_count=1;
  6483.             CASE cod_jmp: jmp:               # (JMP label)
  6484.               JMP();
  6485.             CASE cod_jmpif:                  # (JMPIF label)
  6486.               if (!nullp(value1)) goto jmp;
  6487.               notjmp:
  6488.               NOTJMP();
  6489.             CASE cod_jmpifnot:               # (JMPIFNOT label)
  6490.               if (nullp(value1)) goto jmp;
  6491.               NOTJMP();
  6492.             CASE cod_jmpif1:                 # (JMPIF1 label)
  6493.               if (!nullp(value1)) goto jmp1;
  6494.               NOTJMP();
  6495.             CASE cod_jmpifnot1:              # (JMPIFNOT1 label)
  6496.               if (nullp(value1)) goto jmp1;
  6497.               NOTJMP();
  6498.             CASE cod_jmpifatom:              # (JMPIFATOM label)
  6499.               if (atomp(value1)) goto jmp;
  6500.               NOTJMP();
  6501.             CASE cod_jmpifconsp:             # (JMPIFCONSP label)
  6502.               if (consp(value1)) goto jmp;
  6503.               NOTJMP();
  6504.             CASE cod_jmpifeq:                # (JMPIFEQ label)
  6505.               if (eq(popSTACK(),value1)) goto jmp;
  6506.               NOTJMP();
  6507.             CASE cod_jmpifnoteq:             # (JMPIFNOTEQ label)
  6508.               if (!eq(popSTACK(),value1)) goto jmp;
  6509.               NOTJMP();
  6510.             CASE cod_jmpifeqto:              # (JMPIFEQTO n label)
  6511.               { var reg2 uintL n;
  6512.                 U_operand(n);
  6513.                 if (eq(popSTACK(),TheCclosure(closure)->clos_consts[n])) goto jmp;
  6514.               }
  6515.               NOTJMP();
  6516.             CASE cod_jmpifnoteqto:           # (JMPIFNOTEQTO n label)
  6517.               { var reg2 uintL n;
  6518.                 U_operand(n);
  6519.                 if (!eq(popSTACK(),TheCclosure(closure)->clos_consts[n])) goto jmp;
  6520.               }
  6521.               NOTJMP();
  6522.             CASE cod_jmphash:                # (JMPHASH n label)
  6523.               { var reg7 uintL n;
  6524.                 U_operand(n);
  6525.                {var reg4 object hashvalue = # value1 in der Hash-Tabelle suchen
  6526.                   gethash(value1,TheCclosure(closure)->clos_consts[n]);
  6527.                 if (eq(hashvalue,nullobj))
  6528.                   goto jmp; # nicht gefunden -> zu label springen
  6529.                   else # gefundenes Fixnum als Label interpretieren:
  6530.                   { byteptr += fixnum_to_L(hashvalue); }
  6531.               }}
  6532.               goto next_byte;
  6533.             CASE cod_jmphashv:               # (JMPHASHV n label)
  6534.               { var reg7 uintL n;
  6535.                 U_operand(n);
  6536.                {var reg4 object hashvalue = # value1 in der Hash-Tabelle suchen
  6537.                   gethash(value1,TheSvector(TheCclosure(closure)->clos_consts[0])->data[n]);
  6538.                 if (eq(hashvalue,nullobj))
  6539.                   goto jmp; # nicht gefunden -> zu label springen
  6540.                   else # gefundenes Fixnum als Label interpretieren:
  6541.                   { byteptr += fixnum_to_L(hashvalue); }
  6542.               }}
  6543.               goto next_byte;
  6544.             # Führt einen (JSR label)-Befehl aus.
  6545.             #define JSR()  \
  6546.               check_STACK(); check_SP();                              \
  6547.               { var reg2 uintB* label_byteptr;                        \
  6548.                 L_operand(label_byteptr);                             \
  6549.                 with_saved_context(                                   \
  6550.                   interpret_bytecode_(closure,codeptr,label_byteptr); \
  6551.                   );                                                  \
  6552.               }
  6553.             CASE cod_jsr:                    # (JSR label)
  6554.               JSR();
  6555.               goto next_byte;
  6556.             CASE cod_jsr_push:               # (JSR&PUSH label)
  6557.               JSR(); pushSTACK(value1);
  6558.               goto next_byte;
  6559.             CASE cod_jmptail:                # (JMPTAIL m n label)
  6560.               { var reg7 uintL m;
  6561.                 var reg8 uintL n;
  6562.                 U_operand(m);
  6563.                 U_operand(n);
  6564.                 # Es gilt n>=m. m Stackeinträge um n-m nach oben kopieren:
  6565.                {var reg4 object* ptr1 = STACK STACKop m;
  6566.                 var reg2 object* ptr2 = STACK STACKop n;
  6567.                 var reg6 uintC count;
  6568.                 dotimesC(count,m, { NEXT(ptr2) = NEXT(ptr1); } );
  6569.                 # Nun ist ptr1 = STACK und ptr2 = STACK STACKop (n-m).
  6570.                 *(closureptr = &NEXT(ptr2)) = closure; # Closure im Stack ablegen
  6571.                 setSTACK(STACK = ptr2); # STACK verkürzen
  6572.               }}
  6573.               JMP(); # an label springen
  6574.             # ------------------- (6) Environments und Closures -----------------------
  6575.             CASE cod_venv:                   # (VENV)
  6576.               # VenvConst aus der Closure holen:
  6577.               value1 = TheCclosure(closure)->clos_venv; mv_count=1;
  6578.               goto next_byte;
  6579.             CASE cod_make_vector1_push:      # (MAKE-VECTOR1&PUSH n)
  6580.               { var reg4 uintL n;
  6581.                 U_operand(n);
  6582.                 pushSTACK(value1);
  6583.                 # Vektor erzeugen:
  6584.                {var reg2 object vec;
  6585.                 with_saved_context( { vec = allocate_vector(n+1); } );
  6586.                 # Erstes Element eintragen:
  6587.                 TheSvector(vec)->data[0] = STACK_0;
  6588.                 STACK_0 = vec;
  6589.               }}
  6590.               goto next_byte;
  6591.             CASE cod_copy_closure:           # (COPY-CLOSURE m n)
  6592.               { var reg9 object old;
  6593.                 # zu kopierende Closure holen:
  6594.                {var reg2 uintL m;
  6595.                 U_operand(m);
  6596.                 old = TheCclosure(closure)->clos_consts[m];
  6597.                }
  6598.                 # Closure gleicher Länge allozieren:
  6599.                {var reg8 object new;
  6600.                 pushSTACK(old);
  6601.                 with_saved_context(
  6602.                   new = allocate_srecord(0,Rectype_Closure,TheCclosure(old)->reclength,closure_type);
  6603.                   );
  6604.                 old = popSTACK();
  6605.                 # Inhalt der alten in die neue Closure kopieren:
  6606.                 { var reg2 object* newptr = &((Srecord)TheCclosure(new))->recdata[0];
  6607.                   var reg4 object* oldptr = &((Srecord)TheCclosure(old))->recdata[0];
  6608.                   var reg6 uintC count;
  6609.                   dotimespC(count,((Srecord)TheCclosure(old))->reclength,
  6610.                     { *newptr++ = *oldptr++; }
  6611.                     );
  6612.                 }
  6613.                 # Stackinhalt in die neue Closure kopieren:
  6614.                 { var reg7 uintL n;
  6615.                   U_operand(n);
  6616.                  {var reg2 object* newptr = &TheCclosure(new)->clos_consts[n];
  6617.                   dotimespL(n,n, { *--newptr = popSTACK(); } );
  6618.                 }}
  6619.                 value1 = new; mv_count=1;
  6620.               }}
  6621.               goto next_byte;
  6622.             CASE cod_copy_closure_push:      # (COPY-CLOSURE&PUSH m n)
  6623.               { var reg9 object old;
  6624.                 # zu kopierende Closure holen:
  6625.                {var reg2 uintL m;
  6626.                 U_operand(m);
  6627.                 old = TheCclosure(closure)->clos_consts[m];
  6628.                }
  6629.                 # Closure gleicher Länge allozieren:
  6630.                {var reg8 object new;
  6631.                 pushSTACK(old);
  6632.                 with_saved_context(
  6633.                   new = allocate_srecord(0,Rectype_Closure,TheCclosure(old)->reclength,closure_type);
  6634.                   );
  6635.                 old = popSTACK();
  6636.                 # Inhalt der alten in die neue Closure kopieren:
  6637.                 { var reg2 object* newptr = &((Srecord)TheCclosure(new))->recdata[0];
  6638.                   var reg4 object* oldptr = &((Srecord)TheCclosure(old))->recdata[0];
  6639.                   var reg6 uintC count;
  6640.                   dotimespC(count,((Srecord)TheCclosure(old))->reclength,
  6641.                     { *newptr++ = *oldptr++; }
  6642.                     );
  6643.                 }
  6644.                 # Stackinhalt in die neue Closure kopieren:
  6645.                 { var reg7 uintL n;
  6646.                   U_operand(n);
  6647.                  {var reg2 object* newptr = &TheCclosure(new)->clos_consts[n];
  6648.                   dotimespL(n,n, { *--newptr = popSTACK(); } );
  6649.                 }}
  6650.                 pushSTACK(new);
  6651.               }}
  6652.               goto next_byte;
  6653.             # ------------------- (7) Funktionsaufrufe -----------------------
  6654.             # Führt (CALL k n)-Befehl aus.
  6655.             #define CALL()  \
  6656.               { var reg4 uintC k; # Argumentezahl                  \
  6657.                 var reg2 uintL n;                                  \
  6658.                 U_operand(k);                                      \
  6659.                 U_operand(n);                                      \
  6660.                 with_saved_context(                                \
  6661.                   funcall(TheCclosure(closure)->clos_consts[n],k); \
  6662.                   );                                               \
  6663.               }
  6664.             # Führt (CALL0 n)-Befehl aus.
  6665.             #define CALL0()  \
  6666.               { var reg2 uintL n;                                  \
  6667.                 U_operand(n);                                      \
  6668.                 with_saved_context(                                \
  6669.                   funcall(TheCclosure(closure)->clos_consts[n],0); \
  6670.                   );                                               \
  6671.               }
  6672.             # Führt (CALL1 n)-Befehl aus.
  6673.             #define CALL1()  \
  6674.               { var reg2 uintL n;                                  \
  6675.                 U_operand(n);                                      \
  6676.                 with_saved_context(                                \
  6677.                   funcall(TheCclosure(closure)->clos_consts[n],1); \
  6678.                   );                                               \
  6679.               }
  6680.             # Führt (CALL2 n)-Befehl aus.
  6681.             #define CALL2()  \
  6682.               { var reg2 uintL n;                                  \
  6683.                 U_operand(n);                                      \
  6684.                 with_saved_context(                                \
  6685.                   funcall(TheCclosure(closure)->clos_consts[n],2); \
  6686.                   );                                               \
  6687.               }
  6688.             # Führt (CALLS1 n)-Befehl aus.
  6689.             #define CALLS1()  \
  6690.               { var reg2 uintL n;                                         \
  6691.                 B_operand(n);                                             \
  6692.                 # Der Compiler hat die Argumentüberprüfung schon gemacht. \
  6693.                {var reg2 Subr fun = FUNTAB1[n];                           \
  6694.                 subr_self = subr_tab_ptr_as_object(fun);                  \
  6695.                 with_saved_context(                                       \
  6696.                   (*(subr_norest_function*)(fun->function))();            \
  6697.                   );                                                      \
  6698.               }}
  6699.             # Führt (CALLS2 n)-Befehl aus.
  6700.             #define CALLS2()  \
  6701.               { var reg2 uintL n;                                         \
  6702.                 B_operand(n);                                             \
  6703.                 # Der Compiler hat die Argumentüberprüfung schon gemacht. \
  6704.                {var reg2 Subr fun = FUNTAB2[n];                           \
  6705.                 subr_self = subr_tab_ptr_as_object(fun);                  \
  6706.                 with_saved_context(                                       \
  6707.                   (*(subr_norest_function*)(fun->function))();            \
  6708.                   );                                                      \
  6709.               }}
  6710.             # Führt (CALLSR m n)-Befehl aus.
  6711.             #define CALLSR()  \
  6712.               { var reg4 uintL m;                                         \
  6713.                 var reg2 uintL n;                                         \
  6714.                 U_operand(m);                                             \
  6715.                 B_operand(n);                                             \
  6716.                 # Der Compiler hat die Argumentüberprüfung schon gemacht. \
  6717.                {var reg2 Subr fun = FUNTABR[n];                           \
  6718.                 subr_self = subr_tab_ptr_as_object(fun);                  \
  6719.                 with_saved_context(                                       \
  6720.                   (*(subr_rest_function*)(fun->function))(m,args_end_pointer STACKop m); \
  6721.                   );                                                      \
  6722.               }}
  6723.             CASE cod_call:                   # (CALL k n)
  6724.               CALL();
  6725.               goto next_byte;
  6726.             CASE cod_call_push:              # (CALL&PUSH k n)
  6727.               CALL(); pushSTACK(value1);
  6728.               goto next_byte;
  6729.             CASE cod_call0:                  # (CALL0 n)
  6730.               CALL0();
  6731.               goto next_byte;
  6732.             CASE cod_call1:                  # (CALL1 n)
  6733.               CALL1();
  6734.               goto next_byte;
  6735.             CASE cod_call1_push:             # (CALL1&PUSH n)
  6736.               CALL1(); pushSTACK(value1);
  6737.               goto next_byte;
  6738.             CASE cod_call2:                  # (CALL2 n)
  6739.               CALL2();
  6740.               goto next_byte;
  6741.             CASE cod_call2_push:             # (CALL2&PUSH n)
  6742.               CALL2(); pushSTACK(value1);
  6743.               goto next_byte;
  6744.             CASE cod_calls1:                 # (CALLS1 n)
  6745.               CALLS1();
  6746.               goto next_byte;
  6747.             CASE cod_calls1_push:            # (CALLS1&PUSH n)
  6748.               CALLS1(); pushSTACK(value1);
  6749.               goto next_byte;
  6750.             CASE cod_calls2:                 # (CALLS2 n)
  6751.               CALLS2();
  6752.               goto next_byte;
  6753.             CASE cod_calls2_push:            # (CALLS2&PUSH n)
  6754.               CALLS2(); pushSTACK(value1);
  6755.               goto next_byte;
  6756.             CASE cod_callsr:                 # (CALLSR m n)
  6757.               CALLSR();
  6758.               goto next_byte;
  6759.             CASE cod_callsr_push:            # (CALLSR&PUSH m n)
  6760.               CALLSR(); pushSTACK(value1);
  6761.               goto next_byte;
  6762.             # Führt einen (CALLC)-Befehl aus.
  6763.             #define CALLC()  \
  6764.               { check_STACK(); check_SP(); # STACK und SP überprüfen \
  6765.                 with_saved_context(                                  \
  6766.                   # compilierte Closure ab Byte 6 interpretieren:    \
  6767.                   interpret_bytecode(value1,TheCclosure(value1)->clos_codevec,CCHD+6); \
  6768.                   );                                                 \
  6769.               }
  6770.             # Führt einen (CALLCKEY)-Befehl aus.
  6771.             #define CALLCKEY()  \
  6772.               { check_STACK(); check_SP(); # STACK und SP überprüfen \
  6773.                 with_saved_context(                                  \
  6774.                   # compilierte Closure ab Byte 10 interpretieren:   \
  6775.                   interpret_bytecode(value1,TheCclosure(value1)->clos_codevec,CCHD+10); \
  6776.                   );                                                 \
  6777.               }
  6778.             CASE cod_callc:                  # (CALLC)
  6779.               CALLC();
  6780.               goto next_byte;
  6781.             CASE cod_callc_push:             # (CALLC&PUSH)
  6782.               CALLC(); pushSTACK(value1);
  6783.               goto next_byte;
  6784.             CASE cod_callckey:               # (CALLCKEY)
  6785.               CALLCKEY();
  6786.               goto next_byte;
  6787.             CASE cod_callckey_push:          # (CALLCKEY&PUSH)
  6788.               CALLCKEY(); pushSTACK(value1);
  6789.               goto next_byte;
  6790.             CASE cod_funcall:                # (FUNCALL n)
  6791.               { var reg2 uintL n;
  6792.                 U_operand(n);
  6793.                {var reg4 object fun = STACK_(n); # Funktion
  6794.                 with_saved_context( funcall(fun,n); ); # Funktion aufrufen
  6795.                 skipSTACK(1); # Funktion aus dem Stack streichen
  6796.               }}
  6797.               goto next_byte;
  6798.             CASE cod_funcall_push:           # (FUNCALL&PUSH n)
  6799.               { var reg2 uintL n;
  6800.                 U_operand(n);
  6801.                {var reg4 object fun = STACK_(n); # Funktion
  6802.                 with_saved_context( funcall(fun,n); ); # Funktion aufrufen
  6803.                 STACK_0 = value1; # Funktion im Stack durch den Wert ersetzen
  6804.               }}
  6805.               goto next_byte;
  6806.             CASE cod_apply:                  # (APPLY n)
  6807.               { var reg2 uintL n;
  6808.                 U_operand(n);
  6809.                {var reg4 object fun = STACK_(n); # Funktion
  6810.                 with_saved_context( apply(fun,n,value1); ); # Funktion aufrufen
  6811.                 skipSTACK(1); # Funktion aus dem Stack streichen
  6812.               }}
  6813.               goto next_byte;
  6814.             CASE cod_apply_push:             # (APPLY&PUSH n)
  6815.               { var reg2 uintL n;
  6816.                 U_operand(n);
  6817.                {var reg4 object fun = STACK_(n); # Funktion
  6818.                 with_saved_context( apply(fun,n,value1); ); # Funktion aufrufen
  6819.                 STACK_0 = value1; # Funktion im Stack durch den Wert ersetzen
  6820.               }}
  6821.               goto next_byte;
  6822.             # ------------------- (8) optionale und Keyword-Argumente -----------------------
  6823.             CASE cod_push_unbound:           # (PUSH-UNBOUND n)
  6824.               { var reg2 uintC n;
  6825.                 U_operand(n);
  6826.                 dotimesC(n,n, { pushSTACK(unbound); } );
  6827.               }
  6828.               goto next_byte;
  6829.             CASE cod_unlist:                 # (UNLIST n m)
  6830.               { var reg4 uintC n;
  6831.                 var reg5 uintC m;
  6832.                 U_operand(n);
  6833.                 U_operand(m);
  6834.                {var reg2 object l = value1;
  6835.                 if (n > 0)
  6836.                   do { if (atomp(l)) goto unlist_unbound;
  6837.                        pushSTACK(Car(l)); l = Cdr(l);
  6838.                      }
  6839.                      until (--n == 0);
  6840.                 if (atomp(l))
  6841.                   goto next_byte;
  6842.                   else
  6843.                   fehler_apply_zuviel(S(lambda));
  6844.                 unlist_unbound:
  6845.                 if (n > m) fehler_apply_zuwenig(S(lambda));
  6846.                 do { pushSTACK(unbound); } until (--n == 0);
  6847.                 goto next_byte;
  6848.               }}
  6849.             CASE cod_unliststern:            # (UNLIST* n m)
  6850.               { var reg4 uintC n;
  6851.                 var reg5 uintC m;
  6852.                 U_operand(n);
  6853.                 U_operand(m);
  6854.                {var reg2 object l = value1;
  6855.                 do { if (atomp(l)) goto unliststern_unbound;
  6856.                      pushSTACK(Car(l)); l = Cdr(l);
  6857.                    }
  6858.                    until (--n == 0);
  6859.                 pushSTACK(l);
  6860.                 goto next_byte;
  6861.                 unliststern_unbound:
  6862.                 if (n > m) fehler_apply_zuwenig(S(lambda));
  6863.                 do { pushSTACK(unbound); } until (--n == 0);
  6864.                 pushSTACK(NIL);
  6865.                 goto next_byte;
  6866.               }}
  6867.             CASE cod_jmpifboundp:            # (JMPIFBOUNDP n label)
  6868.               { var reg4 uintL n;
  6869.                 U_operand(n);
  6870.                {var reg2 object obj = STACK_(n);
  6871.                 if (eq(obj,unbound)) goto notjmp;
  6872.                 value1 = obj; mv_count=1; JMP();
  6873.               }}
  6874.             CASE cod_boundp:                 # (BOUNDP n)
  6875.               { var reg4 uintL n;
  6876.                 U_operand(n);
  6877.                {var reg2 object obj = STACK_(n);
  6878.                 if (eq(obj,unbound)) goto code_nil; else goto code_t;
  6879.               }}
  6880.             CASE cod_unbound_nil:            # (UNBOUND->NIL n)
  6881.               { var reg2 uintL n;
  6882.                 U_operand(n);
  6883.                 if (eq(STACK_(n),unbound)) { STACK_(n) = NIL; }
  6884.               }
  6885.               goto next_byte;
  6886.             # ------------------- (9) Behandlung mehrerer Werte -----------------------
  6887.             CASE cod_values0:                # (VALUES0)
  6888.               value1 = NIL; mv_count = 0;
  6889.               goto next_byte;
  6890.             CASE cod_values1:                # (VALUES1)
  6891.               mv_count = 1;
  6892.               goto next_byte;
  6893.             CASE cod_stack_to_mv:            # (STACK-TO-MV n)
  6894.               { var reg2 uintL n;
  6895.                 U_operand(n);
  6896.                 if (n >= mv_limit) goto fehler_zuviele_werte;
  6897.                 STACK_to_mv(n);
  6898.               }
  6899.               goto next_byte;
  6900.             CASE cod_mv_to_stack:            # (MV-TO-STACK)
  6901.               mv_to_STACK(); # Werte auf den Stack schieben
  6902.               goto next_byte;
  6903.             CASE cod_nv_to_stack:            # (NV-TO-STACK n)
  6904.               { var reg4 uintL n;
  6905.                 U_operand(n);
  6906.                 # Test auf Stacküberlauf:
  6907.                 get_space_on_STACK(n*sizeof(object));
  6908.                 # n Werte in den Stack schieben:
  6909.                {var reg7 uintC count = mv_count;
  6910.                 if (n==0) goto nv_to_stack_end; # kein Wert gewünscht -> fertig
  6911.                 # mindestens 1 Wert gewünscht
  6912.                 pushSTACK(value1);
  6913.                 n--; if (n==0) goto nv_to_stack_end; # nur 1 Wert gewünscht -> fertig
  6914.                 if (count<=1) goto nv_to_stack_fill; # nur 1 Wert vorhanden -> mit NILs auffüllen
  6915.                 count--;
  6916.                 # mindestens 2 Werte gewünscht und vorhanden
  6917.                 { var reg2 object* mvp = &mv_space[1];
  6918.                   loop
  6919.                     { pushSTACK(*mvp++);
  6920.                       n--; if (n==0) goto nv_to_stack_end; # kein Wert mehr gewünscht -> fertig
  6921.                       count--; if (count==0) goto nv_to_stack_fill; # kein Wert mehr vorhanden -> mit NILs auffüllen
  6922.                 }   }
  6923.                 nv_to_stack_fill: # Auffüllen mit n>0 NILs als zusätzlichen Werten:
  6924.                 dotimespL(n,n, { pushSTACK(NIL); } );
  6925.                 nv_to_stack_end: ;
  6926.               }}
  6927.               goto next_byte;
  6928.             CASE cod_mv_to_list:             # (MV-TO-LIST)
  6929.               with_saved_context(
  6930.                 # Werte auf den Stack schieben und daraus Liste basteln:
  6931.                 mv_to_list();
  6932.                 );
  6933.               value1 = popSTACK(); mv_count=1;
  6934.               goto next_byte;
  6935.             CASE cod_list_to_mv:             # (LIST-TO-MV)
  6936.               list_to_mv(value1, { goto fehler_zuviele_werte; } );
  6937.               goto next_byte;
  6938.             CASE cod_mvcallp:                # (MVCALLP)
  6939.               pushSP((aint)STACK); # STACK retten
  6940.               pushSTACK(value1); # auszuführende Funktion retten
  6941.               goto next_byte;
  6942.             CASE cod_mvcall:                 # (MVCALL)
  6943.               { var reg2 object* FRAME; popSP( FRAME = (object*) ); # Pointer über Argumente und Funktion
  6944.                {var reg7 object fun = NEXT(FRAME); # Funktion
  6945.                 with_saved_context(
  6946.                   {var reg4 uintL argcount = # Anzahl der Argumente auf dem Stack
  6947.                      STACK_item_count(STACK,FRAME);
  6948.                    if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
  6949.                      fehler_zuviel_caller(fun,S(multiple_value_call));
  6950.                    # Funktion anwenden, Stack anheben bis unter die Funktion:
  6951.                    funcall(fun,argcount);
  6952.                    skipSTACK(1); # Funktion aus dem STACK streichen
  6953.                   });
  6954.               }}
  6955.               goto next_byte;
  6956.             # ------------------- (10) BLOCK -----------------------
  6957.             CASE cod_block_open:             # (BLOCK-OPEN n label)
  6958.               # belegt 3 STACK-Einträge und 1 SP-jmp_buf-Eintrag und 2 SP-Einträge
  6959.               { var reg4 uintL n;
  6960.                 var reg7 sintL label_dist;
  6961.                 U_operand(n);
  6962.                 S_operand(label_dist);
  6963.                 # Block_Cons erzeugen:
  6964.                {var reg2 object block_cons;
  6965.                 with_saved_context(
  6966.                   block_cons = allocate_cons();
  6967.                   label_dist += index; # CODEPTR+label_dist ist das Sprungziel
  6968.                   );
  6969.                 # Block-Cons füllen: (CONST n) als CAR
  6970.                 Car(block_cons) = TheCclosure(closure)->clos_consts[n];
  6971.                 # Sprungziel in den SP:
  6972.                 pushSP(label_dist); pushSP((aint)closureptr);
  6973.                 # CBLOCK-Frame aufbauen:
  6974.                 { var reg7 object* top_of_frame = STACK; # Pointer übern Frame
  6975.                   pushSTACK(block_cons); # Cons ( (CONST n) . ...)
  6976.                  {var reg4 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
  6977.                   finish_entry_frame_1(CBLOCK,returner, goto block_return; );
  6978.                 }}
  6979.                 # Framepointer im Block-Cons ablegen:
  6980.                 Cdr(block_cons) = make_framepointer(STACK);
  6981.               }}
  6982.               goto next_byte;
  6983.               block_return: # Hierher wird gesprungen, wenn der oben aufgebaute
  6984.                             # CBLOCK-Frame ein RETURN-FROM gefangen hat.
  6985.               { FREE_JMPBUF_on_SP();
  6986.                 skipSTACK(2); # CBLOCK-Frame auflösen, dabei
  6987.                 Cdr(popSTACK()) = disabled; # Block-Cons als Disabled markieren
  6988.                {var reg2 uintL index;
  6989.                 # closure zurück, byteptr:=label_byteptr :
  6990.                 popSP(closureptr = (object*) ); popSP(index = );
  6991.                 closure = *closureptr; # Closure aus dem Stack holen
  6992.                 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
  6993.                 byteptr = CODEPTR + index;
  6994.               }}
  6995.               goto next_byte; # am Label weiterinterpretieren
  6996.             CASE cod_block_close:            # (BLOCK-CLOSE)
  6997.               # CBLOCK-Frame auflösen:
  6998.               #if STACKCHECKC
  6999.               if (!(mtypecode(STACK_0) == CBLOCK_frame_info))
  7000.                 goto fehler_STACK_putt;
  7001.               #endif
  7002.               { FREE_JMPBUF_on_SP();
  7003.                 skipSTACK(2); # CBLOCK-Frame auflösen, dabei
  7004.                 Cdr(popSTACK()) = disabled; # Block-Cons als Disabled markieren
  7005.                 skipSP(2); # Ziel-Closureptr und Ziel-Label kennen wir
  7006.               }
  7007.               goto next_byte; # am Label gleich weiterinterpretieren
  7008.             CASE cod_return_from:            # (RETURN-FROM n)
  7009.               { var reg4 uintL n;
  7010.                 U_operand(n);
  7011.                {var reg2 object block_cons = TheCclosure(closure)->clos_consts[n];
  7012.                 if (eq(Cdr(block_cons),disabled))
  7013.                   { fehler_block_left(Car(block_cons)); }
  7014.                 # Bis zum Block-Frame unwinden, dann seine Routine zum Auflösen anspringen:
  7015.                 #ifndef FAST_SP
  7016.                 FREE_DYNAMIC_ARRAY(private_SP_space);
  7017.                 #endif
  7018.                 unwind_upto(uTheFramepointer(Cdr(block_cons)));
  7019.               }}
  7020.             CASE cod_return_from_i:          # (RETURN-FROM-I k n)
  7021.               { var reg4 uintL k;
  7022.                 var reg4 uintL n;
  7023.                 U_operand(k);
  7024.                 U_operand(n);
  7025.                {var reg2 object* FRAME = (object*) SP_(k);
  7026.                 var reg2 object block_cons = FRAME_(n);
  7027.                 if (eq(Cdr(block_cons),disabled))
  7028.                   { fehler_block_left(Car(block_cons)); }
  7029.                 # Bis zum Block-Frame unwinden, dann seine Routine zum Auflösen anspringen:
  7030.                 #ifndef FAST_SP
  7031.                 FREE_DYNAMIC_ARRAY(private_SP_space);
  7032.                 #endif
  7033.                 unwind_upto(uTheFramepointer(Cdr(block_cons)));
  7034.               }}
  7035.             # ------------------- (11) TAGBODY -----------------------
  7036.             CASE cod_tagbody_open:           # (TAGBODY-OPEN n label1 ... labelm)
  7037.               # belegt 3+m STACK-Einträge und 1 SP-jmp_buf-Eintrag und 1 SP-Eintrag
  7038.               { var reg7 uintL n;
  7039.                 U_operand(n);
  7040.                 # Tagbody-Cons erzeugen:
  7041.                {var reg2 object tagbody_cons;
  7042.                 with_saved_context(
  7043.                   tagbody_cons = allocate_cons();
  7044.                   );
  7045.                 # Tagbody-Cons füllen: Tag-Vektor (CONST n) als CAR
  7046.                 {var reg6 object tag_vector = TheCclosure(closure)->clos_consts[n];
  7047.                  var reg7 uintL m = TheSvector(tag_vector)->length;
  7048.                  Car(tagbody_cons) = tag_vector;
  7049.                  get_space_on_STACK(m*sizeof(object)); # Platz reservieren
  7050.                 # alle labeli als Fixnums auf den STACK legen:
  7051.                  {var reg4 uintL count;
  7052.                   dotimespL(count,m,
  7053.                     { var reg2 uintB* label_byteptr;
  7054.                       L_operand(label_byteptr);
  7055.                       pushSTACK(fixnum(label_byteptr - CODEPTR));
  7056.                     });
  7057.                 }}
  7058.                 # Sprungziel in den SP:
  7059.                 pushSP((aint)closureptr);
  7060.                 # CTAGBODY-Frame aufbauen:
  7061.                 { var reg9 object* top_of_frame = STACK; # Pointer übern Frame
  7062.                   pushSTACK(tagbody_cons); # Cons ( (CONST n) . ...)
  7063.                  {var reg4 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
  7064.                   finish_entry_frame_1(CTAGBODY,returner, goto tagbody_go; );
  7065.                 }}
  7066.                 # Framepointer im Tagbody-Cons ablegen:
  7067.                 Cdr(tagbody_cons) = make_framepointer(STACK);
  7068.               }}
  7069.               goto next_byte;
  7070.               tagbody_go: # Hierher wird gesprungen, wenn der oben aufgebaute
  7071.                           # CTAGBODY-Frame ein GO zum Label Nummer i gefangen hat.
  7072.               { var reg7 uintL m = TheSvector(Car(STACK_2))->length; # Anzahl der Labels
  7073.                 # (Könnte auch das obige m als 'auto' deklarieren und hier benutzen.)
  7074.                 var reg4 uintL i = posfixnum_to_L(value1); # Nummer des Labels
  7075.                 var reg2 uintL index = posfixnum_to_L(STACK_((m-i)+3)); # labeli
  7076.                 # closure zurück, byteptr:=labeli_byteptr :
  7077.                 closureptr = (object*) SP_(jmpbufsize+0);
  7078.                 closure = *closureptr; # Closure aus dem Stack holen
  7079.                 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
  7080.                 byteptr = CODEPTR + index;
  7081.               }
  7082.               goto next_byte; # am Label i weiterinterpretieren
  7083.             CASE cod_tagbody_close_nil:      # (TAGBODY-CLOSE-NIL)
  7084.               value1 = NIL; mv_count=1; # Wert des Tagbody ist NIL
  7085.             CASE cod_tagbody_close:          # (TAGBODY-CLOSE)
  7086.               # CTAGBODY-Frame auflösen:
  7087.               #if STACKCHECKC
  7088.               if (!(mtypecode(STACK_0) == CTAGBODY_frame_info))
  7089.                 goto fehler_STACK_putt;
  7090.               #endif
  7091.               { FREE_JMPBUF_on_SP();
  7092.                {var reg2 object tagbody_cons = STACK_2; # Tagbody-Cons
  7093.                 Cdr(tagbody_cons) = disabled; # als Disabled markieren
  7094.                 skipSTACK(3+TheSvector(Car(tagbody_cons))->length);
  7095.                 skipSP(1);
  7096.               }}
  7097.               goto next_byte;
  7098.             CASE cod_go:                     # (GO n l)
  7099.               { var reg7 uintL n;
  7100.                 var reg7 uintL l;
  7101.                 U_operand(n);
  7102.                 U_operand(l);
  7103.                {var reg2 object tagbody_cons = # (CONST n)
  7104.                   TheCclosure(closure)->clos_consts[n];
  7105.                 if (eq(Cdr(tagbody_cons),disabled))
  7106.                   { var reg8 object tag_vector = Car(tagbody_cons);
  7107.                     pushSTACK(tag_vector);
  7108.                     pushSTACK(TheSvector(tag_vector)->data[l]); # Marke l
  7109.                     pushSTACK(S(go));
  7110.                     //: DEUTSCH "(~ ~): Der Tagbody mit den Marken ~ wurde bereits verlassen."
  7111.                     //: ENGLISH "(~ ~): the tagbody of the tags ~ has already been left"
  7112.                     //: FRANCAIS "(~ ~): Le «tagbody» avec les marqueurs ~ a déjà été quitté."
  7113.                     fehler(control_error, GETTEXT("(~ ~): the tagbody of the tags ~ has already been left"));
  7114.                   }
  7115.                 # Übergabewert an den Tagbody:
  7116.                 # Bei CTAGBODY-Frames 1+l als Fixnum,
  7117.                 # bei ITAGBODY-Frames die Formenliste zu Tag Nummer l.
  7118.                 {var reg4 object* FRAME = uTheFramepointer(Cdr(tagbody_cons));
  7119.                  value1 = (mtypecode(FRAME_(0)) == CTAGBODY_frame_info
  7120.                            ? fixnum(1+l)
  7121.                            : FRAME_(frame_bindings+2*l+1)
  7122.                           );
  7123.                  mv_count=1;
  7124.                  # Bis zum Tagbody-Frame unwinden, dann seine Routine anspringen,
  7125.                  # die zum Label l springt:
  7126.                  #ifndef FAST_SP
  7127.                  FREE_DYNAMIC_ARRAY(private_SP_space);
  7128.                  #endif
  7129.                  unwind_upto(FRAME);
  7130.               }}}
  7131.             CASE cod_go_i:                   # (GO-I k n l)
  7132.               { var reg7 uintL k;
  7133.                 var reg7 uintL n;
  7134.                 var reg7 uintL l;
  7135.                 U_operand(k);
  7136.                 U_operand(n);
  7137.                 U_operand(l);
  7138.                {var reg2 object* FRAME = (object*) SP_(k);
  7139.                 var reg2 object tagbody_cons = FRAME_(n);
  7140.                 if (eq(Cdr(tagbody_cons),disabled))
  7141.                   { var reg8 object tag_vector = Car(tagbody_cons);
  7142.                     pushSTACK(tag_vector);
  7143.                     pushSTACK(TheSvector(tag_vector)->data[l]); # Marke l
  7144.                     pushSTACK(S(go));
  7145.                     //: DEUTSCH "(~ ~): Der Tagbody mit den Marken ~ wurde bereits verlassen."
  7146.                     //: ENGLISH "(~ ~): the tagbody of the tags ~ has already been left"
  7147.                     //: FRANCAIS "(~ ~): Le «tagbody» avec les marqueurs ~ a déjà été quitté."
  7148.                     fehler(control_error, GETTEXT("(~ ~): the tagbody of the tags ~ has already been left"));
  7149.                   }
  7150.                 # Übergabewert an den Tagbody:
  7151.                 # Bei CTAGBODY-Frames 1+l als Fixnum.
  7152.                 {var reg4 object* FRAME = uTheFramepointer(Cdr(tagbody_cons));
  7153.                  value1 = fixnum(1+l); mv_count=1;
  7154.                  # Bis zum Tagbody-Frame unwinden, dann seine Routine anspringen,
  7155.                  # die zum Label l springt:
  7156.                  #ifndef FAST_SP
  7157.                  FREE_DYNAMIC_ARRAY(private_SP_space);
  7158.                  #endif
  7159.                  unwind_upto(FRAME);
  7160.               }}}
  7161.             # ------------------- (12) CATCH und THROW -----------------------
  7162.             CASE cod_catch_open:             # (CATCH-OPEN label)
  7163.               # belegt 3 STACK-Einträge und 1 SP-jmp_buf-Eintrag und 2 SP-Einträge
  7164.               { var reg2 uintB* label_byteptr;
  7165.                 L_operand(label_byteptr);
  7166.                 # closureptr, label_byteptr retten:
  7167.                 pushSP(label_byteptr - CODEPTR); pushSP((aint)closureptr);
  7168.               } # Frame aufbauen:
  7169.               { var reg4 object* top_of_frame = STACK;
  7170.                 pushSTACK(value1); # Tag
  7171.                {var reg2 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
  7172.                 finish_entry_frame_1(CATCH,returner, goto catch_return; );
  7173.               }}
  7174.               goto next_byte;
  7175.               catch_return: # Hierher wird gesprungen, wenn der oben aufgebaute
  7176.                             # Catch-Frame einen Throw gefangen hat.
  7177.               { FREE_JMPBUF_on_SP();
  7178.                 skipSTACK(3); # CATCH-Frame auflösen
  7179.                {var reg2 uintL index;
  7180.                 # closure zurück, byteptr:=label_byteptr :
  7181.                 popSP(closureptr = (object*) ); popSP(index = );
  7182.                 closure = *closureptr; # Closure aus dem Stack holen
  7183.                 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
  7184.                 byteptr = CODEPTR + index;
  7185.               }}
  7186.               goto next_byte; # am Label weiterinterpretieren
  7187.             CASE cod_catch_close:            # (CATCH-CLOSE)
  7188.               # Es muß ein CATCH-Frame kommen:
  7189.               #if STACKCHECKC
  7190.               if (!(mtypecode(STACK_0) == CATCH_frame_info))
  7191.                 goto fehler_STACK_putt;
  7192.               #endif
  7193.               FREE_JMPBUF_on_SP();
  7194.               #if STACKCHECKC
  7195.               if (!(closureptr == (object*)SP_(0))) # dort stehender Closureptr muß der jetzige sein
  7196.                 goto fehler_STACK_putt;
  7197.               #endif
  7198.               skipSP(2); skipSTACK(3); # CATCH-Frame auflösen
  7199.               goto next_byte;
  7200.             CASE cod_throw:                  # (THROW)
  7201.               { var reg2 object tag = popSTACK();
  7202.                 throw(tag);
  7203.                 pushSTACK(tag);
  7204.                 pushSTACK(S(throw));
  7205.                 //: DEUTSCH "~: Es gibt kein CATCH zur Marke ~."
  7206.                 //: ENGLISH "~: There is no CATCHer for tag ~"
  7207.                 //: FRANCAIS "~: Il n'y a pas de CATCH pour le marqueur ~."
  7208.                 fehler(control_error, GETTEXT("~: There is no CATCHer for tag ~"));
  7209.               }
  7210.             # ------------------- (13) UNWIND-PROTECT -----------------------
  7211.             CASE cod_uwp_open:               # (UNWIND-PROTECT-OPEN label)
  7212.               # belegt 2 STACK-Einträge und 1 SP-jmp_buf-Eintrag und 2 SP-Einträge
  7213.               { var reg2 uintB* label_byteptr;
  7214.                 L_operand(label_byteptr);
  7215.                 # closureptr, label_byteptr retten:
  7216.                 pushSP(label_byteptr - CODEPTR); pushSP((aint)closureptr);
  7217.               } # Frame aufbauen:
  7218.               { var reg4 object* top_of_frame = STACK;
  7219.                 var reg2 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
  7220.                 finish_entry_frame_1(UNWIND_PROTECT,returner, goto throw_save; );
  7221.               }
  7222.               goto next_byte;
  7223.               throw_save: # Hierher wird gesprungen, wenn der oben aufgebaute
  7224.                           # Unwind-Protect-Frame einen Throw aufgehalten hat.
  7225.               # unwind_protect_to_save ist zu retten und am Schluß anzuspringen.
  7226.               #if STACKCHECKC
  7227.               if (!(mtypecode(STACK_0) == UNWIND_PROTECT_frame_info))
  7228.                   //: DEUTSCH "STACK kaputt."
  7229.                   //: ENGLISH "STACK corrupted"
  7230.                   //: FRANCAIS "Pile STACK est corrompue."
  7231.                 { fehler(serious_condition, GETTEXT("STACK corrupted"));
  7232.                 }
  7233.               #endif
  7234.               # Frame auflösen:
  7235.               FREE_JMPBUF_on_SP();
  7236.               skipSTACK(2);
  7237.               { var reg2 uintL index;
  7238.                 # closure zurück, byteptr:=label_byteptr :
  7239.                 popSP(closureptr = (object*) );
  7240.                 popSP(index = );
  7241.                 # unwind_protect_to_save retten:
  7242.                 pushSP((aint)unwind_protect_to_save.fun);
  7243.                 pushSP((aint)unwind_protect_to_save.upto_frame);
  7244.                 pushSP((aint)STACK); # Pointer übern Frame zusätzlich auf den SP
  7245.                 # alle Werte auf den Stack:
  7246.                 mv_to_STACK();
  7247.                 # Cleanup-Formen ausführen:
  7248.                 closure = *closureptr; # Closure aus dem Stack holen
  7249.                 codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
  7250.                 byteptr = CODEPTR + index;
  7251.               }
  7252.               goto next_byte;
  7253.             CASE cod_uwp_normal_exit:        # (UNWIND-PROTECT-NORMAL-EXIT)
  7254.               #if STACKCHECKC
  7255.               if (!(mtypecode(STACK_0) == UNWIND_PROTECT_frame_info))
  7256.                 goto fehler_STACK_putt;
  7257.               if (!(closureptr == (object*)SP_(jmpbufsize+0))) # dort stehender Closureptr muß der jetzige sein
  7258.                 goto fehler_STACK_putt;
  7259.               #endif
  7260.               # Frame auflösen:
  7261.               # Nichts zu tun, da closure und byteptr unverändert bleiben.
  7262.               FREE_JMPBUF_on_SP(); skipSP(2);
  7263.               skipSTACK(2);
  7264.               # Dummy-Werte für 'unwind_protect_to_save':
  7265.               pushSP((aint)NULL); pushSP((aint)NULL); # NULL,NULL -> uwp_continue
  7266.               pushSP((aint)STACK); # Pointer übern Frame zusätzlich auf den SP
  7267.               # alle Werte auf den Stack:
  7268.               mv_to_STACK();
  7269.               # Cleanup-Formen ausführen:
  7270.               goto next_byte;
  7271.             CASE cod_uwp_close:              # (UNWIND-PROTECT-CLOSE)
  7272.               # Hierher wird am Ende der Cleanup-Formen gesprungen.
  7273.               { var reg4 object* oldSTACK; # Wert von STACK vor dem Retten der Werte
  7274.                 popSP( oldSTACK = (object*) );
  7275.                {var reg2 uintL mvcount = # Anzahl der geretteten Werte auf dem Stack
  7276.                   STACK_item_count(STACK,oldSTACK);
  7277.                 if (mvcount >= mv_limit) goto fehler_zuviele_werte;
  7278.                 STACK_to_mv(mvcount);
  7279.               }}
  7280.               # Rücksprung zum geretteten unwind_protect_to_save.fun :
  7281.               { var reg4 restart fun;
  7282.                 var reg2 object* arg;
  7283.                 popSP( arg = (object*) ); popSP( fun = (restart) );
  7284.                 # Rücksprung zu uwp_continue oder uwp_jmpback oder unwind_upto:
  7285.                 if (!(fun == (restart)NULL))
  7286.                   { (*fun)(arg); NOTREACHED } # Rücksprung zu unwind_upto o.ä.
  7287.                 if (arg == (object*)NULL)
  7288.                   { # uwp_continue:
  7289.                     # Hierher wird gesprungen, wenn nach dem Ausführen der
  7290.                     # Cleanup-Formen einfach weiterinterpretiert werden soll.
  7291.                     goto next_byte;
  7292.                   }
  7293.                   else
  7294.                   { # uwp_jmpback:
  7295.                     # Hierher wird gesprungen, wenn nach dem Ausführen der
  7296.                     # Cleanup-Formen an der alten Stelle in derselben Closure
  7297.                     # weiterinterpretiert werden soll.
  7298.                     byteptr = CODEPTR + (uintP)arg;
  7299.                     goto next_byte;
  7300.               }   }
  7301.             CASE cod_uwp_cleanup:            # (UNWIND-PROTECT-CLEANUP)
  7302.               # Dies wird ausgeführt, wenn innerhalb derselben Closure ein
  7303.               # Ausführen des Cleanup-Codes nötig ist.
  7304.               #if STACKCHECKC
  7305.               if (!(mtypecode(STACK_0) == UNWIND_PROTECT_frame_info))
  7306.                 goto fehler_STACK_putt;
  7307.               if (!(closureptr == (object*)SP_(jmpbufsize+0))) # dort stehender Closureptr muß der jetzige sein
  7308.                 goto fehler_STACK_putt;
  7309.               #endif
  7310.               # closure bleibt, byteptr:=label_byteptr :
  7311.               { var reg2 uintL index = SP_(jmpbufsize+1);
  7312.                 # Frame auflösen:
  7313.                 FREE_JMPBUF_on_SP(); skipSP(2);
  7314.                 skipSTACK(2);
  7315.                 # Dummy-Werte für 'unwind_protect_to_save':
  7316.                 pushSP((aint)NULL); # NULL -> uwp_jmpback
  7317.                 pushSP(byteptr - CODEPTR);
  7318.                 pushSP((aint)STACK); # Pointer übern Frame zusätzlich auf den SP
  7319.                 # alle Werte auf den Stack:
  7320.                 mv_to_STACK();
  7321.                 # Cleanup-Formen ausführen:
  7322.                 byteptr = CODEPTR + index;
  7323.               }
  7324.               goto next_byte;
  7325.             # ------------------- (14) HANDLER-BIND -----------------------
  7326.             CASE cod_handler_open:           # (HANDLER-OPEN n)
  7327.               # belegt 4 STACK-Einträge
  7328.               { var reg2 uintL n;
  7329.                 U_operand(n);
  7330.                 # Frame aufbauen:
  7331.                {var reg5 object* top_of_frame = STACK; # Pointer übern Frame
  7332.                 pushSTACK(TheCclosure(closure)->clos_consts[n]);
  7333.                 pushSTACK(closure);
  7334.                 pushSTACK(as_object((aint)(_SP_(0))));
  7335.                 finish_frame(HANDLER);
  7336.               }}
  7337.               goto next_byte;
  7338.             CASE cod_handler_begin_push:      # (HANDLER-BEGIN&PUSH)
  7339.               # baut SP neu auf, belegt 1 SP-Eintrag und
  7340.               # beginnt einen neuen STACK-Bereich.
  7341.               { var reg5 uintL count = handler_args.spdepth;
  7342.                 if (count > 0)
  7343.                   { var reg2 SPint* oldsp = handler_args.sp; # war früher &SP_(0)
  7344.                     # oldsp[0..count-1] auf den jetzigen SP kopieren:
  7345.                     oldsp skipSPop count;
  7346.                     dotimespL(count,count, { oldsp skipSPop -1; pushSP(*oldsp); } );
  7347.               }   }
  7348.               pushSP((aint)handler_args.stack); # Pointer übern Handler-Frame
  7349.               value1 = handler_args.condition; mv_count=1;
  7350.               pushSTACK(value1);
  7351.               goto next_byte;
  7352.             # ------------------- (15) einige Funktionen -----------------------
  7353.             CASE cod_not:                    # (NOT)
  7354.               if (nullp(value1)) goto code_t; else goto code_nil;
  7355.             CASE cod_eq:                     # (EQ)
  7356.               if (!eq(value1,popSTACK())) goto code_nil; else goto code_t;
  7357.             CASE cod_car:                    # (CAR)
  7358.               { var reg2 object arg = value1;
  7359.                 if (consp(arg)) { value1 = Car(arg); } # CAR eines Cons
  7360.                 elif (nullp(arg)) {} # (CAR NIL) = NIL: value1 bleibt NIL
  7361.                 else { subr_self = L(car); fehler_list(arg); }
  7362.                 mv_count=1;
  7363.               }
  7364.               goto next_byte;
  7365.             CASE cod_car_push:               # (CAR&PUSH)
  7366.               { var reg2 object arg = value1;
  7367.                 if (consp(arg)) { pushSTACK(Car(arg)); } # CAR eines Cons
  7368.                 elif (nullp(arg)) { pushSTACK(arg); } # (CAR NIL) = NIL
  7369.                 else { subr_self = L(car); fehler_list(arg); }
  7370.               }
  7371.               goto next_byte;
  7372.             CASE cod_load_car_push:          # (LOAD&CAR&PUSH n)
  7373.               { var reg4 uintL n;
  7374.                 U_operand(n);
  7375.                {var reg2 object arg = STACK_(n);
  7376.                 if (consp(arg)) { pushSTACK(Car(arg)); } # CAR eines Cons
  7377.                 elif (nullp(arg)) { pushSTACK(arg); } # (CAR NIL) = NIL
  7378.                 else { subr_self = L(car); fehler_list(arg); }
  7379.               }}
  7380.               goto next_byte;
  7381.             CASE cod_load_car_store:         # (LOAD&CAR&STORE m n)
  7382.               { var reg7 uintL m;
  7383.                 var reg4 uintL n;
  7384.                 U_operand(m);
  7385.                 U_operand(n);
  7386.                {var reg2 object arg = STACK_(m);
  7387.                 if (consp(arg)) { STACK_(n) = value1 = Car(arg); } # CAR eines Cons
  7388.                 elif (nullp(arg)) { STACK_(n) = value1 = arg; } # (CAR NIL) = NIL
  7389.                 else { subr_self = L(car); fehler_list(arg); }
  7390.                 mv_count=1;
  7391.               }}
  7392.               goto next_byte;
  7393.             CASE cod_cdr:                    # (CDR)
  7394.               { var reg2 object arg = value1;
  7395.                 if (consp(arg)) { value1 = Cdr(arg); } # CDR eines Cons
  7396.                 elif (nullp(arg)) {} # (CDR NIL) = NIL: value1 bleibt NIL
  7397.                 else { subr_self = L(cdr); fehler_list(arg); }
  7398.                 mv_count=1;
  7399.               }
  7400.               goto next_byte;
  7401.             CASE cod_cdr_push:               # (CDR&PUSH)
  7402.               { var reg2 object arg = value1;
  7403.                 if (consp(arg)) { pushSTACK(Cdr(arg)); } # CDR eines Cons
  7404.                 elif (nullp(arg)) { pushSTACK(arg); } # (CDR NIL) = NIL
  7405.                 else { subr_self = L(cdr); fehler_list(arg); }
  7406.               }
  7407.               goto next_byte;
  7408.             CASE cod_load_cdr_push:          # (LOAD&CDR&PUSH n)
  7409.               { var reg4 uintL n;
  7410.                 U_operand(n);
  7411.                {var reg2 object arg = STACK_(n);
  7412.                 if (consp(arg)) { pushSTACK(Cdr(arg)); } # CDR eines Cons
  7413.                 elif (nullp(arg)) { pushSTACK(arg); } # (CDR NIL) = NIL
  7414.                 else { subr_self = L(cdr); fehler_list(arg); }
  7415.               }}
  7416.               goto next_byte;
  7417.             CASE cod_load_cdr_store:         # (LOAD&CDR&STORE n)
  7418.               { var reg4 uintL n;
  7419.                 U_operand(n);
  7420.                {var reg4 object* arg_ = &STACK_(n);
  7421.                 var reg2 object arg = *arg_;
  7422.                 if (consp(arg)) { *arg_ = value1 = Cdr(arg); } # CDR eines Cons
  7423.                 elif (nullp(arg)) { value1 = arg; } # (CDR NIL) = NIL
  7424.                 else { subr_self = L(cdr); fehler_list(arg); }
  7425.                 mv_count=1;
  7426.               }}
  7427.               goto next_byte;
  7428.             CASE cod_cons:                   # (CONS)
  7429.               pushSTACK(value1);
  7430.               # Cons anfordern:
  7431.               {var reg2 object new_cons;
  7432.                with_saved_context( { new_cons = allocate_cons(); } );
  7433.                # Cons füllen:
  7434.                Cdr(new_cons) = popSTACK();
  7435.                Car(new_cons) = popSTACK();
  7436.                value1 = new_cons; mv_count=1;
  7437.               }
  7438.               goto next_byte;
  7439.             CASE cod_cons_push:              # (CONS&PUSH)
  7440.               pushSTACK(value1);
  7441.               # Cons anfordern:
  7442.               {var reg2 object new_cons;
  7443.                with_saved_context( { new_cons = allocate_cons(); } );
  7444.                # Cons füllen:
  7445.                Cdr(new_cons) = popSTACK();
  7446.                Car(new_cons) = STACK_0;
  7447.                STACK_0 = new_cons;
  7448.               }
  7449.               goto next_byte;
  7450.             CASE cod_load_cons_store:        # (LOAD&CONS&STORE n)
  7451.               { var reg4 uintL n;
  7452.                 U_operand(n);
  7453.                 # Cons anfordern:
  7454.                {var reg2 object new_cons;
  7455.                 with_saved_context( { new_cons = allocate_cons(); } );
  7456.                 # Cons füllen:
  7457.                 Car(new_cons) = popSTACK();
  7458.                 {var reg4 object* arg_ = &STACK_(n);
  7459.                  Cdr(new_cons) = *arg_;
  7460.                  value1 = *arg_ = new_cons; mv_count=1;
  7461.               }}}
  7462.               goto next_byte;
  7463.             {var reg2 object symbol;
  7464.             CASE cod_symbol_function:        # (SYMBOL-FUNCTION)
  7465.               symbol = value1;
  7466.               if (!symbolp(symbol)) goto csf_kein_symbol;
  7467.               if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
  7468.               value1 = Symbol_function(symbol); mv_count=1;
  7469.               goto next_byte;
  7470.             CASE cod_const_symbol_function:  # (CONST&SYMBOL-FUNCTION n)
  7471.               {var reg4 uintL n;
  7472.                U_operand(n);
  7473.                symbol = TheCclosure(closure)->clos_consts[n];
  7474.               }
  7475.               if (!symbolp(symbol)) goto csf_kein_symbol;
  7476.               if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
  7477.               value1 = Symbol_function(symbol); mv_count=1;
  7478.               goto next_byte;
  7479.             CASE cod_const_symbol_function_push: # (CONST&SYMBOL-FUNCTION&PUSH n)
  7480.               {var reg4 uintL n;
  7481.                U_operand(n);
  7482.                symbol = TheCclosure(closure)->clos_consts[n];
  7483.               }
  7484.               if (!symbolp(symbol)) goto csf_kein_symbol;
  7485.               if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
  7486.               pushSTACK(Symbol_function(symbol));
  7487.               goto next_byte;
  7488.             CASE cod_const_symbol_function_store: # (CONST&SYMBOL-FUNCTION&STORE n k)
  7489.               {var reg4 uintL n;
  7490.                U_operand(n);
  7491.                symbol = TheCclosure(closure)->clos_consts[n];
  7492.               }
  7493.               if (!symbolp(symbol)) goto csf_kein_symbol;
  7494.               if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
  7495.               {var reg4 uintL k;
  7496.                U_operand(k);
  7497.                STACK_(k) = value1 = Symbol_function(symbol); mv_count=1;
  7498.               }
  7499.               goto next_byte;
  7500.             csf_kein_symbol:
  7501.               fehler_kein_symbol(S(symbol_function),symbol);
  7502.             csf_unbound:
  7503.               pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
  7504.               # (Das ist zwar evtl. nicht der eigentliche Funktionsname, denn
  7505.               # z.B. (FUNCTION FOO) wird in (SYMBOL-FUNCTION '#:|(SETF FOO)|)
  7506.               # umgewandelt, aber für die Fehlermeldung reicht das wohl.)
  7507.               pushSTACK(symbol);
  7508.               pushSTACK(S(symbol_function));
  7509.               //: DEUTSCH "~: ~ hat keine Funktionsdefinition."
  7510.               //: ENGLISH "~: the function ~ is undefined"
  7511.               //: FRANCAIS "~: la fonction ~ n'est pas définie."
  7512.               fehler(undefined_function, GETTEXT("~: the function ~ is undefined"));
  7513.             }
  7514.             {var reg2 object vec; var reg4 object index;
  7515.             CASE cod_svref:                  # (SVREF)
  7516.               # STACK_0 muß ein Simple-Vector sein:
  7517.               if (!m_simple_vector_p(STACK_0)) goto svref_kein_svector;
  7518.               vec = popSTACK(); # Simple-Vector
  7519.               index = value1;
  7520.               # und der Index muß ein Fixnum >=0, <Länge(vec) sein:
  7521.               {var reg7 uintL i;
  7522.                if (!(posfixnump(index) &&
  7523.                      ((i = posfixnum_to_L(index)) < TheSvector(vec)->length)
  7524.                   ) )
  7525.                  goto svref_kein_index;
  7526.                value1 = TheSvector(vec)->data[i]; # indiziertes Element als Wert
  7527.                mv_count = 1;
  7528.               }
  7529.               goto next_byte;
  7530.             CASE cod_svset:                  # (SVSET)
  7531.               # STACK_0 muß ein Simple-Vector sein:
  7532.               if (!m_simple_vector_p(STACK_0)) goto svref_kein_svector;
  7533.               vec = popSTACK(); # Simple-Vector
  7534.               index = value1;
  7535.               # und der Index muß ein Fixnum >=0, <Länge(vec) sein:
  7536.               {var reg7 uintL i;
  7537.                if (!(posfixnump(index) &&
  7538.                      ((i = posfixnum_to_L(index)) < TheSvector(vec)->length)
  7539.                   ) )
  7540.                  goto svref_kein_index;
  7541.                value1 = TheSvector(vec)->data[i] = popSTACK(); # neues Element hineinstecken
  7542.                mv_count = 1;
  7543.               }
  7544.               goto next_byte;
  7545.             svref_kein_svector: # Nicht-Simple-Vector in STACK_0
  7546.               fehler_kein_svector(S(svref),STACK_0);
  7547.             svref_kein_index: # unpassender Index in index, zum Vektor vec
  7548.               pushSTACK(vec);
  7549.               pushSTACK(index);
  7550.               pushSTACK(S(svref));
  7551.               //: DEUTSCH "~: ~ ist kein passender Index für ~"
  7552.               //: ENGLISH "~: ~ is not a correct index into ~"
  7553.               //: FRANCAIS "~: ~ n'est pas un index convenable dans ~."
  7554.               fehler(error, GETTEXT("~: ~ is not a correct index into ~"));
  7555.             }
  7556.             CASE cod_list:                   # (LIST n)
  7557.               { var reg2 uintC n;
  7558.                 U_operand(n);
  7559.                 with_saved_context( { value1 = listof(n); mv_count=1; } );
  7560.               }
  7561.               goto next_byte;
  7562.             CASE cod_list_push:              # (LIST&PUSH n)
  7563.               { var reg2 uintC n;
  7564.                 U_operand(n);
  7565.                 with_saved_context( { pushSTACK(listof(n)); } );
  7566.               }
  7567.               goto next_byte;
  7568.             CASE cod_liststern:              # (LIST* n)
  7569.               { var reg4 uintC n;
  7570.                 U_operand(n);
  7571.                 with_saved_context(
  7572.                   { pushSTACK(value1);
  7573.                     dotimespC(n,n,
  7574.                       { var reg2 object new_cons = allocate_cons();
  7575.                         Cdr(new_cons) = popSTACK();
  7576.                         Car(new_cons) = STACK_0;
  7577.                         STACK_0 = new_cons;
  7578.                       });
  7579.                     value1 = popSTACK(); mv_count=1;
  7580.                   });
  7581.               }
  7582.               goto next_byte;
  7583.             CASE cod_liststern_push:         # (LIST*&PUSH n)
  7584.               { var reg4 uintC n;
  7585.                 U_operand(n);
  7586.                 with_saved_context(
  7587.                   { pushSTACK(value1);
  7588.                     dotimespC(n,n,
  7589.                       { var reg2 object new_cons = allocate_cons();
  7590.                         Cdr(new_cons) = popSTACK();
  7591.                         Car(new_cons) = STACK_0;
  7592.                         STACK_0 = new_cons;
  7593.                       });
  7594.                   });
  7595.               }
  7596.               goto next_byte;
  7597.             # ------------------- (16) kombinierte Operationen -----------------------
  7598.             CASE cod_nil_store:              # (NIL&STORE n)
  7599.               {var reg1 uintL n;
  7600.                U_operand(n);
  7601.                STACK_(n) = value1 = NIL; mv_count=1;
  7602.               }
  7603.               goto next_byte;
  7604.             CASE cod_t_store:                # (T&STORE n)
  7605.               {var reg1 uintL n;
  7606.                U_operand(n);
  7607.                STACK_(n) = value1 = T; mv_count=1;
  7608.               }
  7609.               goto next_byte;
  7610.             CASE cod_calls1_store:           # (CALLS1&STORE n k)
  7611.               CALLS1();
  7612.               goto store;
  7613.             CASE cod_calls2_store:           # (CALLS2&STORE n k)
  7614.               CALLS2();
  7615.               goto store;
  7616.             CASE cod_callsr_store:           # (CALLSR&STORE m n k)
  7617.               CALLSR();
  7618.               goto store;
  7619.             # Incrementieren. Speziell optimiert für Fixnums >=0.
  7620.             #define INC(arg,statement)  \
  7621.               { if (posfixnump(arg) # Fixnum >= 0 und < most-positive-fixnum ? \
  7622.                     && !eq(arg,fixnum(bitm(oint_data_len)-1))                  \
  7623.                    )                                                           \
  7624.                   { arg = fixnum_inc(arg,1); statement; }                      \
  7625.                   else                                                         \
  7626.                   { with_saved_context(                                        \
  7627.                       { pushSTACK(arg); subr_self = L(einsplus); C_einsplus(); } # funcall(L(einsplus),1); \
  7628.                       );                                                       \
  7629.                     arg = value1;                                              \
  7630.               }   }
  7631.             # Decrementieren. Speziell optimiert für Fixnums >=0.
  7632.             #define DEC(arg,statement)  \
  7633.               { if (posfixnump(arg) && !eq(arg,Fixnum_0)) # Fixnum > 0 ? \
  7634.                   { arg = fixnum_inc(arg,-1); statement; }               \
  7635.                   else                                                   \
  7636.                   { with_saved_context(                                  \
  7637.                       { pushSTACK(arg); subr_self = L(einsminus); C_einsminus(); } # funcall(L(einsminus),1); \
  7638.                       );                                                 \
  7639.                     arg = value1;                                        \
  7640.               }   }
  7641.             CASE cod_load_inc_push:          # (LOAD&INC&PUSH n)
  7642.               { var reg4 uintL n;
  7643.                 U_operand(n);
  7644.                {var reg2 object arg = STACK_(n);
  7645.                 INC(arg,_EMA_); # incrementieren
  7646.                 pushSTACK(arg);
  7647.               }}
  7648.               goto next_byte;
  7649.             CASE cod_load_inc_store:         # (LOAD&INC&STORE n)
  7650.               { var reg4 uintL n;
  7651.                 U_operand(n);
  7652.                {var reg4 object* arg_ = &STACK_(n);
  7653.                 var reg2 object arg = *arg_;
  7654.                 INC(arg,mv_count=1); # incrementieren, 1 Wert
  7655.                 value1 = *arg_ = arg;
  7656.               }}
  7657.               goto next_byte;
  7658.             CASE cod_load_dec_push:          # (LOAD&DEC&PUSH n)
  7659.               { var reg4 uintL n;
  7660.                 U_operand(n);
  7661.                {var reg2 object arg = STACK_(n);
  7662.                 DEC(arg,_EMA_); # decrementieren
  7663.                 pushSTACK(arg);
  7664.               }}
  7665.               goto next_byte;
  7666.             CASE cod_load_dec_store:         # (LOAD&DEC&STORE n)
  7667.               { var reg4 uintL n;
  7668.                 U_operand(n);
  7669.                {var reg4 object* arg_ = &STACK_(n);
  7670.                 var reg2 object arg = *arg_;
  7671.                 DEC(arg,mv_count=1); # decrementieren, 1 Wert
  7672.                 value1 = *arg_ = arg;
  7673.               }}
  7674.               goto next_byte;
  7675.             CASE cod_call1_jmpif:            # (CALL1&JMPIF n label)
  7676.               CALL1();
  7677.               if (!nullp(value1)) goto jmp; else goto notjmp;
  7678.             CASE cod_call1_jmpifnot:         # (CALL1&JMPIFNOT n label)
  7679.               CALL1();
  7680.               if (nullp(value1)) goto jmp; else goto notjmp;
  7681.             CASE cod_call2_jmpif:            # (CALL2&JMPIF n label)
  7682.               CALL2();
  7683.               if (!nullp(value1)) goto jmp; else goto notjmp;
  7684.             CASE cod_call2_jmpifnot:         # (CALL2&JMPIFNOT n label)
  7685.               CALL2();
  7686.               if (nullp(value1)) goto jmp; else goto notjmp;
  7687.             CASE cod_calls1_jmpif:           # (CALLS1&JMPIF n label)
  7688.               CALLS1();
  7689.               if (!nullp(value1)) goto jmp; else goto notjmp;
  7690.             CASE cod_calls1_jmpifnot:        # (CALLS1&JMPIFNOT n label)
  7691.               CALLS1();
  7692.               if (nullp(value1)) goto jmp; else goto notjmp;
  7693.             CASE cod_calls2_jmpif:           # (CALLS2&JMPIF n label)
  7694.               CALLS2();
  7695.               if (!nullp(value1)) goto jmp; else goto notjmp;
  7696.             CASE cod_calls2_jmpifnot:        # (CALLS2&JMPIFNOT n label)
  7697.               CALLS2();
  7698.               if (nullp(value1)) goto jmp; else goto notjmp;
  7699.             CASE cod_callsr_jmpif:           # (CALLSR&JMPIF m n label)
  7700.               CALLSR();
  7701.               if (!nullp(value1)) goto jmp; else goto notjmp;
  7702.             CASE cod_callsr_jmpifnot:        # (CALLSR&JMPIFNOT m n label)
  7703.               CALLSR();
  7704.               if (nullp(value1)) goto jmp; else goto notjmp;
  7705.             CASE cod_load_jmpif:             # (LOAD&JMPIF n label)
  7706.               {var reg2 uintL n;
  7707.                U_operand(n);
  7708.                mv_count=1;
  7709.                if (!nullp(value1 = STACK_(n))) goto jmp; else goto notjmp;
  7710.               }
  7711.             CASE cod_load_jmpifnot:          # (LOAD&JMPIFNOT n label)
  7712.               {var reg2 uintL n;
  7713.                U_operand(n);
  7714.                mv_count=1;
  7715.                if (nullp(value1 = STACK_(n))) goto jmp; else goto notjmp;
  7716.               }
  7717.             CASE cod_apply_skip_ret:         # (APPLY&SKIP&RET n k)
  7718.               { var reg2 uintL n;
  7719.                 var reg5 uintL k;
  7720.                 U_operand(n);
  7721.                 U_operand(k);
  7722.                {var reg4 object fun = STACK_(n); # Funktion
  7723.                 with_saved_context(
  7724.                   { apply(fun,n,value1); # Funktion aufrufen
  7725.                     skipSTACK(k+1); # Funktion u.a. aus dem Stack streichen
  7726.                     goto finished; # Rücksprung zum Aufrufer
  7727.                   }); # der Kontext wird nicht restauriert
  7728.               }}
  7729.             # ------------------- (17) Kurzcodes -----------------------
  7730.             CASE cod_load0:                  # (LOAD.S 0)
  7731.               value1 = STACK_(0); mv_count=1;
  7732.               goto next_byte;
  7733.             CASE cod_load1:                  # (LOAD.S 1)
  7734.               value1 = STACK_(1); mv_count=1;
  7735.               goto next_byte;
  7736.             CASE cod_load2:                  # (LOAD.S 2)
  7737.               value1 = STACK_(2); mv_count=1;
  7738.               goto next_byte;
  7739.             CASE cod_load3:                  # (LOAD.S 3)
  7740.               value1 = STACK_(3); mv_count=1;
  7741.               goto next_byte;
  7742.             CASE cod_load4:                  # (LOAD.S 4)
  7743.               value1 = STACK_(4); mv_count=1;
  7744.               goto next_byte;
  7745.             CASE cod_load5:                  # (LOAD.S 5)
  7746.               value1 = STACK_(5); mv_count=1;
  7747.               goto next_byte;
  7748.             CASE cod_load6:                  # (LOAD.S 6)
  7749.               value1 = STACK_(6); mv_count=1;
  7750.               goto next_byte;
  7751.             CASE cod_load7:                  # (LOAD.S 7)
  7752.               value1 = STACK_(7); mv_count=1;
  7753.               goto next_byte;
  7754.             CASE cod_load8:                  # (LOAD.S 8)
  7755.               value1 = STACK_(8); mv_count=1;
  7756.               goto next_byte;
  7757.             CASE cod_load9:                  # (LOAD.S 9)
  7758.               value1 = STACK_(9); mv_count=1;
  7759.               goto next_byte;
  7760.             CASE cod_load10:                 # (LOAD.S 10)
  7761.               value1 = STACK_(10); mv_count=1;
  7762.               goto next_byte;
  7763.             CASE cod_load11:                 # (LOAD.S 11)
  7764.               value1 = STACK_(11); mv_count=1;
  7765.               goto next_byte;
  7766.             CASE cod_load12:                 # (LOAD.S 12)
  7767.               value1 = STACK_(12); mv_count=1;
  7768.               goto next_byte;
  7769.             CASE cod_load13:                 # (LOAD.S 13)
  7770.               value1 = STACK_(13); mv_count=1;
  7771.               goto next_byte;
  7772.             CASE cod_load14:                 # (LOAD.S 14)
  7773.               value1 = STACK_(14); mv_count=1;
  7774.               goto next_byte;
  7775.             #if 0
  7776.             CASE cod_load15:                 # (LOAD.S 15)
  7777.               value1 = STACK_(15); mv_count=1;
  7778.               goto next_byte;
  7779.             CASE cod_load16:                 # (LOAD.S 16)
  7780.               value1 = STACK_(16); mv_count=1;
  7781.               goto next_byte;
  7782.             CASE cod_load17:                 # (LOAD.S 17)
  7783.               value1 = STACK_(17); mv_count=1;
  7784.               goto next_byte;
  7785.             CASE cod_load18:                 # (LOAD.S 18)
  7786.               value1 = STACK_(18); mv_count=1;
  7787.               goto next_byte;
  7788.             CASE cod_load19:                 # (LOAD.S 19)
  7789.               value1 = STACK_(19); mv_count=1;
  7790.               goto next_byte;
  7791.             CASE cod_load20:                 # (LOAD.S 20)
  7792.               value1 = STACK_(20); mv_count=1;
  7793.               goto next_byte;
  7794.             CASE cod_load21:                 # (LOAD.S 21)
  7795.               value1 = STACK_(21); mv_count=1;
  7796.               goto next_byte;
  7797.             #endif
  7798.             CASE cod_load_push0:             # (LOAD&PUSH.S 0)
  7799.               pushSTACK(STACK_(0));
  7800.               goto next_byte;
  7801.             CASE cod_load_push1:             # (LOAD&PUSH.S 1)
  7802.               pushSTACK(STACK_(1));
  7803.               goto next_byte;
  7804.             CASE cod_load_push2:             # (LOAD&PUSH.S 2)
  7805.               pushSTACK(STACK_(2));
  7806.               goto next_byte;
  7807.             CASE cod_load_push3:             # (LOAD&PUSH.S 3)
  7808.               pushSTACK(STACK_(3));
  7809.               goto next_byte;
  7810.             CASE cod_load_push4:             # (LOAD&PUSH.S 4)
  7811.               pushSTACK(STACK_(4));
  7812.               goto next_byte;
  7813.             CASE cod_load_push5:             # (LOAD&PUSH.S 5)
  7814.               pushSTACK(STACK_(5));
  7815.               goto next_byte;
  7816.             CASE cod_load_push6:             # (LOAD&PUSH.S 6)
  7817.               pushSTACK(STACK_(6));
  7818.               goto next_byte;
  7819.             CASE cod_load_push7:             # (LOAD&PUSH.S 7)
  7820.               pushSTACK(STACK_(7));
  7821.               goto next_byte;
  7822.             CASE cod_load_push8:             # (LOAD&PUSH.S 8)
  7823.               pushSTACK(STACK_(8));
  7824.               goto next_byte;
  7825.             CASE cod_load_push9:             # (LOAD&PUSH.S 9)
  7826.               pushSTACK(STACK_(9));
  7827.               goto next_byte;
  7828.             CASE cod_load_push10:            # (LOAD&PUSH.S 10)
  7829.               pushSTACK(STACK_(10));
  7830.               goto next_byte;
  7831.             CASE cod_load_push11:            # (LOAD&PUSH.S 11)
  7832.               pushSTACK(STACK_(11));
  7833.               goto next_byte;
  7834.             CASE cod_load_push12:            # (LOAD&PUSH.S 12)
  7835.               pushSTACK(STACK_(12));
  7836.               goto next_byte;
  7837.             CASE cod_load_push13:            # (LOAD&PUSH.S 13)
  7838.               pushSTACK(STACK_(13));
  7839.               goto next_byte;
  7840.             CASE cod_load_push14:            # (LOAD&PUSH.S 14)
  7841.               pushSTACK(STACK_(14));
  7842.               goto next_byte;
  7843.             CASE cod_load_push15:            # (LOAD&PUSH.S 15)
  7844.               pushSTACK(STACK_(15));
  7845.               goto next_byte;
  7846.             CASE cod_load_push16:            # (LOAD&PUSH.S 16)
  7847.               pushSTACK(STACK_(16));
  7848.               goto next_byte;
  7849.             CASE cod_load_push17:            # (LOAD&PUSH.S 17)
  7850.               pushSTACK(STACK_(17));
  7851.               goto next_byte;
  7852.             CASE cod_load_push18:            # (LOAD&PUSH.S 18)
  7853.               pushSTACK(STACK_(18));
  7854.               goto next_byte;
  7855.             CASE cod_load_push19:            # (LOAD&PUSH.S 19)
  7856.               pushSTACK(STACK_(19));
  7857.               goto next_byte;
  7858.             CASE cod_load_push20:            # (LOAD&PUSH.S 20)
  7859.               pushSTACK(STACK_(20));
  7860.               goto next_byte;
  7861.             CASE cod_load_push21:            # (LOAD&PUSH.S 21)
  7862.               pushSTACK(STACK_(21));
  7863.               goto next_byte;
  7864.             CASE cod_load_push22:            # (LOAD&PUSH.S 22)
  7865.               pushSTACK(STACK_(22));
  7866.               goto next_byte;
  7867.             CASE cod_load_push23:            # (LOAD&PUSH.S 23)
  7868.               pushSTACK(STACK_(23));
  7869.               goto next_byte;
  7870.             CASE cod_load_push24:            # (LOAD&PUSH.S 24)
  7871.               pushSTACK(STACK_(24));
  7872.               goto next_byte;
  7873.             CASE cod_const0:                 # (CONST.S 0)
  7874.               value1 = TheCclosure(closure)->clos_consts[0]; mv_count=1;
  7875.               goto next_byte;
  7876.             CASE cod_const1:                 # (CONST.S 1)
  7877.               value1 = TheCclosure(closure)->clos_consts[1]; mv_count=1;
  7878.               goto next_byte;
  7879.             CASE cod_const2:                 # (CONST.S 2)
  7880.               value1 = TheCclosure(closure)->clos_consts[2]; mv_count=1;
  7881.               goto next_byte;
  7882.             CASE cod_const3:                 # (CONST.S 3)
  7883.               value1 = TheCclosure(closure)->clos_consts[3]; mv_count=1;
  7884.               goto next_byte;
  7885.             CASE cod_const4:                 # (CONST.S 4)
  7886.               value1 = TheCclosure(closure)->clos_consts[4]; mv_count=1;
  7887.               goto next_byte;
  7888.             CASE cod_const5:                 # (CONST.S 5)
  7889.               value1 = TheCclosure(closure)->clos_consts[5]; mv_count=1;
  7890.               goto next_byte;
  7891.             CASE cod_const6:                 # (CONST.S 6)
  7892.               value1 = TheCclosure(closure)->clos_consts[6]; mv_count=1;
  7893.               goto next_byte;
  7894.             CASE cod_const7:                 # (CONST.S 7)
  7895.               value1 = TheCclosure(closure)->clos_consts[7]; mv_count=1;
  7896.               goto next_byte;
  7897.             CASE cod_const8:                 # (CONST.S 8)
  7898.               value1 = TheCclosure(closure)->clos_consts[8]; mv_count=1;
  7899.               goto next_byte;
  7900.             CASE cod_const9:                 # (CONST.S 9)
  7901.               value1 = TheCclosure(closure)->clos_consts[9]; mv_count=1;
  7902.               goto next_byte;
  7903.             CASE cod_const10:                # (CONST.S 10)
  7904.               value1 = TheCclosure(closure)->clos_consts[10]; mv_count=1;
  7905.               goto next_byte;
  7906.             CASE cod_const11:                # (CONST.S 11)
  7907.               value1 = TheCclosure(closure)->clos_consts[11]; mv_count=1;
  7908.               goto next_byte;
  7909.             CASE cod_const12:                # (CONST.S 12)
  7910.               value1 = TheCclosure(closure)->clos_consts[12]; mv_count=1;
  7911.               goto next_byte;
  7912.             CASE cod_const13:                # (CONST.S 13)
  7913.               value1 = TheCclosure(closure)->clos_consts[13]; mv_count=1;
  7914.               goto next_byte;
  7915.             CASE cod_const14:                # (CONST.S 14)
  7916.               value1 = TheCclosure(closure)->clos_consts[14]; mv_count=1;
  7917.               goto next_byte;
  7918.             CASE cod_const15:                # (CONST.S 15)
  7919.               value1 = TheCclosure(closure)->clos_consts[15]; mv_count=1;
  7920.               goto next_byte;
  7921.             CASE cod_const16:                # (CONST.S 16)
  7922.               value1 = TheCclosure(closure)->clos_consts[16]; mv_count=1;
  7923.               goto next_byte;
  7924.             CASE cod_const17:                # (CONST.S 17)
  7925.               value1 = TheCclosure(closure)->clos_consts[17]; mv_count=1;
  7926.               goto next_byte;
  7927.             CASE cod_const18:                # (CONST.S 18)
  7928.               value1 = TheCclosure(closure)->clos_consts[18]; mv_count=1;
  7929.               goto next_byte;
  7930.             CASE cod_const19:                # (CONST.S 19)
  7931.               value1 = TheCclosure(closure)->clos_consts[19]; mv_count=1;
  7932.               goto next_byte;
  7933.             CASE cod_const20:                # (CONST.S 20)
  7934.               value1 = TheCclosure(closure)->clos_consts[20]; mv_count=1;
  7935.               goto next_byte;
  7936.             #if 0
  7937.             CASE cod_const21:                # (CONST.S 21)
  7938.               value1 = TheCclosure(closure)->clos_consts[21]; mv_count=1;
  7939.               goto next_byte;
  7940.             CASE cod_const22:                # (CONST.S 22)
  7941.               value1 = TheCclosure(closure)->clos_consts[22]; mv_count=1;
  7942.               goto next_byte;
  7943.             CASE cod_const23:                # (CONST.S 23)
  7944.               value1 = TheCclosure(closure)->clos_consts[23]; mv_count=1;
  7945.               goto next_byte;
  7946.             CASE cod_const24:                # (CONST.S 24)
  7947.               value1 = TheCclosure(closure)->clos_consts[24]; mv_count=1;
  7948.               goto next_byte;
  7949.             #endif
  7950.             CASE cod_const_push0:            # (CONST&PUSH.S 0)
  7951.               pushSTACK(TheCclosure(closure)->clos_consts[0]);
  7952.               goto next_byte;
  7953.             CASE cod_const_push1:            # (CONST&PUSH.S 1)
  7954.               pushSTACK(TheCclosure(closure)->clos_consts[1]);
  7955.               goto next_byte;
  7956.             CASE cod_const_push2:            # (CONST&PUSH.S 2)
  7957.               pushSTACK(TheCclosure(closure)->clos_consts[2]);
  7958.               goto next_byte;
  7959.             CASE cod_const_push3:            # (CONST&PUSH.S 3)
  7960.               pushSTACK(TheCclosure(closure)->clos_consts[3]);
  7961.               goto next_byte;
  7962.             CASE cod_const_push4:            # (CONST&PUSH.S 4)
  7963.               pushSTACK(TheCclosure(closure)->clos_consts[4]);
  7964.               goto next_byte;
  7965.             CASE cod_const_push5:            # (CONST&PUSH.S 5)
  7966.               pushSTACK(TheCclosure(closure)->clos_consts[5]);
  7967.               goto next_byte;
  7968.             CASE cod_const_push6:            # (CONST&PUSH.S 6)
  7969.               pushSTACK(TheCclosure(closure)->clos_consts[6]);
  7970.               goto next_byte;
  7971.             CASE cod_const_push7:            # (CONST&PUSH.S 7)
  7972.               pushSTACK(TheCclosure(closure)->clos_consts[7]);
  7973.               goto next_byte;
  7974.             CASE cod_const_push8:            # (CONST&PUSH.S 8)
  7975.               pushSTACK(TheCclosure(closure)->clos_consts[8]);
  7976.               goto next_byte;
  7977.             CASE cod_const_push9:            # (CONST&PUSH.S 9)
  7978.               pushSTACK(TheCclosure(closure)->clos_consts[9]);
  7979.               goto next_byte;
  7980.             CASE cod_const_push10:           # (CONST&PUSH.S 10)
  7981.               pushSTACK(TheCclosure(closure)->clos_consts[10]);
  7982.               goto next_byte;
  7983.             CASE cod_const_push11:           # (CONST&PUSH.S 11)
  7984.               pushSTACK(TheCclosure(closure)->clos_consts[11]);
  7985.               goto next_byte;
  7986.             CASE cod_const_push12:           # (CONST&PUSH.S 12)
  7987.               pushSTACK(TheCclosure(closure)->clos_consts[12]);
  7988.               goto next_byte;
  7989.             CASE cod_const_push13:           # (CONST&PUSH.S 13)
  7990.               pushSTACK(TheCclosure(closure)->clos_consts[13]);
  7991.               goto next_byte;
  7992.             CASE cod_const_push14:           # (CONST&PUSH.S 14)
  7993.               pushSTACK(TheCclosure(closure)->clos_consts[14]);
  7994.               goto next_byte;
  7995.             CASE cod_const_push15:           # (CONST&PUSH.S 15)
  7996.               pushSTACK(TheCclosure(closure)->clos_consts[15]);
  7997.               goto next_byte;
  7998.             CASE cod_const_push16:           # (CONST&PUSH.S 16)
  7999.               pushSTACK(TheCclosure(closure)->clos_consts[16]);
  8000.               goto next_byte;
  8001.             CASE cod_const_push17:           # (CONST&PUSH.S 17)
  8002.               pushSTACK(TheCclosure(closure)->clos_consts[17]);
  8003.               goto next_byte;
  8004.             CASE cod_const_push18:           # (CONST&PUSH.S 18)
  8005.               pushSTACK(TheCclosure(closure)->clos_consts[18]);
  8006.               goto next_byte;
  8007.             CASE cod_const_push19:           # (CONST&PUSH.S 19)
  8008.               pushSTACK(TheCclosure(closure)->clos_consts[19]);
  8009.               goto next_byte;
  8010.             CASE cod_const_push20:           # (CONST&PUSH.S 20)
  8011.               pushSTACK(TheCclosure(closure)->clos_consts[20]);
  8012.               goto next_byte;
  8013.             CASE cod_const_push21:           # (CONST&PUSH.S 21)
  8014.               pushSTACK(TheCclosure(closure)->clos_consts[21]);
  8015.               goto next_byte;
  8016.             CASE cod_const_push22:           # (CONST&PUSH.S 22)
  8017.               pushSTACK(TheCclosure(closure)->clos_consts[22]);
  8018.               goto next_byte;
  8019.             CASE cod_const_push23:           # (CONST&PUSH.S 23)
  8020.               pushSTACK(TheCclosure(closure)->clos_consts[23]);
  8021.               goto next_byte;
  8022.             CASE cod_const_push24:           # (CONST&PUSH.S 24)
  8023.               pushSTACK(TheCclosure(closure)->clos_consts[24]);
  8024.               goto next_byte;
  8025.             CASE cod_const_push25:           # (CONST&PUSH.S 25)
  8026.               pushSTACK(TheCclosure(closure)->clos_consts[25]);
  8027.               goto next_byte;
  8028.             CASE cod_const_push26:           # (CONST&PUSH.S 26)
  8029.               pushSTACK(TheCclosure(closure)->clos_consts[26]);
  8030.               goto next_byte;
  8031.             CASE cod_const_push27:           # (CONST&PUSH.S 27)
  8032.               pushSTACK(TheCclosure(closure)->clos_consts[27]);
  8033.               goto next_byte;
  8034.             CASE cod_const_push28:           # (CONST&PUSH.S 28)
  8035.               pushSTACK(TheCclosure(closure)->clos_consts[28]);
  8036.               goto next_byte;
  8037.             CASE cod_const_push29:           # (CONST&PUSH.S 29)
  8038.               pushSTACK(TheCclosure(closure)->clos_consts[29]);
  8039.               goto next_byte;
  8040.             #if 0
  8041.             CASE cod_const_push30:           # (CONST&PUSH.S 30)
  8042.               pushSTACK(TheCclosure(closure)->clos_consts[30]);
  8043.               goto next_byte;
  8044.             CASE cod_const_push31:           # (CONST&PUSH.S 31)
  8045.               pushSTACK(TheCclosure(closure)->clos_consts[31]);
  8046.               goto next_byte;
  8047.             CASE cod_const_push32:           # (CONST&PUSH.S 32)
  8048.               pushSTACK(TheCclosure(closure)->clos_consts[32]);
  8049.               goto next_byte;
  8050.             #endif
  8051.             CASE cod_store0:                 # (STORE.S 0)
  8052.               STACK_(0) = value1; mv_count=1;
  8053.               goto next_byte;
  8054.             CASE cod_store1:                 # (STORE.S 1)
  8055.               STACK_(1) = value1; mv_count=1;
  8056.               goto next_byte;
  8057.             CASE cod_store2:                 # (STORE.S 2)
  8058.               STACK_(2) = value1; mv_count=1;
  8059.               goto next_byte;
  8060.             CASE cod_store3:                 # (STORE.S 3)
  8061.               STACK_(3) = value1; mv_count=1;
  8062.               goto next_byte;
  8063.             CASE cod_store4:                 # (STORE.S 4)
  8064.               STACK_(4) = value1; mv_count=1;
  8065.               goto next_byte;
  8066.             CASE cod_store5:                 # (STORE.S 5)
  8067.               STACK_(5) = value1; mv_count=1;
  8068.               goto next_byte;
  8069.             CASE cod_store6:                 # (STORE.S 6)
  8070.               STACK_(6) = value1; mv_count=1;
  8071.               goto next_byte;
  8072.             CASE cod_store7:                 # (STORE.S 7)
  8073.               STACK_(7) = value1; mv_count=1;
  8074.               goto next_byte;
  8075.             CASE cod_store8:                 # (STORE.S 8)
  8076.               STACK_(8) = value1; mv_count=1;
  8077.               goto next_byte;
  8078.             CASE cod_store9:                 # (STORE.S 9)
  8079.               STACK_(9) = value1; mv_count=1;
  8080.               goto next_byte;
  8081.             #if 0
  8082.             CASE cod_store10:                # (STORE.S 10)
  8083.               STACK_(10) = value1; mv_count=1;
  8084.               goto next_byte;
  8085.             CASE cod_store11:                # (STORE.S 11)
  8086.               STACK_(11) = value1; mv_count=1;
  8087.               goto next_byte;
  8088.             CASE cod_store12:                # (STORE.S 12)
  8089.               STACK_(12) = value1; mv_count=1;
  8090.               goto next_byte;
  8091.             CASE cod_store13:                # (STORE.S 13)
  8092.               STACK_(13) = value1; mv_count=1;
  8093.               goto next_byte;
  8094.             CASE cod_store14:                # (STORE.S 14)
  8095.               STACK_(14) = value1; mv_count=1;
  8096.               goto next_byte;
  8097.             CASE cod_store15:                # (STORE.S 15)
  8098.               STACK_(15) = value1; mv_count=1;
  8099.               goto next_byte;
  8100.             CASE cod_store16:                # (STORE.S 16)
  8101.               STACK_(16) = value1; mv_count=1;
  8102.               goto next_byte;
  8103.             CASE cod_store17:                # (STORE.S 17)
  8104.               STACK_(17) = value1; mv_count=1;
  8105.               goto next_byte;
  8106.             CASE cod_store18:                # (STORE.S 18)
  8107.               STACK_(18) = value1; mv_count=1;
  8108.               goto next_byte;
  8109.             CASE cod_store19:                # (STORE.S 19)
  8110.               STACK_(19) = value1; mv_count=1;
  8111.               goto next_byte;
  8112.             CASE cod_store20:                # (STORE.S 20)
  8113.               STACK_(20) = value1; mv_count=1;
  8114.               goto next_byte;
  8115.             CASE cod_store21:                # (STORE.S 21)
  8116.               STACK_(21) = value1; mv_count=1;
  8117.               goto next_byte;
  8118.             #endif
  8119.             # ------------------- sonstiges -----------------------
  8120.             #ifndef FAST_DISPATCH
  8121.             default:
  8122.             #endif
  8123.               # undefinierter Code
  8124.               #if defined(GNU) && defined(FAST_SP)
  8125.                 # -fomit-frame-pointer zunichte machen, damit
  8126.                 # %sp bzw. %esp als private_SP verwendbar ist:
  8127.                 alloca(1);
  8128.               #endif
  8129.               pushSTACK(fixnum(byteptr-&codeptr->data[0]-1)); # fehlerhafte Bytenummer
  8130.               pushSTACK(closure); # Closure
  8131.               //: DEUTSCH "Undefinierter Byte-Code in ~ bei Byte ~"
  8132.               //: ENGLISH "undefined bytecode in ~ at byte ~"
  8133.               //: FRANCAIS "Code octet indéfinissable ~ à l'octet ~"
  8134.               fehler(serious_condition, GETTEXT("undefined bytecode in ~ at byte ~"));
  8135.             #undef L_operand
  8136.             #undef S_operand
  8137.             #undef U_operand
  8138.             #undef B_operand
  8139.             #undef CASE
  8140.           }
  8141.         fehler_zuviele_werte:
  8142.           //: DEUTSCH "Zu viele Werte erzeugt."
  8143.           //: ENGLISH "too many return values"
  8144.           //: FRANCAIS "Trop de valeurs VALUES."
  8145.           fehler(error, GETTEXT("too many return values"));
  8146.         #if STACKCHECKC
  8147.         fehler_STACK_putt:
  8148.           pushSTACK(fixnum(byteptr-&codeptr->data[0])); # PC
  8149.           pushSTACK(closure); # FUNC
  8150.           //: DEUTSCH "Stack kaputt in ~ bei Byte ~"
  8151.           //: ENGLISH "Corrupted STACK in ~ at byte ~"
  8152.           //: FRANCAIS "Pile STACK corrompue dans ~ à l'octet ~"
  8153.           fehler(serious_condition, GETTEXT("Corrupted STACK in ~ at byte ~"));
  8154.         #endif
  8155.         finished:
  8156.         #undef FREE_JMPBUF_on_SP
  8157.         #undef JMPBUF_on_SP
  8158.         #ifndef FAST_SP
  8159.         FREE_DYNAMIC_ARRAY(private_SP_space);
  8160.         #endif
  8161.         return;
  8162.     }}}
  8163.  
  8164.  
  8165. # wo ist check_SP() oder check_STACK() einzufügen??
  8166. # soll nest_env sein Ziel-Environment übergeben bekommen??
  8167. # Register-Allozierung in eval_subr und eval_cclosure usw.??
  8168. # subr_self eliminieren??
  8169.  
  8170.