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