home *** CD-ROM | disk | FTP | other *** search
Text File | 1996-04-18 | 382.3 KB | 8,170 lines |
- # Evaluator, Applyer und Bytecode-Interpreter für CLISP
- # Bruno Haible 13.6.1995
-
- #include "lispbibl.c"
-
-
- # Der STACK:
- #if !defined(STACK_register)
- global object* STACK;
- #endif
- #ifdef HAVE_SAVED_STACK
- global object* saved_STACK;
- #endif
-
- # MULTIPLE-VALUE-SPACE:
- #if !defined(mv_count_register)
- global uintC mv_count;
- #endif
- #ifdef NEED_temp_mv_count
- global uintC temp_mv_count;
- #endif
- global object mv_space [mv_limit-1];
- #ifdef NEED_temp_value1
- global object temp_value1;
- #endif
-
- # Während der Ausführung eines SUBR, FSUBR: das aktuelle SUBR bzw. FSUBR
- #if !defined(subr_self_register)
- global object subr_self;
- #endif
- #ifdef HAVE_SAVED_SUBR_SELF
- global object saved_subr_self;
- #endif
-
- # Während Callbacks die geretteten Register:
- #if defined(HAVE_SAVED_REGISTERS)
- global struct registers *callback_saved_registers;
- #endif
-
- # Funktionen-Tabelle:
- # Darin stehen nur SUBRs, die der Compiler "inline" machen darf.
- # In FUNTAB1 und FUNTAB2 stehen SUBRs ohne Rest-Parameter (also
- # mit zur Compile-Zeit bekannter fester Argumentezahl).
- # In FUNTABR stehen SUBRs mit Rest-Parameter.
- #define _(name) &subr_tab.D_##name # Adresse von SUBR name, wie L(name)
- # erst FUNTAB1 und FUNTAB2 :
- global Subr FUNTAB[] = {
- # SPVW : 0 SUBRs
- # EVAL : 2 SUBRs
- _(funtabref), _(subr_info),
- # ARRAY : 29-2 SUBRs
- /* _(svref), _(psvstore), */ _(row_major_aref), _(row_major_store),
- _(array_element_type), _(array_rank), _(array_dimension),
- _(array_dimensions), _(array_total_size), _(adjustable_array_p),
- _(bit_and), _(bit_ior), _(bit_xor), _(bit_eqv), _(bit_nand), _(bit_nor),
- _(bit_andc1), _(bit_andc2), _(bit_orc1), _(bit_orc2), _(bit_not),
- _(array_has_fill_pointer_p), _(fill_pointer), _(set_fill_pointer),
- _(vector_push), _(vector_pop), _(vector_push_extend), _(make_array),
- _(adjust_array),
- # CHARSTRG : 52 SUBRs
- _(standard_char_p), _(graphic_char_p), _(string_char_p), _(alpha_char_p),
- _(upper_case_p), _(lower_case_p), _(both_case_p), _(digit_char_p),
- _(alphanumericp), _(char_code), _(char_bits), _(char_font), _(code_char),
- _(make_char), _(character), _(char_upcase), _(char_downcase),
- _(digit_char), _(char_int), _(int_char), _(char_name), _(char_bit),
- _(set_char_bit), _(char), _(schar), _(store_char), _(store_schar),
- _(string_gleich), _(string_ungleich), _(string_kleiner),
- _(string_groesser), _(string_klgleich), _(string_grgleich),
- _(string_equal), _(string_not_equal), _(string_lessp), _(string_greaterp),
- _(string_not_greaterp), _(string_not_lessp), _(search_string_gleich),
- _(search_string_equal), _(make_string), _(string_both_trim),
- _(nstring_upcase), _(string_upcase), _(nstring_downcase),
- _(string_downcase), _(nstring_capitalize), _(string_capitalize),
- _(string), _(name_char), _(substring),
- # CONTROL : 21-2 SUBRs
- _(symbol_value), /* _(symbol_function), */ _(boundp), _(fboundp),
- _(special_form_p), _(set), _(makunbound), _(fmakunbound), /* _(values_list), */
- _(driver), _(unwind_to_driver), _(macro_function), _(macroexpand),
- _(macroexpand_1), _(proclaim), _(eval), _(evalhook), _(applyhook),
- _(constantp), _(parse_body), _(keyword_test),
- # DEBUG : 1 SUBR
- _(room),
- # ERROR : 1 SUBR
- _(invoke_debugger),
- # HASHTABL : 11 SUBRs
- _(make_hash_table), _(gethash), _(puthash), _(remhash), _(maphash),
- _(clrhash), _(hash_table_count), _(hash_table_iterator),
- _(hash_table_iterate), _(class_gethash), _(sxhash),
- # IO : 36 SUBRs
- _(copy_readtable), _(set_syntax_from_char), _(set_macro_character),
- _(get_macro_character), _(make_dispatch_macro_character),
- _(set_dispatch_macro_character), _(get_dispatch_macro_character),
- _(read), _(read_preserving_whitespace), _(read_delimited_list),
- _(read_line), _(read_char), _(unread_char), _(peek_char), _(listen),
- _(read_char_no_hang), _(clear_input), _(read_from_string),
- _(parse_integer), _(write), _(prin1), _(print), _(pprint), _(princ),
- _(write_to_string), _(prin1_to_string), _(princ_to_string), _(write_char),
- _(write_string), _(write_line), _(terpri), _(fresh_line),
- _(finish_output), _(force_output), _(clear_output), _(line_position),
- # LIST : 83-36 SUBRs
- /* _(car), _(cdr), _(caar), _(cadr), _(cdar), _(cddr), _(caaar), _(caadr),
- _(cadar), _(caddr), _(cdaar), _(cdadr), _(cddar), _(cdddr), _(caaaar),
- _(caaadr), _(caadar), _(caaddr), _(cadaar), _(cadadr), _(caddar),
- _(cadddr), _(cdaaar), _(cdaadr), _(cdadar), _(cdaddr), _(cddaar),
- _(cddadr), _(cdddar), _(cddddr), _(cons), */ _(tree_equal), _(endp),
- _(list_length), _(nth), /* _(first), _(second), _(third), _(fourth), */
- _(fifth), _(sixth), _(seventh), _(eighth), _(ninth), _(tenth), /* _(rest), */
- _(nthcdr), _(last), _(make_list), _(copy_list), _(copy_alist),
- _(copy_tree), _(revappend), _(nreconc), _(list_nreverse), _(butlast),
- _(nbutlast), _(ldiff), _(rplaca), _(prplaca), _(rplacd), _(prplacd),
- _(subst), _(subst_if), _(subst_if_not), _(nsubst), _(nsubst_if),
- _(nsubst_if_not), _(sublis), _(nsublis), _(member), _(member_if),
- _(member_if_not), _(tailp), _(adjoin), _(acons), _(pairlis), _(assoc),
- _(assoc_if), _(assoc_if_not), _(rassoc), _(rassoc_if), _(rassoc_if_not),
- # MISC : 10 SUBRs
- _(lisp_implementation_type), _(lisp_implementation_version),
- _(software_type), _(software_version), _(identity), _(get_universal_time),
- _(get_internal_run_time), _(get_internal_real_time), _(sleep), _(time),
- # PACKAGE : 26 SUBRs
- _(make_symbol), _(find_package), _(package_name), _(package_nicknames),
- _(rename_package), _(package_use_list), _(package_used_by_list),
- _(package_shadowing_symbols), _(list_all_packages), _(intern),
- _(find_symbol), _(unintern), _(export), _(unexport), _(import),
- _(shadowing_import), _(shadow), _(use_package), _(unuse_package),
- _(make_package), _(pin_package), _(in_package), _(find_all_symbols),
- _(map_symbols), _(map_external_symbols), _(map_all_symbols),
- # PATHNAME : 27 SUBRs
- _(parse_namestring), _(pathname), _(pathnamehost), _(pathnamedevice),
- _(pathnamedirectory), _(pathnamename), _(pathnametype),
- _(pathnameversion), _(file_namestring), _(directory_namestring),
- _(host_namestring), _(merge_pathnames), _(enough_namestring),
- _(make_pathname), _(namestring), _(truename), _(probe_file),
- _(delete_file), _(rename_file), _(open), _(directory), _(cd),
- _(make_dir), _(delete_dir), _(file_write_date), _(file_author),
- _(savemem),
- # PREDTYPE : 46-3 SUBRs
- /* _(eq), */ _(eql), _(equal), _(equalp), _(consp), _(atom), _(symbolp),
- _(stringp), _(numberp), _(compiled_function_p), /* _(null), _(not), */
- _(closurep), _(listp), _(integerp), _(fixnump), _(rationalp), _(floatp),
- _(short_float_p), _(single_float_p), _(double_float_p), _(long_float_p),
- _(realp), _(complexp), _(streamp), _(random_state_p), _(readtablep),
- _(hash_table_p), _(pathnamep), _(logical_pathname_p), _(characterp),
- _(functionp), _(generic_function_p), _(packagep), _(arrayp),
- _(simple_array_p), _(bit_vector_p), _(vectorp), _(simple_vector_p),
- _(simple_string_p), _(simple_bit_vector_p), _(commonp), _(type_of),
- _(class_of), _(find_class), _(coerce),
- # RECORD : 21 SUBRs
- _(record_ref), _(record_store), _(record_length), _(structure_ref),
- _(structure_store), _(make_structure), _(copy_structure),
- _(structure_type_p), _(closure_name), _(closure_codevec),
- _(closure_consts), _(make_code_vector), _(make_closure),
- _(make_load_time_eval), _(std_instance_p), _(allocate_std_instance),
- _(slot_value), _(set_slot_value), _(slot_boundp), _(slot_makunbound),
- _(slot_exists_p),
- # SEQUENCE : 40 SUBRs
- _(sequencep), _(elt), _(setelt), _(subseq), _(copy_seq), _(length),
- _(reverse), _(nreverse), _(make_sequence), _(reduce), _(fill),
- _(replace), _(remove), _(remove_if), _(remove_if_not), _(delete),
- _(delete_if), _(delete_if_not), _(remove_duplicates),
- _(delete_duplicates), _(substitute), _(substitute_if),
- _(substitute_if_not), _(nsubstitute), _(nsubstitute_if),
- _(nsubstitute_if_not), _(find), _(find_if), _(find_if_not), _(position),
- _(position_if), _(position_if_not), _(count), _(count_if),
- _(count_if_not), _(mismatch), _(search), _(sort), _(stable_sort),
- _(merge),
- # STREAM : 23 SUBRs
- _(file_stream_p), _(make_synonym_stream), _(synonym_stream_p),
- _(broadcast_stream_p), _(concatenated_stream_p), _(make_two_way_stream),
- _(two_way_stream_p), _(make_echo_stream), _(echo_stream_p),
- _(make_string_input_stream), _(string_input_stream_index),
- _(make_string_output_stream), _(get_output_stream_string),
- _(make_string_push_stream), _(string_stream_p), _(input_stream_p),
- _(output_stream_p), _(stream_element_type), _(close), _(read_byte),
- _(write_byte), _(file_position), _(file_length),
- # SYMBOL : 15 SUBRs
- _(putd), _(proclaim_constant), _(get), _(getf), _(get_properties),
- _(putplist), _(put), _(remprop), _(symbol_package), _(symbol_plist),
- _(symbol_name), _(keywordp), _(gensym), _(special_variable_p), _(gensym),
- # LISPARIT : 84 SUBRs
- _(decimal_string), _(zerop), _(plusp), _(minusp), _(oddp), _(evenp),
- _(einsplus), _(einsminus), _(conjugate), _(exp), _(expt), _(log),
- _(sqrt), _(isqrt), _(abs), _(phase), _(signum), _(sin), _(cos), _(tan),
- _(cis), _(asin), _(acos), _(atan), _(sinh), _(cosh), _(tanh), _(asinh),
- _(acosh), _(atanh), _(float), _(rational), _(rationalize), _(numerator),
- _(denominator), _(floor), _(ceiling), _(truncate), _(round), _(mod),
- _(rem), _(ffloor), _(fceiling), _(ftruncate), _(fround), _(decode_float),
- _(scale_float), _(float_radix), _(float_sign), _(float_digits),
- _(float_precision), _(integer_decode_float), _(complex), _(realpart),
- _(imagpart), _(lognand), _(lognor), _(logandc1), _(logandc2), _(logorc1),
- _(logorc2), _(boole), _(lognot), _(logtest), _(logbitp), _(ash),
- _(logcount), _(integer_length), _(byte), _(bytesize), _(byteposition),
- _(ldb), _(ldb_test), _(mask_field), _(dpb), _(deposit_field), _(random),
- _(make_random_state), _(fakultaet), _(exquo), _(long_float_digits),
- _(set_long_float_digits), _(log2), _(log10),
- # sonstige:
- };
- # Das waren 528-43 SUBRs.
- # Nun FUNTABR :
- local Subr FUNTABR[] = {
- # SPVW : 0 SUBRs
- # EVAL : 0 SUBRs
- # ARRAY : 7 SUBRs
- _(vector), _(aref), _(store), _(array_in_bounds_p),
- _(array_row_major_index), _(bit), _(sbit),
- # CHARSTRG : 13 SUBRs
- _(char_gleich), _(char_ungleich), _(char_kleiner), _(char_groesser),
- _(char_klgleich), _(char_grgleich), _(char_equal), _(char_not_equal),
- _(char_lessp), _(char_greaterp), _(char_not_greaterp), _(char_not_lessp),
- _(string_concat),
- # CONTROL : 10 SUBRs
- _(apply), _(pfuncall), _(funcall), _(mapcar), _(maplist), _(mapc),
- _(mapl), _(mapcan), _(mapcon), _(values),
- # DEBUG : 0 SUBRs
- # ERROR : 2 SUBRs
- _(error), _(error_of_type),
- # HASHTABL : 1 SUBR
- _(class_tuple_gethash),
- # IO : 0 SUBRs
- # LIST : 4 SUBRs
- _(list), _(liststern), _(append), _(nconc),
- # MISC : 0 SUBRs
- # PACKAGE : 0 SUBRs
- # PATHNAME : 0 SUBRs
- # PREDTYPE : 0 SUBRs
- # RECORD : 0 SUBRs
- # SEQUENCE : 6 SUBRs
- _(concatenate), _(map), _(some), _(every), _(notany), _(notevery),
- # STREAM : 2 SUBRs
- _(make_broadcast_stream), _(make_concatenated_stream),
- # SYMBOL : 0 SUBRs
- # LISPARIT : 18 SUBRs
- _(gleich), _(ungleich), _(kleiner), _(groesser), _(klgleich),
- _(grgleich), _(max), _(min), _(plus), _(minus), _(mal), _(durch), _(gcd),
- _(lcm), _(logior), _(logxor), _(logand), _(logeqv),
- };
- # Das waren 63 SUBRs.
- #undef _
- #define FUNTAB1 (&FUNTAB[0])
- #define FUNTAB2 (&FUNTAB[256])
- #define FUNTAB_length (sizeof(FUNTAB)/sizeof(Subr))
- #define FUNTABR_length (sizeof(FUNTABR)/sizeof(Subr))
-
- # Argumenttyp-Kürzel bei compilierten Closures:
- typedef enum {cclos_argtype_default,
- cclos_argtype_0_0,
- cclos_argtype_1_0,
- cclos_argtype_2_0,
- cclos_argtype_3_0,
- cclos_argtype_4_0,
- cclos_argtype_5_0,
- cclos_argtype_0_1,
- cclos_argtype_1_1,
- cclos_argtype_2_1,
- cclos_argtype_3_1,
- cclos_argtype_4_1,
- cclos_argtype_0_2,
- cclos_argtype_1_2,
- cclos_argtype_2_2,
- cclos_argtype_3_2,
- cclos_argtype_0_3,
- cclos_argtype_1_3,
- cclos_argtype_2_3,
- cclos_argtype_0_4,
- cclos_argtype_1_4,
- cclos_argtype_0_5,
- cclos_argtype_0_0_rest,
- cclos_argtype_1_0_rest,
- cclos_argtype_2_0_rest,
- cclos_argtype_3_0_rest,
- cclos_argtype_4_0_rest,
- cclos_argtype_0_0_key,
- cclos_argtype_1_0_key,
- cclos_argtype_2_0_key,
- cclos_argtype_3_0_key,
- cclos_argtype_4_0_key,
- cclos_argtype_0_1_key,
- cclos_argtype_1_1_key,
- cclos_argtype_2_1_key,
- cclos_argtype_3_1_key,
- cclos_argtype_0_2_key,
- cclos_argtype_1_2_key,
- cclos_argtype_2_2_key,
- cclos_argtype_0_3_key,
- cclos_argtype_1_3_key,
- cclos_argtype_0_4_key,
- cclos_argtype_for_broken_compilers_that_dont_like_trailing_commas
- }
- cclos_argtype_;
-
- # Aufruf des Bytecode-Interpreters:
- # Interpretiert den Bytecode einer compilierten Closure.
- # interpret_bytecode(closure,codevec,index);
- # > closure: compilierte Closure
- # > codevec: ihr Codevektor, ein Simple-Bit-Vector
- # > index: Start-Index
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- # local Values interpret_bytecode (object closure, object codevec, uintL index);
- local Values interpret_bytecode_ (object closure, Sbvector codeptr, uintB* byteptr);
- #define interpret_bytecode(closure,codevec,index) \
- interpret_bytecode_(closure,TheSbvector(codevec),&TheSbvector(codevec)->data[index])
-
- # GCC2 kann direkt zu Labels springen. Das gibt schnelleren Code als switch().
- #ifdef GNU
- #if (__GNUC__ >= 2) && !defined(NO_FAST_DISPATCH)
- #define FAST_DISPATCH
- #if (__GNUC_MINOR__ >= 7) # gcc-2.6.3 Bug umgehen (-fno-defer-pop ginge auch)
- #define FAST_DISPATCH_THREADED
- #endif
- #endif
- #endif
-
- # Werte der Bytecodes (256 Stück):
- #ifndef FAST_DISPATCH
- typedef enum {
- #define BYTECODE(code) code,
- #include "bytecode.c"
- #undef BYTECODE
- cod_for_broken_compilers_that_dont_like_trailing_commas
- }
- bytecode_enum;
- #endif
-
-
- # ---------------------- LISP-FUNKTIONEN -----------------------
-
- # (SYS::%FUNTABREF i) liefert den Namen der Funktion Nr. i aus der Funktionen-
- # tabelle (ein Symbol), bzw. NIL falls i nicht im richtigen Bereich liegt.
- LISPFUNN(funtabref,1)
- { var reg2 object arg = popSTACK(); # Argument
- var reg1 uintL i;
- if (posfixnump(arg) # sollte ein Fixnum >=0
- && (i = posfixnum_to_L(arg),
- i < FUNTAB_length+FUNTABR_length # und < Tabellenlänge sein
- ) )
- # Name des indizierten Elements der Tabelle:
- { value1 = (i < FUNTAB_length
- ? FUNTAB[i] # aus FUNTAB1/2
- : FUNTABR[i-FUNTAB_length] # bzw. aus FUNTABR
- )->name;
- }
- else
- { value1 = NIL; } # oder NIL
- mv_count=1; # als Wert
- }
-
- # (SYS::SUBR-INFO obj) liefert, wenn obj ein SUBR (oder ein Symbol mit einem
- # SUBR als globaler Funktionsdefinition) ist, Information zu diesem SUBR,
- # 6 Werte:
- # name Name,
- # req-anz Anzahl der required-Parameter,
- # opt-anz Anzahl der optionalen Parameter,
- # rest-p Flag, ob &rest angegeben,
- # keywords Liste der zulässigen Keywords (leer: kein &key angegeben),
- # allow-other-keys Flag, ob zusätzliche Keywords erlaubt sind,
- # und sonst NIL.
- LISPFUNN(subr_info,1)
- { var reg1 object obj = popSTACK();
- if (!subrp(obj))
- { if (!(symbolp(obj) && msubrp(Symbol_function(obj))))
- { value1 = NIL; mv_count=0; return; } # kein SUBR -> kein Wert
- obj = Symbol_function(obj);
- }
- # obj ist ein SUBR
- pushSTACK(TheSubr(obj)->name); # Name
- pushSTACK(fixnum(TheSubr(obj)->req_anz)); # req-anz
- pushSTACK(fixnum(TheSubr(obj)->opt_anz)); # opt-anz
- pushSTACK(TheSubr(obj)->rest_flag == subr_norest ? NIL : T); # rest-p
- coerce_sequence(TheSubr(obj)->keywords,S(list));
- pushSTACK(value1); # Keyword-Vektor als Liste
- pushSTACK(TheSubr(obj)->key_flag == subr_key_allow ? T : NIL); # allow-other-keys
- funcall(L(values),6); # 6 Werte
- }
-
-
- LISPFUNN(find_subr,1)
- { if (!msymbolp(STACK_0)) fehler_symbol(STACK_0);
- value1 = Symbol_function(STACK_0);
- if (!subrp(value1)) value1 = NIL;
- mv_count=1;
- skipSTACK(1);
- }
-
- # ----------------------- UNTERPROGRAMME -----------------------
-
- # UP: Löst einen Frame auf, auf den STACK zeigt.
- # unwind();
- # Die Werte mv_count/mv_space bleiben dieselben.
- # Falls es kein Unwind-Protect-Frame ist: kehrt normal zurück.
- # Falls es ein Unwind-Protect-Frame ist:
- # rettet die Werte, klettert STACK und SP hoch
- # und springt dann unwind_protect_to_save.fun an.
- # verändert STACK
- # kann GC auslösen
- global unwind_protect_caller unwind_protect_to_save;
- global void unwind (void);
- global void unwind()
- { var reg3 tint frame_info = mtypecode(STACK_0);
- #ifdef unwind_bit_t
- if (frame_info & bit(unwind_bit_t)) # überhaupt etwas zu tun?
- #else
- if (frame_info >= unwind_limit_t) # überhaupt etwas zu tun?
- #endif
- # (Nein bei APPLY, EVAL ungetrapped, CATCH, HANDLER,
- # IBLOCK und ITAGBODY ungenestet)
- { if ((frame_info & bit(skip2_bit_t)) == 0) # ENV-Frame oder DYNBIND-Frame?
- #ifdef entrypoint_bit_t
- if (frame_info & bit(entrypoint_bit_t)) # BLOCK, TAGBODY, CATCH etc. ?
- #else
- if (frame_info < entrypoint_limit_t) # BLOCK, TAGBODY, CATCH etc. ?
- #endif
- # Frame mit Exitpoint liegt vor
- if (frame_info & bit(blockgo_bit_t)) # BLOCK oder TAGBODY?
- # BLOCK_FRAME oder TAGBODY_FRAME liegt vor
- if (frame_info & bit(cframe_bit_t)) # compilierter?
- # CBLOCK_FRAME oder CTAGBODY_FRAME liegt vor
- { # Im Cons (NAME/Tags . <Framepointer>)
- Cdr(STACK_(frame_ctag)) = disabled; # Exit/Tags disablen
- }
- else
- # IBLOCK_FRAME oder ITAGBODY_FRAME liegt vor, genestet
- { # Im Cons (NAME/Tags . <Framepointer>)
- # (erstes Paar der Aliste next_env)
- Cdr(Car(STACK_(frame_next_env))) = disabled; # Exit/Tags disablen
- }
- else
- # UNWIND_PROTECT_FRAME, DRIVER_FRAME oder getrappter APPLY/EVAL_FRAME liegt vor
- if (frame_info & bit(dynjump_bit_t))
- # UNWIND_PROTECT_FRAME oder DRIVER_FRAME liegt vor
- if (frame_info & bit(driver_bit_t))
- # DRIVER_FRAME liegt vor
- {
- #ifdef HAVE_NUM_STACK
- # NUM_STACK_normal muß wieder den Wert bekommen, den es vor
- # Aufbau des Driver-Frames hatte:
- NUM_STACK =
- NUM_STACK_normal =
- ((DRIVER_frame_data*)(STACK_(frame_SP)))->old_NUM_STACK_normal;
- #endif
- }
- else
- # UNWIND_PROTECT_FRAME liegt vor
- { enter_frame_at_STACK(); }
- else
- # getrappter APPLY/EVAL_FRAME liegt vor
- { # Wie im Tracer:
- var reg1 object values;
- mv_to_list(); values = popSTACK(); # Werte in Liste packen
- dynamic_bind(S(trace_values),values); # *TRACE-VALUES* binden
- break_driver(T); # Break-Driver aufrufen
- list_to_mv(Symbol_value(S(trace_values)), # wieder Werte bilden
- fehler_mv_zuviel(mtypecode(STACK_(0+DYNBIND_SIZE))==TRAPPED_EVAL_frame_info
- ? S(eval)
- : S(apply)
- );
- );
- dynamic_unbind(); # Bindung auflösen
- }
- else
- # VAR_FRAME oder FUN_FRAME liegt vor
- { var reg4 object* new_STACK = topofframe(STACK_0); # Pointer übern Frame
- if (frame_info & bit(fun_bit_t))
- {} # bei Funktionen nichts weiter zu tun
- else
- # VAR_FRAME liegt vor, bindingptr läuft durch die Bindungen hoch
- { var reg2 object* frame_end = STACKpointable(new_STACK);
- var reg1 object* bindingptr = &STACK_(frame_bindings); # Beginn der Variablen-/Funktionsbindungen
- until (bindingptr == frame_end)
- { if (as_oint(*(bindingptr STACKop 0)) & wbit(dynam_bit_o))
- if (as_oint(*(bindingptr STACKop 0)) & wbit(active_bit_o))
- # Bindung statisch oder inaktiv -> nichts zu tun
- # Bindung dynamisch und aktiv -> Wert zurückschreiben:
- { set_Symbolflagged_value_off(*(bindingptr STACKop varframe_binding_sym),*(bindingptr STACKop varframe_binding_value));
-
- }
- bindingptr skipSTACKop varframe_binding_size; # nächste Bindung
- } }
- # STACK neu setzen, dadurch Frame auflösen:
- setSTACK(STACK = new_STACK);
- goto fertig;
- }
- else
- # DYNBIND_FRAME oder ENV_FRAME liegt vor
- if (frame_info & bit(envbind_bit_t))
- # ENV_FRAME liegt vor
- { var reg1 object* ptr = &STACK_1;
- switch (frame_info & envbind_case_mask_t)
- { case (ENV1V_frame_info & envbind_case_mask_t): # 1 VAR_ENV
- aktenv.var_env = *ptr; ptr skipSTACKop 1; break;
- case (ENV1F_frame_info & envbind_case_mask_t): # 1 FUN_ENV
- aktenv.fun_env = *ptr; ptr skipSTACKop 1; break;
- case (ENV1B_frame_info & envbind_case_mask_t): # 1 BLOCK_ENV
- aktenv.block_env = *ptr; ptr skipSTACKop 1; break;
- case (ENV1G_frame_info & envbind_case_mask_t): # 1 GO_ENV
- aktenv.go_env = *ptr; ptr skipSTACKop 1; break;
- case (ENV1D_frame_info & envbind_case_mask_t): # 1 DECL_ENV
- aktenv.decl_env = *ptr; ptr skipSTACKop 1; break;
- case (ENV2VD_frame_info & envbind_case_mask_t): # 1 VAR_ENV und 1 DECL_ENV
- aktenv.var_env = *ptr; ptr skipSTACKop 1;
- aktenv.decl_env = *ptr; ptr skipSTACKop 1;
- break;
- case (ENV5_frame_info & envbind_case_mask_t): # alle 5 Environments
- aktenv.var_env = *ptr; ptr skipSTACKop 1;
- aktenv.fun_env = *ptr; ptr skipSTACKop 1;
- aktenv.block_env = *ptr; ptr skipSTACKop 1;
- aktenv.go_env = *ptr; ptr skipSTACKop 1;
- aktenv.decl_env = *ptr; ptr skipSTACKop 1;
- break;
- default: NOTREACHED
- } }
- else
- # DYNBIND_FRAME liegt vor
- { var reg4 object* new_STACK = topofframe(STACK_0); # Pointer übern Frame
- var reg2 object* frame_end = STACKpointable(new_STACK);
- var reg1 object* bindingptr = &STACK_1; # Beginn der Bindungen
- # bindingptr läuft durch die Bindungen hoch
- until (bindingptr == frame_end)
- { set_Symbol_symvalue(*(bindingptr STACKop 0),*(bindingptr STACKop 1));
- bindingptr skipSTACKop 2; # nächste Bindung
- }
- #ifdef DYNBIND_LIST
- delete_frame_from_binding_list(&STACK_0);
- #endif
- # STACK neu setzen, dadurch Frame auflösen:
- setSTACK(STACK = new_STACK);
- goto fertig;
- }
- }
- # STACK neu setzen, dadurch Frame auflösen:
- setSTACK(STACK = topofframe(STACK_0));
- fertig: ;
- }
-
- # UP: "unwindet" den STACK bis zum nächsten DRIVER_FRAME und
- # springt in die entsprechende Top-Level-Schleife.
- # reset();
- nonreturning_function(global, reset, (void));
- global void reset()
- { # Beim Auflösen von UNWIND-PROTECT-Frames keine Werte retten:
- value1 = NIL; mv_count=0;
- unwind_protect_to_save.fun = (restart)&reset;
- loop
- { # Hört der STACK hier auf?
- if (eq(STACK_0,nullobj) && eq(STACK_1,nullobj))
- { driver(); } # STACK völlig weg -> Neustart
- if (mtypecode(STACK_0) & bit(frame_bit_t))
- # Bei STACK_0 beginnt ein Frame
- { if (mtypecode(STACK_0) == DRIVER_frame_info) # DRIVER_FRAME ?
- break; # ja -> gefunden
- unwind(); # Frame auflösen
- }
- else
- # STACK_0 enthält ein normales LISP-Objekt
- { skipSTACK(1); }
- }
- # Bei STACK_0 beginnt ein Driver-Frame.
- enter_frame_at_STACK();
- }
-
- # UP: bindet dynamisch die Symbole der Liste symlist
- # an die Werte aus der Liste vallist.
- # progv(symlist,vallist);
- # > symlist, vallist: zwei Listen
- # Es wird genau ein Variablenbindungsframe aufgebaut.
- # verändert STACK
- global void progv (object symlist, object vallist);
- global void progv(symlist,vallist)
- var reg2 object symlist;
- var reg4 object vallist;
- { # Platz auf dem STACK verlangen:
- get_space_on_STACK(llength(symlist)*2*sizeof(object));
- # Frame aufbauen:
- { var reg5 object* top_of_frame = STACK; # Pointer übern Frame
- var reg3 object symlistr = symlist;
- while (consp(symlistr)) # Symbolliste durchgehen
- { var reg1 object sym = Car(symlistr);
- if (!symbolp(sym)) { fehler_kein_symbol(S(progv),sym); }
- if (constantp(TheSymbol(sym)))
- { pushSTACK(sym);
- pushSTACK(S(progv));
- //: DEUTSCH "~: ~ ist eine Konstante und kann nicht dynamisch gebunden werden."
- //: ENGLISH "~: ~ is a constant, cannot be bound dynamically"
- //: FRANCAIS "~: ~ est une constante et ne peut pas être liée dynamiquement."
- fehler(error, GETTEXT("~: ~ is a constant, cannot be bound dynamically"));
- }
- pushSTACK(Symbol_symvalue(sym)); # alter Wert der Variablen
- pushSTACK(sym); # Variable
- symlistr = Cdr(symlistr);
- }
- finish_frame(DYNBIND);
- # Frame fertig aufgebaut, nun die Werte der Variablen verändern:
- while (consp(symlist))
- { if (atomp(vallist))
- # Wertliste kürzer als Symbolliste
- # -> alle weiteren "Werte" sind #<UNBOUND>
- { do { set_Symbol_symvalue(Car(symlist),unbound);
- symlist = Cdr(symlist);
- }
- while (consp(symlist));
- break;
- }
- # Symbol bekommt neuen Wert:
- set_Symbol_symvalue(Car(symlist),Car(vallist));
- symlist = Cdr(symlist); vallist = Cdr(vallist);
- }
- #ifdef DYNBIND_LIST
- add_frame_to_binding_list(&STACK_0);
- #endif
- } }
-
- # UP: Löst die dynamische Schachtelung im STACK auf bis zu dem Frame
- # (ausschließlich), auf den upto zeigt, und springt diesen dann an.
- # unwind_upto(upto);
- # > upto: Pointer auf einen Frame (in den Stack, ohne Typinfo).
- # Rettet die Werte mv_count/mv_space.
- # verändert STACK,SP
- # kann GC auslösen
- # Springt dann den gefundenen Frame an.
- nonreturning_function(global, unwind_upto, (object* upto_frame));
- global void unwind_upto(upto_frame)
- var reg1 object* upto_frame;
- { unwind_protect_to_save.fun = &unwind_upto;
- unwind_protect_to_save.upto_frame = upto_frame;
- until (STACK == upto_frame) # am Ziel-Frame angelangt?
- { if (mtypecode(STACK_0) & bit(frame_bit_t)) # liegt ein Frame vor?
- { unwind(); } # ja -> auflösen
- # (Sollte dies ein Unwind-Protect-Frame sein, so wird danach wieder
- # unwind_upto(upto_frame) aufgerufen, und wir sind wieder hier.)
- else
- { skipSTACK(1); } # nein -> einfach weiter
- }
- # Nun zeigt STACK auf den gefundenen FRAME.
- enter_frame_at_STACK();
- }
-
- # UP: throwt zum Tag tag und übergibt dabei die Werte mv_count/mv_space.
- # Kommt nur dann zurück, wenn es keinen CATCH-Frame dieses Tags gibt.
- # throw(tag);
- global void throw (object tag);
- global void throw(tag)
- var reg2 object tag;
- { # Suche nach Catch-Frame mit Tag =tag:
- var reg1 object* FRAME = STACK;
- loop # Suche im Stack ab FRAME nach einem CATCH-Frame mit demselben Tag:
- { if (eq(FRAME_(0),nullobj)) # Stackende?
- { return; } # ja -> kein passendes Catch vorhanden -> Rücksprung
- if (mtypecode(FRAME_(0)) & bit(frame_bit_t))
- # Frame gefunden
- { if ((mtypecode(FRAME_(0)) == CATCH_frame_info) # Catch-Frame?
- && eq(FRAME_(frame_tag),tag) # mit demselben Tag?
- )
- break; # ja -> Suchschleife fertig
- # Frame übergehen:
- FRAME = topofframe(FRAME_(0));
- }
- else
- { FRAME skipSTACKop 1; }
- }
- # FRAME zeigt auf den untersten CATCH-Frame mit demselben Tag
- unwind_upto(FRAME); # bis dorthin auflösen, dann anspringen
- }
-
- # UP: Ruft alle Handler zur Condition cond auf. Kommt nur zurück, wenn keiner
- # dieser Handler sich zuständig fühlt (d.h. wenn jeder Handler zurückkehrt).
- # invoke_handlers(cond);
- # kann GC auslösen
- global void invoke_handlers (object cond);
- # Variablen zur Übergabe von Information an den Beginn des Handlers:
- local struct { object condition; object* stack; SPint* sp; uintL spdepth; }
- handler_args;
- # Dies deaktiviert den Handler, der gerade aufgerufen wird,
- # und alle neueren Handler.
- # Da immer nur ganze Bereiche von Handlers deaktiviert und wieder aktiviert
- # werden, behandeln wir die Handler beim Deaktivieren nicht einzeln, sondern
- # führen eine Liste der STACK-Bereiche, in denen die Handler deaktiviert sind.
- typedef struct stack_range { struct stack_range * next;
- object* low_limit; object* high_limit;
- }
- stack_range;
- local stack_range * inactive_handlers = NULL;
- # Ein Handler gilt genau dann als inaktiv, wenn für einen der in
- # inactive_handlers aufgeführten Bereiche gilt:
- # low_limit <= handler < high_limit.
- global void invoke_handlers(cond)
- var reg2 object cond;
- { # Die Handler-Bereiche, die ausgeblendet werden:
- var stack_range* other_ranges = inactive_handlers;
- var stack_range new_range;
- # Suche nach Handler-Frame, der einen Typ behandelt mit (TYPEP cond type):
- {var reg1 object* FRAME = STACK;
- loop # Suche im Stack ab FRAME nach einem passenden HANDLER-Frame:
- { if (!(other_ranges == NULL) && (FRAME == other_ranges->low_limit))
- { FRAME = other_ranges->high_limit;
- other_ranges = other_ranges->next;
- }
- elif (eq(FRAME_(0),nullobj)) # Stackende?
- { break; } # ja -> fertig, Rücksprung
- elif (mtypecode(FRAME_(0)) & bit(frame_bit_t))
- # Frame gefunden
- { if (mtypecode(FRAME_(0)) == HANDLER_frame_info) # Handler-Frame?
- # Typen des Vektors #(type1 label1 ... typem labelm) durchlaufen:
- { var reg4 uintL m2 = TheSvector(Car(FRAME_(frame_handlers)))->length; # 2*m
- var reg3 uintL i = 0;
- do { pushSTACK(cond); # cond retten
- pushSTACK(cond);
- pushSTACK(TheSvector(Car(FRAME_(frame_handlers)))->data[i]); # typei
- funcall(S(safe_typep),2); # (SYS::SAFE-TYPEP cond typei) ausführen
- if (!nullp(value1)) # passender Handler gefunden?
- goto found_handler;
- cond = popSTACK(); # cond zurück
- i += 2;
- }
- while (i < m2);
- if (FALSE)
- found_handler:
- { # CLtL2 S. 873, 884: "A handler is executed in the dynamic context
- # of the signaler, except that the set of available condition
- # handlers will have been rebound to the value that was active
- # at the time the condition handler was made active."
- # Das Ganze sichern wir durch einen Unwind-Protect-Frame ab:
- var stack_range* saved_inactive_handlers = inactive_handlers;
- new_range.low_limit = STACK;
- new_range.high_limit = topofframe(FRAME_(0));
- new_range.next = other_ranges;
- {var reg4 object* top_of_frame = STACK;
- var jmp_buf returner; # Rücksprungpunkt
- finish_entry_frame(UNWIND_PROTECT,&!returner,_EMA_,
- { var reg5 restart fun = unwind_protect_to_save.fun;
- var reg6 object* arg = unwind_protect_to_save.upto_frame;
- skipSTACK(2); # Unwind-Protect-Frame auflösen
- # Cleanup: Handler reaktivieren:
- inactive_handlers = saved_inactive_handlers;
- # und weiterspringen:
- fun(arg);
- NOTREACHED
- });
- # Handler deaktivieren:
- inactive_handlers = &new_range;
- # Information für den Handler bereitlegen:
- handler_args.condition = STACK_(0+2);
- handler_args.stack = FRAME STACKop 4;
- handler_args.sp = (SPint*)(aint)as_oint(FRAME_(frame_SP));
- handler_args.spdepth = posfixnum_to_L(Cdr(FRAME_(frame_handlers)));
- # Handler aufrufen:
- {var reg4 object closure = FRAME_(frame_closure);
- var reg5 object codevec = TheCclosure(closure)->clos_codevec;
- var reg6 uintL index = (TheSbvector(codevec)->data[CCHD+4] & bit(7) ? CCHD+10 : CCHD+6)
- + posfixnum_to_L(TheSvector(Car(FRAME_(frame_handlers)))->data[i+1]);
- interpret_bytecode(closure,codevec,index);
- }
- skipSTACK(2); # Unwind-Protect-Frame auflösen
- # Handler reaktivieren:
- inactive_handlers = saved_inactive_handlers;
- }
- cond = popSTACK(); # cond zurück
- } }
- # Frame übergehen:
- FRAME = topofframe(FRAME_(0));
- }
- else
- { FRAME skipSTACKop 1; }
- }} }
-
- # UP: Stellt fest, ob ein Objekt ein Funktionsname, d.h. ein Symbol oder
- # eine Liste der Form (SETF symbol), ist.
- # funnamep(obj)
- # > obj: Objekt
- # < ergebnis: TRUE falls Funktionsname
- global boolean funnamep (object obj);
- global boolean funnamep(obj)
- var reg1 object obj;
- { if (symbolp(obj)) return TRUE;
- if (consp(obj) && eq(Car(obj),S(setf)))
- { obj = Cdr(obj);
- if (consp(obj) && nullp(Cdr(obj)) && msymbolp(Car(obj)))
- return TRUE;
- }
- return FALSE;
- }
-
- # UP: Liefert den Wert eines Symbols in einem Environment.
- # sym_value(symbol,venv)
- # > symbol: Symbol
- # > venv: ein Variablen- und Symbolmacro-Environment
- # < ergebnis: Wert des Symbols in diesem Environment
- local object sym_value (object sym, object venv);
- local object sym_value(sym,env)
- var reg6 object sym;
- var reg5 object env;
- { if (constantp(TheSymbol(sym))) goto global_value; # Konstanten haben nur globale Werte
- if (special_var_p(TheSymbol(sym))) goto global_value; # special deklarierte ebenso
- {
- #ifdef NO_symbolflags
- #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
- (eq(*(bindptr STACKop 1),sym) # richtiges Symbol? \
- && eq(*(bindingsptr STACKop 0),fixnum(bit(active_bit))) # und aktiv und statisch? \
- )
- #else
- var reg4 object cmp = as_object(as_oint(sym) | wbit(active_bit_o)); # zum Vergleich: Bindung muß aktiv sein
- #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
- (eq(*(bindingsptr STACKop 0),cmp)) # richtiges Symbol und aktiv und statisch?
- #endif
- next_env:
- switch (typecode(env))
- { case_system: # Environment ist ein Pointer auf einen Variablenbindungs-Frame
- { var reg2 object* FRAME = TheFramepointer(env);
- {var reg3 uintL count = as_oint(FRAME_(frame_anz)); # Anzahl der Bindungen
- var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
- dotimesL(count,count,
- { if (binds_sym_p(bindingsptr)) # richtiges Symbol und aktiv und statisch?
- { var reg1 object value = *(bindingsptr STACKop varframe_binding_value);
- if (eq(value,specdecl))
- { goto global_value; }
- else
- { return value; }
- }
- bindingsptr skipSTACKop varframe_binding_size; # nein: nächste Bindung
- });
- env = FRAME_(frame_next_env);
- goto next_env;
- }}
- case_svector: # Environment ist ein Simple-Vector
- goto next_vector;
- default: # Environment ist NIL
- goto global_value;
- }
- next_vector:
- # Environment ist ein Simple-Vector
- { var reg2 uintL count = floor(TheSvector(env)->length,2); # Anzahl der Bindungen
- var reg1 object* ptr = &TheSvector(env)->data[0];
- dotimesL(count,count,
- { if (eq(*ptr,sym)) # richtiges Symbol?
- { var reg1 object value = *(ptr+1);
- if (eq(value,specdecl))
- { goto global_value; }
- else
- { return value; }
- }
- ptr += 2; # nächste Bindung
- });
- env = *ptr; # nächstes Environment
- if (simple_vector_p(env)) goto next_vector; # ein Simple-Vector?
- # sonst: Environment ist NIL
- }
- #undef binds_sym_p
- }
- global_value: # Es gilt der globale (dynamische) Wert des Symbols
- return Symbol_value(sym);
- }
-
- # UP: Stellt fest, ob ein Symbol im aktuellen Environment einen Macro darstellt.
- # sym_macrop(symbol)
- # > symbol: Symbol
- # < ergebnis: TRUE falls sym einen Symbol-Macro darstellt
- global boolean sym_macrop (object sym);
- global boolean sym_macrop(sym)
- var reg2 object sym;
- { var reg1 object val = sym_value(sym,aktenv.var_env);
- return (symbolmacrop(val) ? TRUE : FALSE);
- }
-
- # UP: Setzt den Wert eines Symbols im aktuellen Environment.
- # setq(symbol,value);
- # > symbol: Symbol, keine Konstante
- # > value: gewünschter Wert des Symbols im aktuellen Environment
- global void setq (object sym, object value);
- global void setq(sym,value)
- var reg6 object sym;
- var reg7 object value;
- { if (special_var_p(TheSymbol(sym))) goto global_value; # special deklarierte ebenso
- {var reg5 object env = aktenv.var_env; # aktuelles VAR_ENV
- #ifdef NO_symbolflags
- #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
- (eq(*(bindptr STACKop 1),sym) # richtiges Symbol? \
- && eq(*(bindingsptr STACKop 0),fixnum(bit(active_bit))) # und aktiv und statisch? \
- )
- #else
- var reg4 object cmp = as_object(as_oint(sym) | wbit(active_bit_o)); # zum Vergleich: Bindung muß aktiv sein
- #define binds_sym_p(bindptr) # Bindet die Bindung bei bindptr das Symbol sym? \
- (eq(*(bindingsptr STACKop 0),cmp)) # richtiges Symbol und aktiv und statisch?
- #endif
- next_env:
- switch (typecode(env))
- { case_system: # Environment ist ein Pointer auf einen Variablenbindungs-Frame
- { var reg2 object* FRAME = TheFramepointer(env);
- {var reg3 uintL count = as_oint(FRAME_(frame_anz)); # Anzahl der Bindungen
- var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
- dotimesL(count,count,
- { if (binds_sym_p(bindingsptr)) # richtiges Symbol und aktiv und statisch?
- { if (eq(*(bindingsptr STACKop varframe_binding_value),specdecl))
- { goto global_value; }
- else
- { *(bindingsptr STACKop varframe_binding_value) = value; return; }
- }
- bindingsptr skipSTACKop varframe_binding_size; # nein: nächste Bindung
- });
- env = FRAME_(frame_next_env);
- goto next_env;
- }}
- case_svector: # Environment ist ein Simple-Vector
- goto next_vector;
- default: # Environment ist NIL
- goto global_value;
- }
- next_vector:
- # Environment ist ein Simple-Vector
- { var reg2 uintL count = floor(TheSvector(env)->length,2); # Anzahl der Bindungen
- var reg1 object* ptr = &TheSvector(env)->data[0];
- dotimesL(count,count,
- { if (eq(*ptr,sym)) # richtiges Symbol?
- { if (eq(*(ptr+1),specdecl))
- { goto global_value; }
- else
- { *(ptr+1) = value; return; }
- }
- ptr += 2; # nächste Bindung
- });
- env = *ptr; # nächstes Environment
- if (simple_vector_p(env)) goto next_vector; # ein Simple-Vector?
- # sonst: Environment ist NIL
- }
- #undef binds_sym_p
- }
- global_value: # Es gilt der globale (dynamische) Wert des Symbols
- set_Symbol_value(sym,value); return;
- }
-
- # UP: Liefert zu einem Symbol seine Funktionsdefinition in einem Environment
- # sym_function(sym,fenv)
- # > sym: Funktionsname (z.B. Symbol)
- # > fenv: ein Funktions- und Macrobindungs-Environment
- # < ergebnis: Funktionsdefinition, entweder unbound (falls undefinierte Funktion)
- # oder Closure/SUBR/FSUBR oder ein Cons (SYS::MACRO . expander).
- global object sym_function (object sym, object fenv);
- global object sym_function(sym,env)
- var reg6 object sym;
- var reg4 object env;
- { var reg5 object value;
- {next_env:
- switch (typecode(env))
- { case_system: # Environment ist ein Pointer auf einen Funktionsbindungs-Frame
- { var reg2 object* FRAME = TheFramepointer(env);
- {var reg3 uintL count = as_oint(FRAME_(frame_anz)); # Anzahl der Bindungen
- var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
- dotimesL(count,count,
- { if (equal(*(bindingsptr STACKop 0),sym)) # richtiges Symbol?
- { value = *(bindingsptr STACKop 1); goto fertig; }
- bindingsptr skipSTACKop 2; # nein: nächste Bindung
- });
- env = FRAME_(frame_next_env);
- goto next_env;
- }}
- case_svector: # Environment ist ein Simple-Vector
- goto next_vector;
- default: # Environment ist NIL
- goto global_value;
- }
- next_vector:
- # Environment ist ein Simple-Vector
- { var reg2 uintL count = floor(TheSvector(env)->length,2); # Anzahl der Bindungen
- var reg1 object* ptr = &TheSvector(env)->data[0];
- dotimesL(count,count,
- { if (equal(*ptr,sym)) # richtiges Symbol?
- { value = *(ptr+1); goto fertig; }
- ptr += 2; # nächste Bindung
- });
- env = *ptr; # nächstes Environment
- if (simple_vector_p(env)) goto next_vector; # ein Simple-Vector?
- # sonst: Environment ist NIL
- }
- }
- global_value: # Es gilt die globale Funktionsdefinition
- if (!symbolp(sym))
- { sym = get(Car(Cdr(sym)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
- if (!symbolp(sym)) # sollte (uninterniertes) Symbol sein
- { return unbound; } # sonst undefiniert
- }
- return Symbol_function(sym);
- fertig: # Symbol aktiv im Environment gefunden, "Wert" value
- # (eine Closure oder NIL oder ein Cons (SYS::MACRO . expander) )
- # Falls Definition = NIL (während LABELS), gilt die Funktion als
- # undefiniert:
- if (nullp(value)) { value = unbound; }
- return value;
- }
-
- # UP: Wertet eine Form in einem gegebenen Environment aus.
- # eval_5env(form,var,fun,block,go,decl);
- # > var_env: Wert für VAR_ENV
- # > fun_env: Wert für FUN_ENV
- # > block_env: Wert für BLOCK_ENV
- # > go_env: Wert für GO_ENV
- # > decl_env: Wert für DECL_ENV
- # > form: Form
- # < mv_count/mv_space: Werte
- # kann GC auslösen
- global Values eval_5env (object form, object var_env, object fun_env, object block_env, object go_env, object decl_env);
- global Values eval_5env(form,var_env,fun_env,block_env,go_env,decl_env)
- var reg2 object form;
- var reg3 object var_env;
- var reg4 object fun_env;
- var reg5 object block_env;
- var reg6 object go_env;
- var reg7 object decl_env;
- { # Environments binden:
- make_ENV5_frame();
- # aktuelle Environments setzen:
- aktenv.var_env = var_env;
- aktenv.fun_env = fun_env;
- aktenv.block_env = block_env;
- aktenv.go_env = go_env;
- aktenv.decl_env = decl_env;
- # Form auswerten:
- eval(form);
- # Environment-Frame auflösen:
- unwind();
- return; # fertig
- }
-
- # UP: Wertet eine Form in einem leeren Environment aus.
- # eval_noenv(form);
- # > form: Form
- # < mv_count/mv_space: Werte
- # kann GC auslösen
- global Values eval_noenv (object form);
- global Values eval_noenv(form)
- var reg1 object form;
- { return_Values eval_5env(form,NIL,NIL,NIL,NIL,O(top_decl_env)); }
-
- # UP: "nestet" ein FUN-Environment, d.h. schreibt alle aktiven Bindungen
- # aus dem Stack in neu allozierte Vektoren.
- # nest_fun(env)
- # > env: FUN-Env
- # < ergebnis: selbes Environment, kein Pointer in den Stack
- # kann GC auslösen
- global object nest_fun (object env);
- global object nest_fun(env)
- var reg5 object env;
- { var reg6 uintL depth = 0; # Rekursionszähler:=0
- # Pseudorekursion mit Input env, Output env.
- nest_start: # Rekursionsbeginn
- if (typecode(env) == system_type)
- # env ist ein Pointer auf einen STACK-Frame.
- { check_STACK();
- pushSTACK(env); # env retten
- # entrekursiviert nest_fun(NEXT_ENV(env)) durchführen:
- {var reg1 object* FRAME = TheFramepointer(env);
- env = FRAME_(frame_next_env); depth++; goto nest_start;
- }
- nest_reentry: depth--;
- # NEXT_ENV ist nun genestet.
- {var reg4 object* FRAME = TheFramepointer(STACK_0); # nächster zu nestender STACK-Frame
- STACK_0 = env; # bisher genestetes Environment
- {var reg3 uintL anzahl = as_oint(FRAME_(frame_anz)); # Anzahl der noch nicht genesteten Bindungen
- if (anzahl == 0)
- # keine Bindungen -> unnötig, einen Vektor zu erzeugen.
- { env = popSTACK(); }
- else
- # Vektor für anzahl Bindungen erzeugen:
- { env = allocate_vector(2*anzahl+1);
- # und füllen:
- { var reg1 object* ptr = &TheSvector(env)->data[0];
- var reg2 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
- # anzahl Bindungen ab bindingsptr in den Vektor ab ptr eintragen:
- dotimespL(anzahl,anzahl,
- { *ptr++ = *(bindingsptr STACKop 0); # Bindung in den Vektor kopieren
- *ptr++ = *(bindingsptr STACKop 1);
- bindingsptr skipSTACKop 2;
- });
- *ptr++ = popSTACK(); # genestetes NEXT_ENV in Vektor eintragen
- }
- FRAME_(frame_next_env) = env; # Vektor als NEXT_ENV in den Frame
- FRAME_(frame_anz) = as_object(0); # neue Zahl noch nicht genesteter Bindungen
- }
- } }}
- # mit diesem Nest-Teilschritt fertig.
- if (depth>0) goto nest_reentry; # Ende der Rekursion
- return env;
- }
-
- # UP: "nestet" ein VAR-Environment, d.h. schreibt alle aktiven Bindungen
- # aus dem Stack in neu allozierte Vektoren.
- # nest_var(env)
- # > env: VAR-Env
- # < ergebnis: selbes Environment, kein Pointer in den Stack
- # kann GC auslösen
- local object nest_var (object env);
- local object nest_var(env)
- var reg6 object env;
- { var reg7 uintL depth = 0; # Rekursionszähler:=0
- # Pseudorekursion mit Input env, Output env.
- nest_start: # Rekursionsbeginn
- if (typecode(env) == system_type)
- # env ist ein Pointer auf einen STACK-Frame.
- { check_STACK();
- pushSTACK(env); # env retten
- # entrekursiviert nest_var(NEXT_ENV(env)) durchführen:
- {var reg1 object* FRAME = TheFramepointer(env);
- env = FRAME_(frame_next_env); depth++; goto nest_start;
- }
- nest_reentry: depth--;
- # NEXT_ENV ist nun genestet.
- {var reg5 object* FRAME = TheFramepointer(STACK_0); # nächster zu nestender STACK-Frame
- STACK_0 = env; # bisher genestetes Environment
- # Suche (von unten) die erste aktive unter den noch nicht
- # genesteten Bindungen:
- {var reg3 uintL anzahl = as_oint(FRAME_(frame_anz)); # Anzahl der noch nicht genesteten Bindungen
- var reg4 uintL count = 0;
- var reg1 object* bindingsptr = &FRAME_(frame_bindings); # Pointer auf die erste Bindung
- until ((count>=anzahl) # alle ungenesteten Bindungen durch?
- || (as_oint(*(bindingsptr STACKop 0)) & wbit(active_bit_o)) # aktive Bindung entdeckt?
- )
- { # nein -> weitersuchen:
- bindingsptr skipSTACKop varframe_binding_size;
- count++;
- }
- # Unterhalb von bindingsptr sind count inaktive Bindungen.
- # Ab bindingsptr kommen anzahl-count aktive, zu nestende Bindungen.
- anzahl = anzahl-count; # Anzahl zu nestender Bindungen
- if (anzahl == 0)
- # keine Bindungen -> unnötig, einen Vektor zu erzeugen.
- { env = popSTACK(); }
- else
- # Vektor für anzahl Bindungen erzeugen:
- { env = allocate_vector(2*anzahl+1);
- # und füllen:
- { var reg2 object* ptr = &TheSvector(env)->data[0];
- # Bindungen ab bindingsptr in den Vektor ab ptr eintragen:
- dotimespL(anzahl,anzahl,
- { if (as_oint(*(bindingsptr STACKop varframe_binding_mark)) & wbit(dynam_bit_o)) # Bindung dynamisch?
- # dynamische Bindung, lexikalische Sichtbarkeit
- { *ptr++ = symbol_without_flags(*(bindingsptr STACKop varframe_binding_sym)); # Symbol ohne Flag-Bits in den Vektor
- *ptr++ = specdecl; # als special reference kennzeichnen
- # Bindung bleibt im Frame aktiv
- }
- else
- # statische Bindung, lexikalische Sichtbarkeit
- { *(oint*)(bindingsptr STACKop varframe_binding_mark) &= ~wbit(active_bit_o); # Bindung inaktivieren
- *ptr++ = *(bindingsptr STACKop varframe_binding_sym); # Bindung in den Vektor kopieren
- *ptr++ = *(bindingsptr STACKop varframe_binding_value);
- }
- bindingsptr skipSTACKop varframe_binding_size;
- });
- *ptr++ = popSTACK(); # genestetes NEXT_ENV in Vektor eintragen
- }
- FRAME_(frame_next_env) = env; # Vektor als NEXT_ENV in den Frame
- FRAME_(frame_anz) = as_object(count); # neue Zahl noch nicht genesteter Bindungen
- }
- } }}
- # mit diesem Nest-Teilschritt fertig.
- if (depth>0) goto nest_reentry; # Ende der Rekursion
- return env;
- }
-
- # Macro: Legt fünf einzelne Environment auf den STACK
- # und bildet daraus ein einzelnes Environment.
- # make_STACK_env(venv,fenv,benv,genv,denv, env5 = );
- # > object venv,fenv,benv,genv,denv: 5 einzelne Environments
- # < environment* env5: Pointer auf im Stack liegendes Environment
- #ifdef STACK_UP
- #define make_STACK_env(venv,fenv,benv,genv,denv,env5_zuweisung) \
- { pushSTACK(venv); pushSTACK(fenv); pushSTACK(benv); pushSTACK(genv); pushSTACK(denv); \
- env5_zuweisung &STACKblock_(environment,0); \
- }
- #endif
- #ifdef STACK_DOWN
- #define make_STACK_env(venv,fenv,benv,genv,denv,env5_zuweisung) \
- { pushSTACK(denv); pushSTACK(genv); pushSTACK(benv); pushSTACK(fenv); pushSTACK(venv); \
- env5_zuweisung &STACKblock_(environment,0); \
- }
- #endif
-
- # UP: Nestet die Environments in *env (d.h. schreibt alle Informationen in
- # Stack-unabhängige Strukturen) und schiebt sie auf den STACK.
- # (Die Werte VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV werden nicht
- # verändert, da evtl. noch inaktive Bindungen in Frames sitzen, die ohne
- # Veränderung von VAR_ENV aktiviert werden können müssen.)
- # nest_env(env)
- # > environment* env: Pointer auf fünf einzelne Environments
- # < environment* ergebnis: Pointer auf die Environments im STACK
- # verändert STACK, kann GC auslösen
- global environment* nest_env (environment* env);
- global environment* nest_env(env5)
- var reg6 environment* env5;
- { # Erst alle Environments in den STACK kopieren:
- make_STACK_env(env5->var_env,env5->fun_env,env5->block_env,env5->go_env,env5->decl_env,
- env5 = );
- # DECL_ENV: Nicht zu verändern.
- # GO_ENV:
- { var reg5 object env = env5->go_env;
- var reg9 uintL depth = 0; # Rekursionstiefe := 0
- # Pseudo-Rekursion: nestet ein GO_ENV.
- # Input: env, ein GO_ENV. Output: env, die Aliste dazu.
- nest_go_start: # Rekursionsbeginn
- if (typecode(env) == system_type)
- # env ist ein Pointer in den STACK auf einen ITAGBODY-Frame.
- { check_STACK();
- {var reg4 object* FRAME = TheFramepointer(env);
- if (mtypecode(FRAME_(0)) & bit(nested_bit_t)) # Frame schon genestet?
- { env = FRAME_(frame_next_env); } # ja -> bisherige Aliste holen
- else
- { pushSTACK(env); # env retten
- # entrekursiviert nest_go(NEXT_ENV(env)) durchführen:
- env = FRAME_(frame_next_env); depth++; goto nest_go_start;
- nest_go_reentry: depth--;
- # NEXT_ENV ist nun genestet.
- { var reg8 object frame = STACK_0; # nächster zu nestender STACK-Frame
- FRAME = uTheFramepointer(frame);
- STACK_0 = env; # bisher genestetes Environment
- {var reg1 object* tagsptr = &FRAME_(frame_bindings); # Pointer aufs unterste Tag
- var reg7 object* frame_end = STACKpointable(topofframe(FRAME_(0))); # Pointer übern Frame
- var reg3 uintL count = # Anzahl der Tags
- # Dazu die Pointer tagsptr und frame_end (beide ohne Typinfo!) abziehen:
- STACK_item_count(tagsptr,frame_end) / 2;
- # Vektor für count Tags erzeugen:
- { var reg6 object tagvec = allocate_vector(count);
- # und füllen:
- { var reg2 object* ptr = &TheSvector(tagvec)->data[0];
- # Tags ab tagsptr in den Vektor ab ptr eintragen:
- dotimesL(count,count,
- { *ptr++ = *(tagsptr STACKop 0);
- tagsptr skipSTACKop 2;
- });
- }
- pushSTACK(tagvec); # und retten
- }
- # Nächstes Alistencons (cons Tag-Vektor Frame-Pointer) erzeugen:
- { var reg2 object new_cons = allocate_cons();
- Car(new_cons) = STACK_0; # tagvec
- Cdr(new_cons) = frame;
- STACK_0 = new_cons;
- }
- # und vor die Aliste hängen:
- env = allocate_cons();
- Car(env) = popSTACK(); # new_cons
- Cdr(env) = popSTACK(); # bisherige Aliste
- FRAME_(frame_next_env) = env; # neues NEXT_ENV eintragen
- *(oint*)(&FRAME_(0)) |= wbit(nested_bit_o); # Dieser Frame ist nun genestet.
- }}}
- }}
- # mit diesem Nest-Teilschritt fertig.
- if (depth>0) goto nest_go_reentry; # Ende der Rekursion
- env5->go_env = env; # genestetes GO_ENV ablegen
- }
- # BLOCK_ENV:
- { var reg2 object env = env5->block_env;
- var reg5 uintL depth = 0; # Rekursionstiefe := 0
- # Pseudo-Rekursion: nestet ein BLOCK_ENV.
- # Input: env, ein BLOCK_ENV. Output: env, die Aliste dazu.
- nest_block_start: # Rekursionsbeginn
- if (typecode(env) == system_type)
- # env ist ein Pointer in den STACK auf einen IBLOCK-Frame.
- { check_STACK();
- {var reg1 object* FRAME = TheFramepointer(env);
- if (mtypecode(FRAME_(0)) & bit(nested_bit_t)) # Frame schon genestet?
- { env = FRAME_(frame_next_env); } # ja -> bisherige Aliste holen
- else
- { pushSTACK(env); # env retten
- # entrekursiviert nest_block(NEXT_ENV(env)) durchführen:
- env = FRAME_(frame_next_env); depth++; goto nest_block_start;
- nest_block_reentry: depth--;
- # NEXT_ENV ist nun genestet.
- {var reg4 object frame = STACK_0; # nächster zu nestender STACK-Frame
- FRAME = TheFramepointer(frame);
- STACK_0 = env; # bisher genestetes Environment
- # Nächstes Alistencons (cons Block-Name Frame-Pointer) erzeugen:
- { var reg3 object new_cons = allocate_cons();
- Car(new_cons) = FRAME_(frame_name);
- Cdr(new_cons) = frame;
- pushSTACK(new_cons);
- }
- # und vor die Aliste hängen:
- env = allocate_cons();
- Car(env) = popSTACK(); # new_cons
- Cdr(env) = popSTACK(); # bisherige Aliste
- FRAME_(frame_next_env) = env; # neues NEXT_ENV eintragen
- *(oint*)(&FRAME_(0)) |= wbit(nested_bit_o); # Dieser Frame ist nun genestet.
- }}
- }}
- # mit diesem Nest-Teilschritt fertig.
- if (depth>0) goto nest_block_reentry; # Ende der Rekursion
- env5->block_env = env; # genestetes BLOCK_ENV ablegen
- }
- # FUN_ENV:
- env5->fun_env = nest_fun(env5->fun_env);
- # VAR_ENV:
- env5->var_env = nest_var(env5->var_env);
- # fertig.
- return env5;
- }
-
- # UP: Nestet die aktuellen Environments (d.h. schreibt alle Informationen in
- # Stack-unabhängige Strukturen) und schiebt sie auf den STACK.
- # (Die Werte VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV werden nicht
- # verändert, da evtl. noch inaktive Bindungen in Frames sitzen, die ohne
- # Veränderung von VAR_ENV aktiviert werden können müssen.)
- # nest_aktenv()
- # < environment* ergebnis: Pointer auf die Environments im STACK
- # verändert STACK, kann GC auslösen
- #define nest_aktenv() nest_env(&aktenv)
-
- # UP: Ergänzt ein Deklarations-Environment um ein decl-spec.
- # augment_decl_env(declspec,env)
- # > declspec: Deklarations-Specifier, ein Cons
- # > env: Deklarations-Environment
- # < ergebnis: neues (evtl. augmentiertes) Deklarations-Environment
- # kann GC auslösen
- global object augment_decl_env (object new_declspec, object env);
- global object augment_decl_env(new_declspec,env)
- var reg6 object new_declspec;
- var reg5 object env;
- { var reg2 object decltype = Car(new_declspec); # Deklarations-Typ
- # Ist dies ein zu beachtender Deklarationstyp?
- # Gibt es in env ein Decl-Spec der Form (DECLARATION ... decltype ...) ?
- # NB: Die Liste O(declaration_types) ist das letzte Decl-Spec in env.
- if (symbolp(decltype))
- { # Alle lokal zu beachtenden Deklarations-Typen durchgehen:
- { var reg4 object declspecs = env;
- while (consp(declspecs)) # Alle declspecs aus env durchgehen
- { var reg3 object declspec = Car(declspecs);
- if (eq(Car(declspec),S(declaration))) # Deklaration (DECLARATION ...) ?
- { var reg1 object list = Cdr(declspec); # ja -> restliche Liste durchgehen
- while (consp(list))
- { if (eq(Car(list),decltype)) # Listenelement = decltype ?
- goto beachten;
- list = Cdr(list);
- } }
- declspecs = Cdr(declspecs);
- } }
- }
- # nicht zu beachtende Deklaration.
- return env; # env unverändert lassen
- beachten:
- # eine zu beachtende Deklaration -> env := (cons new_declspec env)
- pushSTACK(env); pushSTACK(new_declspec);
- env = allocate_cons();
- Car(env) = popSTACK(); Cdr(env) = popSTACK();
- return env;
- }
-
- # UP: expandiert eine Form, falls möglich, (nicht jedoch, wenn FSUBR-Aufruf
- # oder Symbol) in einem Environment
- # macroexp(form,venv,fenv);
- # > form: Form
- # > venv: ein Variablen- und Symbolmacro-Environment
- # > fenv: ein Funktions- und Macrobindungs-Environment
- # < value1: die Expansion
- # < value2: NIL, wenn nicht expandiert,
- # T, wenn expandiert wurde
- # kann GC auslösen
- global void macroexp (object form, object venv, object fenv);
- global void macroexp(form,venv,fenv)
- var reg2 object form;
- var reg5 object venv;
- var reg4 object fenv;
- { if (consp(form)) # nur Listen können Macro-call sein
- { var reg3 object funname = Car(form); # Funktionsname
- if (symbolp(funname))
- { var reg1 object fdef = sym_function(funname,fenv); # Funktionsdefinition holen
- # Ist sie (SYS::MACRO . Expander) ?
- if (consp(fdef) && eq(Car(fdef),S(macro)))
- # ja -> expandieren:
- { # (FUNCALL *MACROEXPAND-HOOK* expander form env) ausführen:
- pushSTACK(Cdr(fdef)); # Expander als erstes Argument
- pushSTACK(form); # Form als zweites Argument
- pushSTACK(fenv);
- pushSTACK(nest_var(venv)); # genestetes Variablen- und Symbolmacro-Environment
- STACK_1 = nest_fun(STACK_1); # genestetes Funktions- und Macrobindungs-Environment
- {var reg6 object env = allocate_vector(2); # Environment für beide
- TheSvector(env)->data[0] = popSTACK(); # venv als 1. Komponente
- TheSvector(env)->data[1] = STACK_0; # fenv als 2. Komponente
- STACK_0 = env; # Environment als drittes Argument
- funcall(Symbol_value(S(macroexpand_hook)),3);
- value2 = T; # expandierte Form als 1. Wert, T als 2. Wert
- return;
- }}
- } }
- # sonst nicht expandieren:
- value1 = form; value2 = NIL;
- }
-
- # UP: expandiert eine Form, falls möglich, (auch, wenn FSUBR-Aufruf)
- # in einem Environment
- # macroexp0(form,env);
- # > form: Form
- # > env: ein Macroexpansions-Environment
- # < value1: die Expansion
- # < value2: NIL, wenn nicht expandiert,
- # T, wenn expandiert wurde
- # kann GC auslösen
- global void macroexp0 (object form, object env);
- global void macroexp0(form,env)
- var reg4 object form;
- var reg6 object env;
- { if (consp(form)) # nur Listen können Macro-call sein
- { var reg5 object funname = Car(form); # Funktionsname
- if (symbolp(funname))
- { var reg3 object fdef = sym_function(funname,TheSvector(env)->data[1]); # Funktionsdefinition holen
- if (fsubrp(fdef))
- # fdef ist ein FSUBR, also war die globale Funktionsdefinition gültig.
- # Schaue nach, ob die Propertyliste eine Macrodefinition enthält:
- { var reg1 object expander = get(funname,S(macro)); # nach Property SYS::MACRO suchen
- if (!eq(expander,unbound))
- # gefunden. Mit dem Expander aus der Propertyliste expandieren:
- { # (FUNCALL *MACROEXPAND-HOOK* expander form env) ausführen:
- pushSTACK(expander); # Expander als erstes Argument
- pushSTACK(form); # Form als zweites Argument
- pushSTACK(env); # Environment als drittes Argument
- funcall(Symbol_value(S(macroexpand_hook)),3);
- value2 = T; # expandierte Form als 1. Wert, T als 2. Wert
- return;
- } }
- else
- # 3 Möglichkeiten:
- # #UNBOUND/SUBR/Closure (globale oder lexikalische Funktionsdef.)
- # -> nicht expandieren
- # (SYS::MACRO . Expander) (lexikalische Macrodefinition)
- # -> expandieren (Expander aufrufen)
- # Symbol (lexikalische Funktionsdefinition während SYS::%EXPAND)
- # expandieren: (list* 'SYS::%FUNCALL Symbol (cdr form))
- if (consp(fdef))
- { # Ist es (SYS::MACRO . Expander) ?
- if (eq(Car(fdef),S(macro)))
- # ja -> expandieren:
- { # (FUNCALL *MACROEXPAND-HOOK* expander form env) ausführen:
- pushSTACK(Cdr(fdef)); # Expander als erstes Argument
- pushSTACK(form); # Form als zweites Argument
- pushSTACK(env); # Environment als drittes Argument
- funcall(Symbol_value(S(macroexpand_hook)),3);
- value2 = T; # expandierte Form als 1. Wert, T als 2. Wert
- return;
- } }
- elif (symbolp(fdef))
- # fdef ein Symbol
- { # Muß zu (SYS::%FUNCALL fdef ...) expandieren:
- pushSTACK(Cdr(form)); # (cdr form)
- pushSTACK(fdef); # Symbol
- {var reg1 object new_cons = allocate_cons();
- Car(new_cons) = popSTACK(); Cdr(new_cons) = STACK_0;
- STACK_0 = new_cons; # (cons Symbol (cdr form))
- }
- {var reg1 object new_cons = allocate_cons();
- Car(new_cons) = S(pfuncall); Cdr(new_cons) = popSTACK();
- value1 = new_cons; # (cons 'SYS::%FUNCALL (cons Symbol (cdr form)))
- }
- value2 = T; return; # es wurde expandiert.
- }
- } }
- elif (symbolp(form))
- { var reg1 object val = sym_value(form,TheSvector(env)->data[0]);
- if (symbolmacrop(val)) # Symbol-Macro gefunden?
- # ja -> expandieren
- { value1 = TheSymbolmacro(val)->symbolmacro_expansion; value2 = T; return; }
- }
- # sonst nicht expandieren:
- value1 = form; value2 = NIL;
- }
-
- # UP: Parse-Declarations-Docstring. Trennt von einer Formenliste diejenigen
- # ab, die als Deklarationen bzw. Dokumentationsstring angesehen werden
- # müssen.
- # parse_dd(formlist,venv,fenv)
- # > formlist: ( {decl|doc-string} . body )
- # > venv: ein Variablen- und Symbolmacro-Environment (für die Macroexpansionen)
- # > fenv: Funktions- und Macrobindungs-Environment (für die Macroexpansionen)
- # < value1: body
- # < value2: Liste der decl-specs
- # < value3: Doc-String oder NIL
- # < ergebnis: TRUE falls eine (COMPILE)-Deklaration vorkam, FALSE sonst
- # kann GC auslösen
- global boolean parse_dd (object formlist, object venv, object fenv);
- global boolean parse_dd(formlist,venv,fenv)
- var reg8 object formlist;
- var reg7 object venv;
- var reg6 object fenv;
- { pushSTACK(formlist); # formlist aufheben für Fehlermeldung
- pushSTACK(venv); # Variablen-Environment
- pushSTACK(fenv); # Macrobindungs-Environment
- pushSTACK(NIL); # vorläufiger Doc-String
- pushSTACK(NIL); # Anfang decl-spec-Liste
- # Stackaufbau: formlist, venv, fenv, docstring, declspecs.
- {var reg5 boolean compile_decl = FALSE; # Flag, ob eine (COMPILE)-Deklaration vorkam
- var reg2 object body = formlist; # Rest der Formenliste
- while (consp(body))
- { pushSTACK(body); # body retten
- { var reg1 object form = Car(body); # nächste Form
- # evtl. macroexpandieren (ohne FSUBRs, Symbole zu expandieren):
- do { macroexp(form,STACK_(3+1),STACK_(2+1)); form = value1; }
- until (nullp(value2));
- body = popSTACK();
- {var reg4 object body_rest = Cdr(body); # body verkürzen
- if (stringp(form)) # Doc-String gefunden?
- { if (atomp(body_rest)) # an letzter Stelle der Formenliste?
- goto fertig; # ja -> letzte Form kann kein Doc-String sein!
- if (!nullp(STACK_1)) # schon ein Doc-String dagewesen?
- # ja -> mehr als ein Doc-String ist zuviel:
- { pushSTACK(STACK_4); # formlist
- //: DEUTSCH "In ~ kommen zu viele Doc-Strings vor."
- //: ENGLISH "Too many documentation strings in ~"
- //: FRANCAIS "Trop de chaînes de documentation dans ~."
- fehler(program_error, GETTEXT("Too many documentation strings in ~"));
- }
- STACK_1 = form; # neuer Doc-String
- body = body_rest;
- }
- elif (consp(form) && eq(Car(form),S(declare))) # Deklaration (DECLARE ...) ?
- { # neue decl-specs einzeln auf STACK_0 consen:
- pushSTACK(body_rest); # body_rest retten
- pushSTACK(Cdr(form)); # Liste der neuen decl-specs
- while (mconsp(STACK_0))
- {{var reg3 object declspec = Car(STACK_0); # nächstes decl-spec
- # Teste, ob (EQUAL d '(COMPILE)) =
- # (and (consp d) (eq (car d) 'COMPILE) (null (cdr d)))
- if (consp(declspec)
- && eq(Car(declspec),S(compile))
- && nullp(Cdr(declspec))
- )
- { compile_decl = TRUE; }
- }# Diese Deklaration auf STACK_(0+2) consen:
- {var reg3 object new_cons = allocate_cons();
- Car(new_cons) = Car(STACK_0);
- Cdr(new_cons) = STACK_(0+2);
- STACK_(0+2) = new_cons;
- }# zum nächsten decl-spec:
- STACK_0 = Cdr(STACK_0);
- }
- skipSTACK(1);
- body = popSTACK(); # body := alter body_rest
- }
- else
- { fertig: # fertig mit Durchlaufen der Formenliste
- #if 0
- # Das war einmal eine schöne Optimierung, die zweimaliges
- # Macroexpandieren vermied. Leider ist sie nicht mehr sicher,
- # denn bei (FUNCTION (LAMBDA ...)), LET, LET*, MULTIPLE-VALUE-BIND
- # wird das äußere(!) Variablen-Environment übergeben, so daß in
- # (SYMBOL-MACROLET ((X Y)) (LET ((X (FOO))) (SETF X ...) ...))
- # der SETF-Macro ein verkehrtes venv übergeben bekäme und zu
- # (SETQ Y ...) expandieren würde.
- if (!eq(form,Car(body))) # sofern die Form expandiert wurde,
- # ersetze body durch (cons form (cdr body)) :
- { pushSTACK(body_rest); pushSTACK(form);
- body = allocate_cons();
- Car(body) = popSTACK(); # form
- Cdr(body) = popSTACK(); # body_rest
- }
- #endif
- break;
- }
- }}}
- value1 = body;
- value2 = nreverse(popSTACK()); # decl-spec-Liste
- value3 = popSTACK(); # Doc-String
- skipSTACK(3);
- return compile_decl;
- }}
-
- # UP: bindet *EVALHOOK* und *APPLYHOOK* dynamisch an die gegebenen Werte.
- # bindhooks(evalhook_value,applyhook_value);
- # > evalhook_value: Wert für *EVALHOOK*
- # > applyhook_value: Wert für *APPLYHOOK*
- # verändert STACK
- # kann GC auslösen
- global void bindhooks (object evalhook_value, object applyhook_value);
- global void bindhooks(evalhook_value,applyhook_value)
- var reg2 object evalhook_value;
- var reg3 object applyhook_value;
- {
- # Frame aufbauen:
- { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
- pushSTACK(Symbol_symvalue(S(evalhookstern))); # alter Wert von *EVALHOOK*
- pushSTACK(S(evalhookstern)); # *EVALHOOK*
- pushSTACK(Symbol_symvalue(S(applyhookstern))); # alter Wert von *APPLYHOOK*
- pushSTACK(S(applyhookstern)); # *APPLYHOOK*
- finish_frame(DYNBIND);
- }
- # Frame fertig aufgebaut, nun die Werte der Variablen verändern:
- set_Symbol_symvalue(S(evalhookstern),evalhook_value); # (SETQ *EVALHOOK* evalhook_value)
- set_Symbol_symvalue(S(applyhookstern),applyhook_value); # (SETQ *APPLYHOOK* applyhook_value)
- #ifdef DYNBIND_LIST
- add_frame_to_binding_list(&STACK_0);
- #endif
- }
-
- # UP: bindet *EVALHOOK* und *APPLYHOOK* dynamisch an NIL.
- # bindhooks_NIL();
- # verändert STACK
- # kann GC auslösen
- #define bindhooks_NIL() bindhooks(NIL,NIL)
-
- # UP: Bestimmt den Source-Lambdabody eines Lambdabody.
- # lambdabody_source(lambdabody)
- # > lambdabody: Lambdabody (ein Cons)
- # < ergebnis: Source-Lambdabody (unbound falls keine Source angegeben)
- local object lambdabody_source (object lambdabody);
- local object lambdabody_source(lambdabody)
- var reg3 object lambdabody;
- { var reg2 object body = Cdr(lambdabody);
- # body = ((DECLARE (SOURCE ...) ...) ...) ?
- if (consp(body))
- { var reg1 object form = Car(body); # erste Form
- # form = (DECLARE (SOURCE ...) ...) ?
- if (consp(form) && eq(Car(form),S(declare)))
- { var reg6 object declspecs = Cdr(form);
- # declspecs = ((SOURCE ...) ...) ?
- if (consp(declspecs))
- { var reg5 object declspec = Car(declspecs);
- # declspec = (SOURCE ...) ?
- if (consp(declspec) && eq(Car(declspec),S(source)))
- { var reg4 object declspecr = Cdr(declspec);
- if (consp(declspecr))
- # Source gefunden
- { return Car(declspecr); }
- } } } }
- return unbound;
- }
-
- # UP: Erzeugt zu einem Lambdabody die entsprechende Closure durch Zerlegen
- # der Lambdaliste und eventuelles Macroexpandieren aller Formen.
- # get_closure(lambdabody,name,env)
- # > lambdabody: (lambda-list {decl|doc} {form})
- # > name: Name, ein Symbol oder (SETF symbol)
- # > env: Pointer auf die fünf einzelnen Environments:
- # env->var_env = VENV, env->fun_env = FENV,
- # env->block_env = BENV, env->go_env = GENV,
- # end->decl_env = DENV.
- # < ergebnis: Closure
- # kann GC auslösen
- global object get_closure (object lambdabody, object name, environment* env);
- global object get_closure(lambdabody,name,env)
- var reg10 object lambdabody;
- var reg10 object name;
- var reg10 environment* env;
- { # Lambdabody muß ein Cons sein:
- if (atomp(lambdabody))
- { pushSTACK(name);
- //: DEUTSCH "FUNCTION: Lambda-Liste für ~ fehlt."
- //: ENGLISH "FUNCTION: lambda-list for ~ is missing"
- //: FRANCAIS "FUNCTION: La liste lambda pour ~ manque."
- fehler(program_error, GETTEXT("FUNCTION: lambda-list for ~ is missing"));
- }
- # und der CAR muß eine Liste sein:
- {var reg1 object lambdalist = Car(lambdabody);
- if (!listp(lambdalist))
- { pushSTACK(lambdalist);
- pushSTACK(name);
- //: DEUTSCH "FUNCTION: Lambda-Liste für ~ muß eine Liste sein, nicht ~"
- //: ENGLISH "FUNCTION: lambda-list for ~ should be a list, not ~"
- //: FRANCAIS "FUNCTION: La liste lambda pour ~ doit être une liste et non ~"
- fehler(program_error, GETTEXT("FUNCTION: lambda-list for ~ should be a list, not ~"));
- } }
- pushSTACK(name);
- pushSTACK(lambdabody);
- # Stackaufbau: name, lambdabody.
- if (parse_dd(Cdr(lambdabody),env->var_env,env->fun_env)) # ({decl|doc} {form}) zerlegen
- # Es trat eine (COMPILE)-Deklaration auf.
- { # Lambdabody durch seine Source ersetzen (denn manche Macros
- # können effizienter compiliert werden als ihre Macro-Expansion):
- { var reg1 object source = lambdabody_source(STACK_0);
- if (!eq(source,unbound)) { STACK_0 = source; }
- }
- # Environments nesten:
- { var reg1 environment* stack_env = nest_env(env); # nesten, auf den STACK legen
- #if !defined(STACK_UP)
- var environment my_env;
- my_env = *stack_env; # und hierher übertragen
- skipSTACK(5); # und wieder vom STACK nehmen
- pushSTACK(my_env.var_env);
- pushSTACK(my_env.fun_env);
- pushSTACK(my_env.block_env);
- pushSTACK(my_env.go_env);
- pushSTACK(my_env.decl_env);
- #endif
- # Stackaufbau: name, lambdabody, venv, fenv, benv, genv, denv.
- }
- # (SYS::COMPILE-LAMBDA name lambdabody venv fenv benv genv denv) ausführen:
- funcall(S(compile_lambda),7);
- return value1; # compilierte Closure als Wert
- }
- # Interpretierte Closure bauen:
- { var reg1 object source = lambdabody_source(STACK_0);
- if (eq(source,unbound))
- # keine Source angegeben -> Lambdabody expandieren:
- { # (SYS::%EXPAND-LAMBDABODY-MAIN lambdabody venv fenv) aufrufen:
- pushSTACK(STACK_0); # Lambdabody als 1. Argument
- pushSTACK(nest_var(env->var_env)); # Variablen-Environment genestet als 2. Argument
- pushSTACK(nest_fun(env->fun_env)); # Funktions-Environment genestet als 3. Argument
- funcall(S(expand_lambdabody_main),3);
- lambdabody = value1; # expandierter Lambdabody
- }
- else
- # Source angegeben -> sie ersetzt den alten Lambdabody:
- { lambdabody = STACK_0; # Lambdabody
- STACK_0 = source; # Source-Lambdabody
- }
- }
- # Nun ist STACK_0 der Source-Lambdabody,
- # lambdabody der zu verwendende Lambdabody.
- pushSTACK(Car(lambdabody)); # Lambdaliste
- parse_dd(Cdr(lambdabody),env->var_env,env->fun_env); # ({decl|doc} {form}) zerlegen
- pushSTACK(value1); # Body
- pushSTACK(value2); # Deklarationen
- pushSTACK(value3); # Doc-String oder NIL
- {var reg3 object* closure_; # Pointer auf die Closure im STACK
- # Closure erzeugen (mit NIL gefüllt):
- { var reg1 object closure = allocate_srecord(0,Rectype_Closure,iclos_length,closure_type);
- # und teilweise füllen:
- TheIclosure(closure)->clos_docstring = popSTACK(); # Doc-String
- { var reg5 object declarations = popSTACK(); # Deklarationen
- TheIclosure(closure)->clos_body = popSTACK(); # Body
- {var reg4 object lambdalist = popSTACK(); # Lambda-Liste
- TheIclosure(closure)->clos_form = popSTACK(); # Source-Lambdabody
- TheIclosure(closure)->clos_name = STACK_0; # Name
- # und retten:
- STACK_0 = closure;
- # Stackaufbau: closure.
- closure_ = &STACK_0; # Pointer auf die Closure im STACK
- pushSTACK(lambdalist); pushSTACK(declarations);
- }}}
- # Environments nesten und genestet in die Closure stecken:
- {var reg1 environment* stack_env = nest_env(env);
- var reg2 object closure = *closure_;
- TheIclosure(closure)->clos_var_env = stack_env->var_env ;
- TheIclosure(closure)->clos_fun_env = stack_env->fun_env ;
- TheIclosure(closure)->clos_block_env = stack_env->block_env;
- TheIclosure(closure)->clos_go_env = stack_env->go_env ;
- TheIclosure(closure)->clos_decl_env = stack_env->decl_env ;
- skipSTACK(5);
- TheIclosure(closure)->clos_keywords = Fixnum_0; # keywords:=0, solange &KEY fehlt
- }
- # Stackaufbau: closure, lambdalist, declarations.
- {var reg10 uintL spec_count = 0; # Anzahl der dynamischen Referenzen
- var reg10 uintL req_count = 0; # Anzahl der required-Parameter
- var reg10 uintL opt_count = 0; # Anzahl der optional-Parameter
- var reg10 uintL key_count = 0; # Anzahl der Keyword-Parameter
- var reg10 uintL aux_count = 0; # Anzahl der &AUX-Variablen
- var reg9 uintL var_count = 0; # Gesamtzahl der auf dem STACK liegenden Variablen
- {var reg4 object declarations = popSTACK();
- # Deklarationen verarbeiten:
- # Dynamisch referenzierte Variablen aus der decl-spec-Liste declarations
- # herauslesen und auf dem STACK ablegen. Sonstige zu beachtende
- # Deklarationen verändern das Deklarations-Environment der Closure.
- while (consp(declarations)) # alle decl-specs abgearbeitet?
- { var reg1 object declspec = Car(declarations);
- # declspec muß Liste sein:
- if (atomp(declspec))
- { pushSTACK(declspec);
- //: DEUTSCH "FUNCTION: ~ ist keine erlaubte Deklaration."
- //: ENGLISH "FUNCTION: illegal declaration ~"
- //: FRANCAIS "FUNCTION: ~ n'est pas une déclaration licite."
- fehler(program_error, GETTEXT("FUNCTION: illegal declaration ~"));
- }
- # SPECIAL-Deklaration verarbeiten:
- if (eq(Car(declspec),S(special))) # SPECIAL-Deklaration ?
- { declspec = Cdr(declspec);
- while (consp(declspec))
- { var reg2 object sym = Car(declspec);
- if (!symbolp(sym))
- { pushSTACK(sym);
- //: DEUTSCH "FUNCTION: ~ ist kein Symbol, wurde aber als SPECIAL deklariert."
- //: ENGLISH "FUNCTION: ~ is not a symbol, cannot be declared SPECIAL"
- //: FRANCAIS "FUNCTION: ~ n'est pas un symbôle mais fut déclaré SPECIAL."
- fehler(program_error, GETTEXT("FUNCTION: ~ is not a symbol, cannot be declared SPECIAL"));
- }
- # Symbol im STACK ablegen:
- check_STACK(); pushSTACK(sym); spec_count++; var_count++;
- declspec = Cdr(declspec);
- } }
- # sonstige Deklaration verarbeiten:
- pushSTACK(Cdr(declarations)); # declarations verkürzen und retten
- {var reg2 object denv = TheIclosure(*closure_)->clos_decl_env;
- denv = augment_decl_env(declspec,denv);
- TheIclosure(*closure_)->clos_decl_env = denv;
- }
- declarations = popSTACK();
- } }
- {var reg2 object lambdalist = *(closure_ STACKop -1); # restliche Lambdaliste
- var reg1 object item; # Element der Lambdaliste
- # Macro:
- # NEXT_ITEM(&OPTIONAL_label,&REST_label,&KEY_label,
- # &ALLOW-OTHER-KEYS_label,&AUX_label,Ende_label)
- # verkürzt den Lambdalistenrest, bringt das nächste Element nach item
- # und springt im Falle eines der 6 angegebenen Lambdalistenmarker an
- # die entsprechenden Stellen.
- #define NEXT_ITEM(opt_label,rest_label,key_label,allow_label,aux_label,end_label) \
- { if (atomp(lambdalist)) goto end_label; # Lambda-Liste zu Ende? \
- item = Car(lambdalist); # nächstes Element \
- lambdalist = Cdr(lambdalist); # Liste verkürzen \
- if (eq(item,S(LLoptional))) goto opt_label; # &OPTIONAL ? \
- if (eq(item,S(LLrest))) goto rest_label; # &REST ? \
- if (eq(item,S(LLkey))) goto key_label; # &KEY ? \
- if (eq(item,S(LLallow_other_keys))) goto allow_label; # &ALLOW-OTHER-KEYS ? \
- if (eq(item,S(LLaux))) goto aux_label; # &AUX ? \
- }
- req: # required-Parameter abarbeiten und auf dem STACK ablegen:
- loop
- { NEXT_ITEM(opt,rest,key,badLLkey,aux,ende);
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- check_STACK();
- pushSTACK(item); pushSTACK(Fixnum_0); req_count++; var_count++;
- }
- opt: # &OPTIONAL-Parameter abarbeiten, auf dem STACK ablegen und
- # Init-Formen in die Closure stecken:
- loop
- { NEXT_ITEM(badLLkey,rest,key,badLLkey,aux,ende);
- {var reg7 object init_form;
- # Parse Variablenspezifikation in item:
- # var oder (var [init [svar]])
- # Lege var und evtl. svar auf den STACK, setze in var evtl.
- # das svar_bit. Liefert auch init (oder NIL) in init_form.
- check_STACK();
- if (atomp(item))
- { if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); opt_count++; var_count++;
- init_form = NIL; # Default-Init
- }
- else
- { var reg4 object item_rest = Cdr(item);
- item = Car(item); # erstes Listenelement: var
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); opt_count++; var_count++;
- if (consp(item_rest))
- { init_form = Car(item_rest); # zweites Listenelement: init
- item_rest = Cdr(item_rest);
- if (consp(item_rest))
- { if (mconsp(Cdr(item_rest)))
- # varspec ist zu lang
- { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Zu lange Variablenspezifikation nach &OPTIONAL: ~"
- //: ENGLISH "FUNCTION: too long variable specification after &OPTIONAL: ~"
- //: FRANCAIS "FUNCTION: Spécification de variable trop longue après &OPTIONAL : ~"
- fehler(program_error, GETTEXT("FUNCTION: too long variable specification after &OPTIONAL: ~"));
- }
- item = Car(item_rest); # drittes Listenelement: svar
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # svar-Bit für var setzen:
- STACK_0 = fixnum_inc(STACK_0,bit(svar_bit));
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
- } }
- else
- { init_form = NIL; } # Default-Init
- }
- # init_form vor (clos_opt_inits closure) pushen:
- pushSTACK(lambdalist); pushSTACK(init_form);
- { var reg5 object new_cons = allocate_cons();
- Car(new_cons) = popSTACK();
- {var reg6 object closure = *closure_;
- Cdr(new_cons) = TheIclosure(closure)->clos_opt_inits;
- TheIclosure(closure)->clos_opt_inits = new_cons;
- }}
- lambdalist = popSTACK();
- }}
- rest: # &REST-Parameter abarbeiten und auf dem Stack ablegen:
- { NEXT_ITEM(badrest,badrest,badrest,badrest,badrest,badrest);
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
- # Rest-Flag auf T setzen:
- TheIclosure(*closure_)->clos_rest_flag = T;
- }
- { NEXT_ITEM(badLLkey,badLLkey,key,badLLkey,aux,ende);
- pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Nach &REST var muß &KEY oder &AUX oder Listenende folgen: ~"
- //: ENGLISH "FUNCTION: &REST var must be followed by &KEY or &AUX or end of list: ~"
- //: FRANCAIS "FUNCTION: &KEY, &AUX ou fin de liste doit suivre une variable &REST : ~."
- fehler(program_error, GETTEXT("FUNCTION: &REST var must be followed by &KEY or &AUX or end of list: ~"));
- }
- badrest:
- pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Nach &REST muß Variable folgen: ~"
- //: ENGLISH "FUNCTION: &REST must be followed by a variable: ~"
- //: FRANCAIS "FUNCTION: Une variable doit suivre &REST : ~"
- fehler(program_error, GETTEXT("FUNCTION: &REST must be followed by a variable: ~"));
- key: # &KEY-Parameter abarbeiten, auf dem STACK ablegen
- # und Init-Formen in die Closure stecken:
- TheIclosure(*closure_)->clos_keywords = NIL; # keywords:=NIL
- loop
- { NEXT_ITEM(badLLkey,badLLkey,badLLkey,allow,aux,ende);
- {var reg8 object keyword;
- var reg7 object init_form;
- # Parse Variablenspezifikation in item:
- # var oder (var [init [svar]]) oder ((key var) [init [svar]])
- # Lege var und evtl. svar auf den STACK, setze in var evtl.
- # das svar_bit. Liefert auch das Keyword in keyword und
- # init (oder NIL) in init_form.
- check_STACK();
- if (atomp(item))
- { if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
- # Keyword holen:
- pushSTACK(lambdalist);
- keyword = intern_keyword(Symbol_name(item));
- lambdalist = popSTACK();
- # Default-Init:
- init_form = NIL;
- }
- else
- { var reg4 object item_rest = Cdr(item); # ([init [svar]])
- item = Car(item); # erstes Listenelement: var oder (key var)
- if (atomp(item))
- # item = var
- { if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
- # Keyword holen:
- pushSTACK(item_rest); pushSTACK(lambdalist);
- keyword = intern_keyword(Symbol_name(item));
- lambdalist = popSTACK(); item_rest = popSTACK();
- }
- else
- # item = (key var)
- { keyword = Car(item); # key
- # sollte ein Keyword sein:
- if (!(symbolp(keyword) && keywordp(keyword)))
- { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- pushSTACK(keyword);
- //: DEUTSCH "FUNCTION: ~ in ~ ist kein Keyword."
- //: ENGLISH "FUNCTION: ~ in ~ is not a keyword"
- //: FRANCAIS "FUNCTION: ~ dans ~ n'est pas un mot-clé."
- fehler(program_error, GETTEXT("FUNCTION: ~ in ~ is not a keyword"));
- }
- item = Cdr(item); # (var)
- if (!(consp(item) && matomp(Cdr(item))))
- goto fehler_keyspec;
- item = Car(item); # var
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); key_count++; var_count++;
- }
- if (consp(item_rest))
- { init_form = Car(item_rest); # zweites Listenelement: init
- item_rest = Cdr(item_rest); # ([svar])
- if (consp(item_rest))
- { if (mconsp(Cdr(item_rest))) goto fehler_keyspec;
- item = Car(item_rest); # drittes Listenelement: svar
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # svar-Bit in var setzen:
- STACK_0 = fixnum_inc(STACK_0,bit(svar_bit));
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); var_count++;
- } }
- else
- { init_form = NIL; } # Default-Init
- }
- # keyword vor (clos_keywords closure) pushen und
- # init_form vor (clos_key_inits closure) pushen:
- pushSTACK(lambdalist); pushSTACK(init_form); pushSTACK(keyword);
- { var reg5 object new_cons = allocate_cons();
- Car(new_cons) = popSTACK();
- {var reg6 object closure = *closure_;
- Cdr(new_cons) = TheIclosure(closure)->clos_keywords;
- TheIclosure(closure)->clos_keywords = new_cons;
- }}
- { var reg5 object new_cons = allocate_cons();
- Car(new_cons) = popSTACK();
- {var reg6 object closure = *closure_;
- Cdr(new_cons) = TheIclosure(closure)->clos_key_inits;
- TheIclosure(closure)->clos_key_inits = new_cons;
- }}
- lambdalist = popSTACK();
- }}
- fehler_keyspec:
- pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Variablenspezifikation nach &KEY ist nicht korrekt: ~"
- //: ENGLISH "FUNCTION: incorrect variable specification after &KEY: ~"
- //: FRANCAIS "FUNCTION: Spécification de variable incorrecte après &KEY : ~"
- fehler(program_error, GETTEXT("FUNCTION: incorrect variable specification after &KEY: ~"));
- allow: # &ALLOW-OTHER-KEYS abarbeiten:
- { TheIclosure(*closure_)->clos_allow_flag = T; # Flag auf T setzen
- NEXT_ITEM(badLLkey,badLLkey,badLLkey,badLLkey,aux,ende);
- pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Auf &ALLOW-OTHER-KEYS muß &AUX oder Listenende folgen: ~"
- //: ENGLISH "FUNCTION: &ALLOW-OTHER-KEYS must be followed by &AUX or end of list: ~"
- //: FRANCAIS "FUNCTION: &AUX ou fin de liste doit suivre &ALLOW-OTHER-KEYS : ~"
- fehler(program_error, GETTEXT("FUNCTION: &ALLOW-OTHER-KEYS must be followed by &AUX or end of list: ~"));
- }
- aux: # &AUX-Parameter abarbeiten, auf dem STACK ablegen und
- # Init-Formen in die Closure stecken:
- loop
- { NEXT_ITEM(badLLkey,badLLkey,badLLkey,badLLkey,badLLkey,ende);
- {var reg7 object init_form;
- # Parse Variablenspezifikation in item:
- # var oder (var [init])
- # Lege var auf den STACK.
- # Liefert auch init (oder NIL) in init_form.
- check_STACK();
- if (atomp(item))
- { if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); aux_count++; var_count++;
- init_form = NIL; # Default-Init
- }
- else
- { var reg4 object item_rest = Cdr(item);
- item = Car(item); # erstes Listenelement: var
- if (!symbolp(item)) goto fehler_symbol;
- if (constantp(TheSymbol(item))) goto fehler_constant;
- # Variable im STACK ablegen:
- pushSTACK(item); pushSTACK(Fixnum_0); aux_count++; var_count++;
- if (consp(item_rest))
- { init_form = Car(item_rest); # zweites Listenelement: init
- if (mconsp(Cdr(item_rest)))
- # varspec ist zu lang
- { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Zu lange Variablenspezifikation nach &AUX: ~"
- //: ENGLISH "FUNCTION: too long variable specification after &AUX: ~"
- //: FRANCAIS "FUNCTION: Spécification de variable trop longue après &AUX : ~"
- fehler(program_error, GETTEXT("FUNCTION: too long variable specification after &AUX: ~"));
- } }
- else
- { init_form = NIL; } # Default-Init
- }
- # init_form vor (clos_aux_inits closure) pushen:
- pushSTACK(lambdalist); pushSTACK(init_form);
- { var reg5 object new_cons = allocate_cons();
- Car(new_cons) = popSTACK();
- {var reg6 object closure = *closure_;
- Cdr(new_cons) = TheIclosure(closure)->clos_aux_inits;
- TheIclosure(closure)->clos_aux_inits = new_cons;
- }}
- lambdalist = popSTACK();
- }}
- # Gesammelte Fehlermeldungen:
- badLLkey:
- pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- pushSTACK(item);
- //: DEUTSCH "FUNCTION: Lambda-Listen-Keyword ~ an der falschen Stelle: ~"
- //: ENGLISH "FUNCTION: badly placed lambda-list keyword ~: ~"
- //: FRANCAIS "FUNCTION: Mot clé de liste lambda ~ mal placé : ~"
- fehler(program_error, GETTEXT("FUNCTION: badly placed lambda-list keyword ~: ~"));
- fehler_symbol:
- pushSTACK(item);
- //: DEUTSCH "FUNCTION: ~ ist kein Symbol und kann daher nicht als Variable verwendet werden."
- //: ENGLISH "FUNCTION: ~ is not a symbol, may not be used as a variable"
- //: FRANCAIS "FUNCTION: ~ n'est pas un symbole et ne peut donc pas être utilisé comme variable."
- fehler(program_error, GETTEXT("FUNCTION: ~ is not a symbol, may not be used as a variable"));
- fehler_constant:
- pushSTACK(item);
- //: DEUTSCH "FUNCTION: ~ ist eine Konstante und kann daher nicht als Variable verwendet werden."
- //: ENGLISH "FUNCTION: ~ is a constant, may not be used as a variable"
- //: FRANCAIS "FUNCTION: ~ est une constante et ne peut donc pas être utilisée comme variable."
- fehler(error, GETTEXT("FUNCTION: ~ is a constant, may not be used as a variable"));
- ende: # Listenende erreicht
- #undef NEXT_ITEM
- if (((uintL)~(uintL)0 > lp_limit_1) && (var_count > lp_limit_1)) # Zu viele Parameter?
- { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Zu viele Parameter in der Lambda-Liste ~"
- //: ENGLISH "FUNCTION: too many parameters in the lambda-list ~"
- //: FRANCAIS "FUNCTION: Trop de paramètres dans la liste lambda ~"
- fehler(program_error, GETTEXT("FUNCTION: too many parameters in the lambda-list ~"));
- }
- # Da nun var_count <= lp_limit_1, passen alle counts in ein uintC.
- if (!nullp(lambdalist)) # Lambda-Liste eine Dotted List?
- { pushSTACK(*(closure_ STACKop -1)); # ganze Lambda-Liste
- //: DEUTSCH "FUNCTION: Ein Punkt in der Lambda-Liste ist nur bei Macros erlaubt, nicht hier: ~"
- //: ENGLISH "FUNCTION: a dot in a lambda-list is allowed only for macros, not here: ~"
- //: FRANCAIS "FUNCTION: Un point dans une liste lambda n'est permis que pour des macros, pas ici : ~"
- fehler(program_error, GETTEXT("FUNCTION: a dot in a lambda-list is allowed only for macros, not here: ~"));
- }
- # Variablen zu einem Vektor zusammenfassen und in die Closure,
- # Variablenflags zu einem Byte-Vektor zusammenfassen und in die Closure:
- pushSTACK(allocate_bit_vector(intBsize*(var_count-spec_count))); # Byte-Vektor erzeugen
- { var reg8 object vars = allocate_vector(var_count); # Vektor erzeugen
- var reg8 object varflags = popSTACK();
- # Variablen in den Vektor schreiben (letzte hinten, erste vorne):
- { var reg4 object* ptr = &TheSvector(vars)->data[var_count];
- var reg5 uintB* ptrflags = &TheSbvector(varflags)->data[var_count-spec_count];
- var reg6 uintC count;
- dotimesC(count,var_count-spec_count,
- { *--ptrflags = (uintB)posfixnum_to_L(popSTACK());
- *--ptr = popSTACK();
- });
- dotimesC(count,spec_count, { *--ptr = popSTACK(); } );
- }
- {var reg4 object closure = *closure_;
- TheIclosure(closure)->clos_vars = vars;
- TheIclosure(closure)->clos_varflags = varflags;
- # Anzahlen in die Closure eintragen:
- TheIclosure(closure)->clos_spec_anz = fixnum(spec_count);
- TheIclosure(closure)->clos_req_anz = fixnum(req_count);
- TheIclosure(closure)->clos_opt_anz = fixnum(opt_count);
- TheIclosure(closure)->clos_key_anz = fixnum(key_count);
- TheIclosure(closure)->clos_aux_anz = fixnum(aux_count);
- # Im Variablen-Vektor sind die ersten spec_count Variablen die
- # SPECIAL-Deklarierten. In jeder übrigen Variablen wird das DYNAM_BIT
- # gesetzt, falls sie unter den SPECIAL-deklarierten vorkommt.
- if (!(spec_count==0))
- { # Schleife über die übrigen Variablen:
- var reg9 object* othervarptr = &TheSvector(vars)->data[spec_count];
- var reg9 uintB* othervarflagsptr = &TheSbvector(varflags)->data[0];
- var reg9 uintC count1;
- dotimesC(count1,var_count-spec_count,
- { var reg7 object othervar = *othervarptr++; # nächste Variable
- # Suche sie in den SPECIAL-deklarierten Variablen:
- {var reg5 object* specvarptr = &TheSvector(vars)->data[0];
- var reg6 uintC count2;
- dotimespC(count2,spec_count,
- { if (eq(*specvarptr++,othervar)) # gefunden?
- # ja -> also ist die Variable othervar dynamisch zu binden.
- { *othervarflagsptr |= bit(dynam_bit); break; }
- });
- }
- othervarflagsptr++;
- });
- }
- # Schließlich noch die akkumulierten Listen in der Closure umdrehen:
- nreverse(TheIclosure(closure)->clos_opt_inits);
- nreverse(TheIclosure(closure)->clos_keywords);
- nreverse(TheIclosure(closure)->clos_key_inits);
- nreverse(TheIclosure(closure)->clos_aux_inits);
- # Fertig.
- # Stackaufbau: closure, lambdalist.
- skipSTACK(2);
- return closure;
- }}
- }}}}
-
- # UP: Wandelt ein Argument in eine Funktion um.
- # coerce_function(obj)
- # > obj: Objekt
- # > subr_self: Aufrufer (ein SUBR)
- # < ergebnis: Objekt als Funktion (SUBR oder Closure)
- # kann GC auslösen
- global object coerce_function (object obj);
- global object coerce_function(obj)
- var reg1 object obj;
- { # obj sollte ein SUBR, eine Closure oder ein Lambdaausdruck sein.
- if (subrp(obj)) { return obj; } # SUBR ist OK
- elif (closurep(obj)) { return obj; } # Closure ist OK
- elif (consp(obj) && eq(Car(obj),S(lambda))) # Cons (LAMBDA . ...) ?
- # Lambda-Ausdruck wird sofort in eine Closure umgewandelt:
- { # leeres Environment für get_closure:
- var reg2 environment* env5;
- make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env5 = );
- # Closure bilden aus lambdabody = (cdr obj), name = :LAMBDA :
- {var reg3 object closure = get_closure(Cdr(obj),S(Klambda),env5);
- skipSTACK(5);
- return closure;
- }}
- #ifdef DYNAMIC_FFI
- elif (ffunctionp(obj)) { return obj; } # Foreign-Function ist OK
- #endif
- else
- { pushSTACK(obj);
- pushSTACK(TheSubr(subr_self)->name);
- //: DEUTSCH "~: ~ ist keine Funktion."
- //: ENGLISH "~: ~ is not a function"
- //: FRANCAIS "~: ~ n'est pas une fonction."
- fehler(error, GETTEXT("~: ~ is not a function"));
- }
- }
-
- #ifdef DEBUG_EVAL
-
- # Emit some trace output for a function call, to *funcall-trace-output*.
- # trace_call(fun,type_of_call,caller_type);
- # > object fun: function being called, a SUBR/FSUBR/Closure
- # > uintB type_of_call: 'A' for apply, 'F' for funcall, 'B' for bytecode
- # > uintB caller_type: 'F' for fsubr, 'S' for subr,
- # 'C' for cclosure, 'I' for iclosure
- # kann GC auslösen
- local void trace_call (object fun, uintB type_of_call, uintB caller_type);
- local void trace_call(fun,type_of_call,caller_type)
- var reg1 object fun;
- var reg3 uintB type_of_call;
- var reg4 uintB caller_type;
- { var reg2 object stream = Symbol_value(S(funcall_trace_output)); # SYS::*FUNCALL-TRACE-OUTPUT*
- # No output until *funcall-trace-output* has been initialized:
- if (!streamp(stream)) return;
- pushSTACK(stream);
- if (cclosurep(fun))
- { pushSTACK(TheCclosure(fun)->clos_name);
- write_schar(&STACK_1,'c');
- }
- elif (closurep(fun))
- { pushSTACK(TheClosure(fun)->clos_name);
- write_schar(&STACK_1,'C');
- }
- elif (subrp(fun))
- { pushSTACK(TheSubr(fun)->name);
- write_schar(&STACK_1,'S');
- }
- elif (fsubrp(fun))
- { pushSTACK(TheFsubr(fun)->name);
- write_schar(&STACK_1,'F');
- }
- else
- { pushSTACK(NIL);
- write_schar(&STACK_1,'?');
- }
- write_schar(&STACK_1,type_of_call); # output type of call
- write_schar(&STACK_1,caller_type); # output caller
- write_schar(&STACK_1,'[');
- prin1(&STACK_1,STACK_0); # output function name
- write_schar(&STACK_1,']');
- terpri(&STACK_1);
- skipSTACK(2);
- }
-
- #endif
-
- # fehler_zuviel_caller(fun);
- # > fun: Funktion
- nonreturning_function(local, fehler_zuviel_caller, (object fun, object caller_fun));
- local void fehler_zuviel_caller(fun, caller_fun)
- var reg1 object fun;
- var reg1 object caller_fun;
- { pushSTACK(fun);
- pushSTACK(caller_fun);
- //: DEUTSCH "~: Zu viele Argumente für ~"
- //: ENGLISH "~: too many arguments given to ~"
- //: FRANCAIS "~: Trop d'arguments pour ~"
- fehler(error, GETTEXT("~: too many arguments given to ~"));
- }
-
- # Fehlermeldung bei unpaarigen Keyword-Argumenten
- # fehler_key_unpaarig(fun);
- # > fun: Funktion
- nonreturning_function(local, fehler_key_unpaarig, (object fun));
- local void fehler_key_unpaarig(fun)
- var reg1 object fun;
- { pushSTACK(fun);
- //: DEUTSCH "EVAL/APPLY: Keyword-Argumente für ~ sind nicht paarig."
- //: ENGLISH "EVAL/APPLY: keyword arguments for ~ should occur pairwise"
- //: FRANCAIS "EVAL/APPLY: Les arguments mot-clé de ~ ne sont pas par paires."
- fehler(error, GETTEXT("EVAL/APPLY: keyword arguments for ~ should occur pairwise"));
- }
-
- # Fehlermeldung bei zu vielen Keyword-Argumenten
- # fehler_zuviel_eval_apply(fun);
- # > fun: Funktion
- nonreturning_function(local, fehler_zuviel_eval_apply, (object fun));
- local void fehler_zuviel_eval_apply(fun)
- var reg1 object fun;
- { pushSTACK(fun);
- //: DEUTSCH "EVAL/APPLY: Zu viele Argumente für ~"
- //: ENGLISH "EVAL/APPLY: too many arguments given to ~"
- //: FRANCAIS "EVAL/APPLY: Trop d'arguments pour ~"
- fehler(error, GETTEXT("EVAL/APPLY: too many arguments given to ~"));
- }
- #define fehler_key_zuviel fehler_zuviel_eval_apply
-
- # Fehlermeldung bei fehlerhaftem Keyword
- # fehler_key_notkw(kw);
- # > kw: Nicht-Keyword
- nonreturning_function(local, fehler_key_notkw, (object kw));
- local void fehler_key_notkw(kw)
- var reg1 object kw;
- { pushSTACK(kw); # Wert für Slot DATUM von TYPE-ERROR
- pushSTACK(S(keyword)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
- pushSTACK(kw);
- //: DEUTSCH "EVAL/APPLY: ~ ist kein Keyword."
- //: ENGLISH "EVAL/APPLY: ~ is not a keyword"
- //: FRANCAIS "EVAL/APPLY: ~ n'est pas un mot-clé."
- fehler(type_error, GETTEXT("EVAL/APPLY: ~ is not a keyword"));
- }
-
- # Fehlermeldung bei fehlerhaftem Keyword
- # fehler_key_badkw(fun,kw,kwlist);
- # > fun: Funktion
- # > kw: unzulässiges Keyword
- # > kwlist: Liste der zugelassenen Keywords
- nonreturning_function(local, fehler_key_badkw, (object fun, object kw, object kwlist));
- local void fehler_key_badkw(fun,kw,kwlist)
- var reg2 object fun;
- var reg3 object kw;
- var reg1 object kwlist;
- { pushSTACK(kwlist);
- pushSTACK(fun);
- pushSTACK(kw);
- //: DEUTSCH "EVAL/APPLY: Das Keyword ~ ist bei ~ nicht erlaubt. Die möglichen Keywords sind ~"
- //: ENGLISH "EVAL/APPLY: keyword ~ is illegal for ~. The possible keywords are ~"
- //: FRANCAIS "EVAL/APPLY: Le mot-clé ~ n'est pas permis pour ~. Possibles sont ~"
- fehler(error, GETTEXT("EVAL/APPLY: keyword ~ is illegal for ~. The possible keywords are ~"));
- }
-
- # Test auf unerlaubte Keywords
- # check_for_illegal_keywords(allow_flag,fehler_statement);
- # > uintC argcount: Anzahl der Keyword/Value-Paare
- # > object* rest_args_pointer: Pointer über die 2*argcount restlichen Argumente
- # > boolean allow_flag: Flag, ob &ALLOW-OTHER-KEYS angegeben war
- # > for_every_keyword: Macro, der alle Keywords durchläuft und an 'keyword'
- # zuweist.
- # > fehler_statement: Statement, das meldet, daß bad_keyword illegal ist.
- #define check_for_illegal_keywords(allow_flag_expr,fehler_statement) \
- { var reg6 object* argptr = rest_args_pointer; # Pointer in die Argumente \
- var reg8 object bad_keyword = nullobj; # erstes unerlaubtes Keyword oder nullobj \
- var reg4 boolean allow_flag = # Flag für allow-other-keys (ob \
- # &ALLOW-OTHER-KEYS angegeben war oder ':ALLOW-OTHER-KEY T' vorkam) \
- (allow_flag_expr); \
- var reg9 uintC check_count; \
- dotimesC(check_count,argcount, \
- { var reg3 object kw = NEXT(argptr); # nächstes Argument \
- var reg7 object val = NEXT(argptr); # und Wert dazu \
- # muß ein Symbol, sollte ein Keyword sein: \
- if (!symbolp(kw)) \
- { fehler_key_notkw(kw); } \
- if (!allow_flag) # andere Keywords erlaubt? ja -> ok \
- { if (eq(kw,S(Kallow_other_keys))) # Kommt :ALLOW-OTHER-KEYS ? \
- { if (!nullp(val)) { allow_flag = TRUE; } } \
- else \
- # bis hierher war nicht :ALLOW-OTHER-KEYS da, und NOALLOW \
- { if (eq(bad_keyword,nullobj)) # bisher alle Keywords ok? \
- # muß testen, ob das Keyword kw erlaubt ist. \
- { for_every_keyword( \
- { if (eq(keyword,kw)) goto kw_ok; } \
- ); \
- # Keyword kw war nicht erlaubt. \
- bad_keyword = kw; \
- kw_ok: ; \
- } } } \
- }); \
- if (!allow_flag) \
- if (!eq(bad_keyword,nullobj)) \
- # falsches Keyword aufgetreten \
- { if (!keywordp(bad_keyword)) \
- { fehler_key_notkw(bad_keyword); } \
- else \
- { fehler_statement } \
- } \
- }
-
- # Zu einem Keyword 'keyword' das Paar Key.Wert suchen:
- # find_keyword_value( notfound_statement, found_statement );
- # > keyword: Keyword
- # > uintC argcount: Anzahl der Keyword/Value-Paare
- # > object* rest_args_pointer: Pointer über die 2*argcount restlichen Argumente
- # > notfound_statement: Was zu tun ist, wenn nicht gefunden
- # > found_statement: Was zu tun ist, wenn Wert value gefunden
- #define find_keyword_value(notfound_statement,found_statement) \
- { var reg1 object* argptr = rest_args_pointer; \
- var reg2 uintC find_count; \
- dotimesC(find_count,argcount, \
- { if (eq(NEXT(argptr),keyword)) goto kw_found; # richtiges Keyword? \
- NEXT(argptr); \
- }); \
- if (TRUE) \
- # nicht gefunden \
- { notfound_statement } \
- else \
- kw_found: # gefunden \
- { var reg1 object value = NEXT(argptr); \
- found_statement \
- } \
- }
-
- # UP: Wendet eine interpretierte Closure auf Argumente an.
- # funcall_iclosure(closure,args_pointer,argcount);
- # > closure: Closure
- # > args_pointer: Pointer über die Argumente (im Stack)
- # > argcount: Anzahl der Argumente
- # < mv_count/mv_space: Werte
- # < STACK: aufgeräumt, = args_pointer
- # kann GC auslösen
- local Values funcall_iclosure (object closure, object* args_pointer, uintC argcount);
- local Values funcall_iclosure(closure,args_pointer,argcount)
- var reg5 object closure;
- var reg8 object* args_pointer;
- var reg9 uintC argcount;
- { # 1. Schritt: APPLY-Frame zu Ende aufbauen:
- var jmp_buf my_jmp_buf;
- #ifdef DEBUG_EVAL
- if (sym_streamp(S(funcall_trace_output)))
- { pushSTACK(closure); trace_call(closure,'F','I'); closure = popSTACK(); }
- #endif
- { var reg1 object* top_of_frame = args_pointer; # Pointer übern Frame
- pushSTACK(closure);
- finish_entry_frame(APPLY,&!my_jmp_buf,_EMA_,
- { if (mv_count==0) # nach Wiedereintritt: Form übergeben?
- { closure = STACK_(frame_closure); # selben APPLY nochmals versuchen
- args_pointer = topofframe(STACK_0);
- argcount = STACK_item_count(STACK STACKop frame_args,args_pointer);
- }
- else
- { setSTACK(STACK = topofframe(STACK_0)); # STACK aufräumen # oder unwind() ??
- eval_noenv(value1); return; # übergebene Form evaluieren
- } }
- );
- }
- {var reg10 object* closure_ = &STACK_(frame_closure); # Pointer auf die Closure
- var reg1 object* frame_pointer; # Pointer in den Frame
- # 2. Schritt: Variablenbindungsframe aufbauen:
- { var reg8 object* top_of_frame = STACK; # Pointer übern Frame
- var reg6 object vars = TheIclosure(closure)->clos_vars; # Vektor mit Variablennamen
- var reg7 uintL var_count = TheSvector(vars)->length; # Anzahl der Variablen
- get_space_on_STACK(var_count * 2 * sizeof(object)); # Platz reservieren
- { var reg3 object* varptr = &TheSvector(vars)->data[0]; # Pointer auf Variablen im Vektor
- var reg9 uintC spec_count = posfixnum_to_L(TheIclosure(closure)->clos_spec_anz);
- var reg4 uintC count;
- # erst die Special-Referenzen:
- dotimesC(count,spec_count,
- { # Bindung mit "Wert" specdecl:
- pushSTACK(specdecl);
- pushSTACK_symbolwithflags(*varptr++,wbit(active_bit_o)); # Bindung schon mal als aktiv vormerken
- });
- frame_pointer = args_end_pointer;
- {var reg3 uintB* varflagsptr = &TheSbvector(TheIclosure(closure)->clos_varflags)->data[0];
- dotimesC(count,var_count-spec_count,
- { pushSTACK(NIL); # NIL als vorläufiger Wert
- {var reg2 object next_var = *varptr++; # nächste Variable
- var reg1 oint next_varflags = (oint)(*varflagsptr++)<<oint_symbolflags_shift; # mit evtl. dynam_bit, svar_bit
- if (special_var_p(TheSymbol(next_var))) # SPECIAL-proklamiert?
- { next_varflags |= wbit(dynam_bit_o); } # -> dynamisch binden
- pushSTACK_symbolwithflags(next_var,next_varflags);
- }});
- }}
- # VAR_ENV der Closure wird NEXT_ENV im Frame:
- pushSTACK(TheIclosure(closure)->clos_var_env);
- pushSTACK(as_object(var_count)); # var_count Bindungen, alle noch ungenestet
- finish_frame(VAR);
- }
- # STACK zeigt nun unter den Variablenbindungs-Frame.
- # frame_pointer = Pointer in den Variablenbindungsframe, über die erste
- # noch inaktive Bindung, unter die bereits aktiven SPECIAL-Referenzen.
- {var reg10 object new_var_env = make_framepointer(STACK);
- # Dieser Frame wird nachher zum neuen VAR_ENV.
- # 3. Schritt: aktuelle Environments binden:
- make_ENV5_frame();
- # Das Closure-Environment aktivieren:
- aktenv.var_env = new_var_env; # Variablenbindungsframe
- aktenv.fun_env = TheIclosure(closure)->clos_fun_env;
- aktenv.block_env = TheIclosure(closure)->clos_block_env;
- aktenv.go_env = TheIclosure(closure)->clos_go_env;
- aktenv.decl_env = TheIclosure(closure)->clos_decl_env;
- }
- # Stackaufbau:
- # APPLY-Frame
- # Variablenbindungsframe
- # ENV-Frame
- # 4. Schritt: Parameter abarbeiten:
- { check_SP();
- # Macro zum Binden von Variablen im Variablenframe:
- # Bindet die nächste Variable an value, erniedrigt frame_pointer um 2 bzw. 3.
- # (Benutzt, daß varframe_binding_mark = 0 !)
-
- #define bind_next_var(value,markptr_zuweisung) \
- { frame_pointer skipSTACKop -varframe_binding_size; \
- {var reg2 object* markptr = markptr_zuweisung &Before(frame_pointer); \
- if (*(oint*)(markptr) & wbit(dynam_bit_o)) \
- # dynamische Bindung aktivieren: \
- { var reg3 object sym = *(markptr STACKop varframe_binding_sym); # Variable \
- *(markptr STACKop varframe_binding_value) = Symbolflagged_value(sym); # alten Wert in den Frame \
- *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren \
- set_Symbolflagged_value_on(sym,value,markptr); # neuen Wert in die Wertzelle \
- closure = *closure_; \
- } \
- else \
- # statische Bindung aktivieren: \
- { *(markptr STACKop varframe_binding_value) = (value); # neuen Wert in den Frame \
- *(oint*)(markptr) |= wbit(active_bit_o); # Bindung aktivieren \
- } \
- } }
- # required-Parameter abarbeiten:
- # Es ist das jeweils nächste Argument zu holen und im Stack zu binden.
- { var reg7 uintC count = posfixnum_to_L(TheIclosure(closure)->clos_req_anz);
- if (count>0)
- { if (argcount < count)
- { pushSTACK(TheIclosure(closure)->clos_name);
- //: DEUTSCH "EVAL/APPLY: Zu wenig Argumente für ~"
- //: ENGLISH "EVAL/APPLY: too few arguments given to ~"
- //: FRANCAIS "EVAL/APPLY: Trop peu d'arguments pour ~"
- fehler(error, GETTEXT("EVAL/APPLY: too few arguments given to ~"));
- }
- argcount -= count;
- dotimespC(count,count,
- { var reg6 object next_arg = NEXT(args_pointer); # nächstes Argument
- bind_next_var(next_arg,_EMA_); # nächste Variable binden
- });
- } }
- # optionale Parameter abarbeiten:
- # Es ist jeweils das nächste Argument zu holen; falls keines vorliegt,
- # eine Init-Form auszuführen; dann im Stack zu binden.
- { var reg8 uintC count = posfixnum_to_L(TheIclosure(closure)->clos_opt_anz);
- if (count==0) goto optional_ende;
- {var reg7 object inits = TheIclosure(closure)->clos_opt_inits; # Init-Formen
- var reg9 object *inits_ptr;
- pushSTACK(inits);
- inits_ptr = &STACK_0;
- do { if (argcount==0) goto optional_aus;
- argcount--;
- {var reg7 object next_arg = NEXT(args_pointer); # nächstes Argument
- {var reg6 object* optmarkptr;
- bind_next_var(next_arg,optmarkptr=); # nächste Variable binden
- if (*(oint*)optmarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
- { *(oint*)optmarkptr &= ~wbit(svar_bit_o);
- bind_next_var(T,_EMA_); # ja -> an T binden
- } }
- *inits_ptr=(Cdr(*inits_ptr)); # Init-Formen-Liste verkürzen
- count--;
- }}
- until (count==0);
- skipSTACK(1);
- goto optional_ende;
- optional_aus: ; # Hier sind die optionalen Argumente ausgegangen.
- }# Ab hier alle Init-Formen der optionalen Parameter ausführen:
- dotimespC(count,count,
- { var reg7 object inits = STACK_0; # restliche Initformen
- STACK_0 = Cdr(inits);
- inits = (eval(Car(inits)),value1); # nächste Initform, ausgewertet
- {var reg6 object* optmarkptr;
- bind_next_var(inits,optmarkptr=); # nächste Variable binden
- if (*(oint*)optmarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
- { *(oint*)optmarkptr &= ~wbit(svar_bit_o);
- bind_next_var(NIL,_EMA_); # ja -> an NIL binden
- } }
- });
- closure = *closure_;
- # &REST-Parameter ohne Argumente initialisieren:
- if (!nullp(TheIclosure(closure)->clos_rest_flag)) # Rest-Flag?
- { bind_next_var(NIL,_EMA_); } # ja -> an NIL binden
- # &KEY-Parameter ohne Argumente initialisieren:
- count = posfixnum_to_L(TheIclosure(closure)->clos_key_anz); # Anzahl Keyword-Parameter
- if (count>0)
- { STACK_0 = TheIclosure(closure)->clos_key_inits; # zugehörige Init-Formen
- dotimespC(count,count,
- { var reg7 object inits = STACK_0; # restliche Initformen
- STACK_0 = Cdr(inits);
- inits = (eval(Car(inits)),value1); # nächste Initform, ausgewertet
- {var reg6 object* keymarkptr;
- bind_next_var(inits,keymarkptr=); # nächste Variable binden
- if (*(oint*)keymarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
- { *(oint*)keymarkptr &= ~wbit(svar_bit_o);
- bind_next_var(NIL,_EMA_); # ja -> an NIL binden
- } }
- });
- closure = *closure_;
- }
- skipSTACK(1); # restliche Init-Formen vergessen
- goto aux; # weiter zu den AUX-Variablen
- }
- optional_ende:
- # &KEY-Parameter und &REST-Parameter vorbereiten:
- if (mnumberp(TheIclosure(closure)->clos_keywords) # keyword eine Zahl?
- && nullp(TheIclosure(closure)->clos_rest_flag) # und kein Rest-Parameter?
- )
- # ja -> weder &KEY noch &REST angegeben
- { if (argcount>0) # noch Argumente da -> Fehler
- fehler_zuviel_eval_apply(TheIclosure(closure)->clos_name);
- }
- else
- # &KEY oder &REST vorhanden.
- { # &REST-Parameter abarbeiten:
- if (!nullp(TheIclosure(closure)->clos_rest_flag)) # Rest-Parameter vorhanden?
- # ja -> übrige Argumente zu einer Liste zusammenfassen:
- { pushSTACK(NIL); # Listenanfang
- if (argcount>0)
- {var reg3 object* ptr = args_pointer STACKop -(uintP)argcount;
- var reg4 uintC count;
- dotimespC(count,argcount,
- { var reg2 object new_cons = allocate_cons();
- Car(new_cons) = BEFORE(ptr);
- Cdr(new_cons) = STACK_0;
- STACK_0 = new_cons;
- });
- closure = *closure_;
- }
- {var reg6 object list = popSTACK(); # Gesamtliste
- bind_next_var(list,_EMA_); # &REST-Parameter an diese Liste binden
- }}
- # &KEY-Parameter abarbeiten:
- if (!mnumberp(TheIclosure(closure)->clos_keywords))
- # Keyword-Parameter vorhanden
- { var reg10 object* rest_args_pointer = args_pointer;
- # argcount = Anzahl restlicher Argumente
- # argcount halbieren, gibt die Anzahl der Paare Key.Wert:
- if (!((argcount%2)==0))
- # Anzahl war ungerade -> nicht paarig:
- { fehler_key_unpaarig(TheIclosure(closure)->clos_name); }
- argcount = argcount/2;
- # Test auf unerlaubte Keywords:
- { var reg10 object keywords = TheIclosure(closure)->clos_keywords;
- #define for_every_keyword(statement) \
- { var reg2 object keywordsr = keywords; \
- while (consp(keywordsr)) \
- { var reg1 object keyword = Car(keywordsr); \
- statement; \
- keywordsr = Cdr(keywordsr); \
- } }
- check_for_illegal_keywords(
- !nullp(TheIclosure(closure)->clos_allow_flag),
- { fehler_key_badkw(TheIclosure(closure)->clos_name,
- bad_keyword,
- TheIclosure(closure)->clos_keywords);
- }
- );
- #undef for_every_keyword
- # Jetzt die Key-Werte zuordnen und die Key-Inits auswerten:
- {var auto object key_inits = TheIclosure(closure)->clos_key_inits;
- var reg10 uintC count;
- var reg3 object *keywords_ptr;
- var reg4 object *key_inits_ptr;
- var reg6 object *svar_value_ptr;
-
- pushSTACK(keywords); keywords_ptr=&STACK_0;
- pushSTACK(key_inits); key_inits_ptr=&STACK_0;
- pushSTACK(NIL); svar_value_ptr=&STACK_0;
- dotimesC(count,posfixnum_to_L(TheIclosure(closure)->clos_key_anz),
- { var reg8 object keyword = Car(*keywords_ptr); # Keyword
- var reg7 object var_value;
- # Zu diesem Keyword das Paar Key.Wert suchen:
- find_keyword_value(
- # nicht gefunden, muß den Init auswerten:
- { var_value = (eval(Car(*key_inits_ptr)),value1);
- *svar_value_ptr=NIL; # NIL für evtl. supplied-p-Parameter
- },
- # gefunden -> Wert nehmen:
- { var_value = value;
- *svar_value_ptr=T; # T für evtl. supplied-p-Parameter
- }
- );
- {var reg6 object* keymarkptr;
- bind_next_var(var_value,keymarkptr=); # Keyword-Variable binden
- if (*(oint*)keymarkptr & wbit(svar_bit_o)) # supplied-p-Parameter folgt?
- { *(oint*)keymarkptr &= ~wbit(svar_bit_o);
- bind_next_var(*svar_value_ptr,_EMA_); # ja -> an NIL bzw. T binden
- } }
- *keywords_ptr=Cdr(*keywords_ptr);
- *key_inits_ptr=Cdr(*key_inits_ptr);
- });
- skipSTACK(3);
- }}
- closure = *closure_;
- } }
- aux: # &AUX-Parameter behandeln:
- { var reg7 uintC count = posfixnum_to_L(TheIclosure(closure)->clos_aux_anz);
- if (count>0)
- { pushSTACK(TheIclosure(closure)->clos_aux_inits); # Init-Formen für &AUX-Variablen
- dotimespC(count,count,
- { var reg6 object inits = STACK_0;
- STACK_0 = Cdr(inits);
- inits = (eval(Car(inits)),value1); # nächstes Init auswerten
- bind_next_var(inits,_EMA_); # und Variable daran binden
- });
- skipSTACK(1); # restliche Init-Formen vergessen
- closure = *closure_;
- } }
- #undef bind_next_var
- }
- # 5. Schritt: Body auswerten:
- implicit_progn(TheIclosure(closure)->clos_body,NIL);
- unwind(); # ENV-Frame auflösen
- unwind(); # Variablenbindungsframe auflösen
- unwind(); # APPLY-Frame auflösen
- # fertig
- }}
-
- # UP: Besorgt die Zuordnung der Key-Argumente bei SUBRs.
- # Nur aufzurufen, falls key_flag /= subr_nokey.
- # > fun: Funktion, ein SUBR
- # > argcount: Argumentezahl nach den optionalen
- # > STACK_(argcount-1),...,STACK_0: die argcount Argumente nach den optionalen
- # > key_args_pointer: Pointer über die Key-Parameter im STACK
- # > rest_args_pointer: Pointer über die restlichen Argumente im STACK
- # < STACK: korrekt gesetzt
- # verändert STACK
- local void match_subr_key (object fun, uintL argcount, object* key_args_pointer, object* rest_args_pointer);
- local void match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer)
- var reg6 object fun;
- var reg9 uintL argcount;
- var reg10 object* key_args_pointer;
- var reg10 object* rest_args_pointer;
- { # argcount halbieren, gibt die Anzahl der Paare Key.Wert:
- if (!((argcount%2)==0))
- # Anzahl war ungerade -> nicht paarig:
- { fehler_key_unpaarig(fun); }
- if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
- { fehler_key_zuviel(fun); }
- # Da nun argcount <= ca_limit_1, passen alle count's in ein uintC.
- argcount = argcount/2;
- # Test auf unerlaubte Keywords:
- { var reg10 object* keywords_pointer = &TheSvector(TheSubr(fun)->keywords)->data[0];
- var reg10 uintC key_anz = TheSubr(fun)->key_anz;
- #define for_every_keyword(statement) \
- { var reg1 object* keywordptr = keywords_pointer; \
- var reg2 uintC count; \
- dotimesC(count,key_anz, \
- { var reg1 object keyword = *keywordptr++; \
- statement; \
- }); \
- }
- check_for_illegal_keywords(
- TheSubr(fun)->key_flag == subr_key_allow,
- { pushSTACK(bad_keyword); # fehlerhaftes Keyword retten
- # Keyword-Vektor in eine Liste umwandeln:
- # (SYS::COERCE-SEQUENCE kwvec 'LIST)
- coerce_sequence(TheSubr(fun)->keywords,S(list));
- {var reg1 object kwlist = value1;
- fehler_key_badkw(fun,popSTACK(),kwlist);
- }}
- );
- #undef for_every_keyword
- # Jetzt Argumente und Parameter zuordnen:
- {var reg4 object* keywordptr = keywords_pointer;
- var reg5 object* key_args_ptr = key_args_pointer;
- var reg7 uintC count;
- dotimesC(count,key_anz,
- { var reg3 object keyword = *keywordptr++; # Keyword
- # Zu diesem Keyword das Paar Key.Wert suchen:
- find_keyword_value(
- # nicht gefunden -> Wert bleibt #<UNBOUND> :
- { NEXT(key_args_ptr); },
- # gefunden -> Wert eintragen:
- { NEXT(key_args_ptr) = value; }
- );
- });
- }}
- # evtl. Rest-Parameter versorgen:
- if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne &REST-Flag: restliche Argumente vergessen:
- { set_args_end_pointer(rest_args_pointer); }
- # SUBR mit &REST-Flag: restliche Argumente im Stack belassen
- }
-
- # UP: Besorgt die Zuordnung zwischen Argumentliste und Keyword-Parametern
- # und eventuellem Rest-Parameter einer compilierten Closure.
- # > closure: compilierte Closure mit &KEY-Parametern
- # > argcount: Argumentezahl nach den optionalen
- # > STACK_(argcount-1),...,STACK_0: die argcount Argumente nach den optionalen
- # > key_args_pointer: Pointer über die Key-Parameter im STACK
- # (evtl. auch Pointer unter den Rest-Parameter im STACK,
- # der = #<UNBOUND> ist, falls er noch zu versorgen ist)
- # > rest_args_pointer: Pointer über die restlichen Argumente im STACK
- # < STACK: korrekt gesetzt
- # < ergebnis: closure
- # verändert STACK
- # kann GC auslösen
- local object match_cclosure_key (object closure, uintL argcount, object* key_args_pointer, object* rest_args_pointer);
- local object match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer)
- var reg10 object closure;
- var reg9 uintL argcount;
- var reg10 object* key_args_pointer;
- var reg9 object* rest_args_pointer;
- { # argcount halbieren, gibt die Anzahl der Paare Key.Wert:
- if (!((argcount%2)==0))
- # Anzahl war ungerade -> nicht paarig:
- { fehler_key_unpaarig(closure); }
- if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
- { fehler_key_zuviel(closure); }
- # Da nun argcount <= ca_limit_1, passen alle count's in ein uintC.
- argcount = argcount/2;
- {var reg10 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
- {var reg9 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keywords
- var reg10 uintL keywords_offset = *(uintW*)(&TheSbvector(codevec)->data[CCHD+8]); # Offset der Keywords in FUNC
- var reg6 object* keywords_pointer = # zeigt aufs erste Keyword
- (TheSbvector(codevec)->data[CCHD+4] & bit(4) # generische Funktion?
- ? &TheSvector(TheCclosure(closure)->clos_consts[0])->data[keywords_offset]
- : &TheCclosure(closure)->clos_consts[keywords_offset]
- );
- # Test auf unerlaubte Keywords:
- #define for_every_keyword(statement) \
- { var reg1 object* keywordptr = keywords_pointer; \
- var reg2 uintC count; \
- dotimesC(count,key_anz, \
- { var reg1 object keyword = *keywordptr++; \
- statement; \
- }); \
- }
- check_for_illegal_keywords(
- !((TheSbvector(codevec)->data[CCHD+4] & bit(6)) == 0),
- { pushSTACK(bad_keyword); # retten
- # Liste der erlaubten Keywords bilden:
- for_every_keyword( { pushSTACK(keyword); } );
- {var reg7 object kwlist = listof(key_anz);
- bad_keyword = popSTACK();
- # und Fehler melden:
- fehler_key_badkw(closure,bad_keyword,kwlist);
- }}
- );
- #undef for_every_keyword
- # Jetzt Argumente und Parameter zuordnen:
- {var reg4 object* keywordptr = keywords_pointer;
- var reg5 object* key_args_ptr = key_args_pointer;
- var reg6 uintC count;
- dotimesC(count,key_anz,
- { var reg3 object keyword = *keywordptr++; # Keyword
- # Zu diesem Keyword das Paar Key.Wert suchen:
- find_keyword_value(
- # nicht gefunden -> Wert bleibt #<UNBOUND> :
- { NEXT(key_args_ptr); },
- # gefunden -> Wert eintragen:
- { NEXT(key_args_ptr) = value; }
- );
- });
- }}
- # evtl. Rest-Parameter versorgen:
- if (TheSbvector(codevec)->data[CCHD+4] & bit(0)) # Rest-Flag?
- # Closure mit Keywords und &REST-Flag:
- { var reg2 object* rest_arg_ = &BEFORE(key_args_pointer); # Pointer auf den REST-Parameter
- if (eq(*rest_arg_,unbound))
- # muß noch gefüllt werden: Liste basteln
- { *rest_arg_ = closure; # Closure retten
- {var reg1 object rest_arg = NIL;
- until (args_end_pointer == rest_args_pointer)
- { pushSTACK(rest_arg);
- rest_arg = allocate_cons();
- Cdr(rest_arg) = popSTACK();
- Car(rest_arg) = popSTACK();
- }
- closure = *rest_arg_; # Closure zurück
- *rest_arg_ = rest_arg;
- }}
- else
- # restliche Argumente vergessen:
- { set_args_end_pointer(rest_args_pointer); }
- }
- else
- # Closure ohne &REST-Flag: restliche Argumente vergessen:
- { set_args_end_pointer(rest_args_pointer); }
- return closure;
- }}
-
-
- # ----------------------- E V A L -----------------------
-
- # später:
- local Values eval1 (object form);
- local Values eval_fsubr (object fun, object args);
- local Values eval_applyhook (object fun);
- local Values eval_subr (object fun);
- local Values eval_closure (object fun);
- #ifdef DYNAMIC_FFI
- local Values eval_ffunction (object fun);
- #endif
-
- # UP: Wertet eine Form im aktuellen Environment aus.
- # eval(form);
- # > form: Form
- # < mv_count/mv_space: Werte
- # kann GC auslösen
- global Values eval (object form);
- global Values eval(form)
- var reg2 object form;
- { start:
- # Test auf Tastatur-Interrupt:
- interruptp(
- { pushSTACK(form); # form retten
- pushSTACK(S(eval)); tast_break(); # Break-Schleife aufrufen
- form = popSTACK();
- goto start;
- });
- {var jmp_buf my_jmp_buf;
- # EVAL-Frame aufbauen:
- { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
- pushSTACK(form); # Form
- finish_entry_frame(EVAL,&!my_jmp_buf,_EMA_,
- { if (mv_count==0) # nach Wiedereintritt: Form übergeben?
- { form = STACK_(frame_form); } # selbe Form nochmal evaluieren
- else
- { form = STACK_(frame_form) = value1; } # übergebene Form evaluieren
- });
- }
- # Test auf *EVALHOOK*:
- { var reg1 object evalhook_value = Symbol_value(S(evalhookstern)); # *EVALHOOK*
- if (nullp(evalhook_value)) # *EVALHOOK* = NIL ?
- # ja -> normal weiter-evaluieren
- { pushSTACK(Symbol_value(S(applyhookstern))); eval1(form); }
- else
- { # *EVALHOOK*, *APPLYHOOK* an NIL binden:
- var reg2 object *form_ptr;
- var reg3 object *evalhook_value_ptr;
- pushSTACK(form); form_ptr=&STACK_0;
- pushSTACK(evalhook_value); evalhook_value_ptr=&STACK_0;
- bindhooks_NIL();
- evalhook_value = *evalhook_value_ptr;
- form = *form_ptr;
- pushSTACK(form); # Form als 1. Argument
- pushSTACK(evalhook_value); # Funktion retten
- # (FUNCALL *EVALHOOK* form env) ausführen:
- {var reg4 environment* stack_env = nest_aktenv(); # Environments in den Stack,
- var reg3 object env = allocate_vector(5); # in neu allozierten Vektor
- *(environment*)(&TheSvector(env)->data[0]) = *stack_env; # hineinschieben
- skipSTACK(5);
- evalhook_value = popSTACK(); # Funktion zurück
- pushSTACK(env); # gesamtes Environment als 2. Argument
- funcall(evalhook_value,2);
- # alte Werte von *EVALHOOK*, *APPLYHOOK* zurück:
- unwind();
- skipSTACK(2);
- # EVAL-Frame auflösen:
- unwind();
- } }}
- }}
-
- # UP: Wertet eine Form im aktuellen Environment aus. Nimmt dabei auf
- # *EVALHOOK* und *APPLYHOOK* keine Rücksicht.
- # eval_no_hooks(form);
- # > form: Form
- # < mv_count/mv_space: Werte
- # kann GC auslösen
- global Values eval_no_hooks (object form);
- global Values eval_no_hooks(form)
- var reg2 object form;
- { var jmp_buf my_jmp_buf;
- # EVAL-Frame aufbauen:
- { var reg1 object* top_of_frame = STACK; # Pointer übern Frame
- pushSTACK(form); # Form
- finish_entry_frame(EVAL,&!my_jmp_buf,_EMA_,
- { if (mv_count==0) # nach Wiedereintritt: Form übergeben?
- { form = STACK_(frame_form); } # selbe Form nochmal evaluieren
- else
- { form = STACK_(frame_form) = value1; } # übergebene Form evaluieren
- });
- }
- # weiterevaluieren, *APPLYHOOK* als NIL betrachten:
- { pushSTACK(NIL); eval1(form); }
- }
-
- # UP: Wertet eine Form im aktuellen Environment aus.
- # Nimmt dabei auf *EVALHOOK* keine Rücksicht, und erwartet den Wert von
- # *APPLYHOOK*.
- # Der EVAL-Frame muß bereits aufgebaut sein; er wird dann abgebaut.
- # eval1(form);
- # > form: Form
- # > STACK_3..STACK_1: EVAL-Frame, mit Form in STACK_3
- # > STACK_0: Wert von *APPLYHOOK*
- # < mv_count/mv_space: Werte
- # verändert STACK
- # kann GC auslösen
- local Values eval1(form)
- var reg1 object form;
- { if (atomp(form))
- { if (symbolp(form))
- { # Form ist Symbol
- value1 = sym_value(form,aktenv.var_env); # Wert im aktuellen Environment
- if (eq(value1,unbound))
- { pushSTACK(form); # Wert für Slot NAME von CELL-ERROR
- pushSTACK(form);
- //: DEUTSCH "EVAL: Die Variable ~ hat keinen Wert."
- //: ENGLISH "EVAL: variable ~ has no value"
- //: FRANCAIS "EVAL: La variable ~ n'a pas de valeur."
- fehler(unbound_variable, GETTEXT("EVAL: variable ~ has no value"));
- }
- elif (symbolmacrop(value1)) # Symbol-Macro?
- # ja -> expandieren und erneut evaluieren:
- { skipSTACK(1); # Wert von *APPLYHOOK* vergessen
- check_SP(); check_STACK();
- eval(TheSymbolmacro(value1)->symbolmacro_expansion); # Expansion evaluieren
- unwind(); # EVAL-Frame auflösen
- }
- else
- { mv_count=1; # value1 als Wert
- skipSTACK(1);
- unwind(); # EVAL-Frame auflösen
- }
- }
- else
- # self-evaluating form
- { value1 = form; mv_count=1; # form als Wert
- skipSTACK(1);
- unwind(); # EVAL-Frame auflösen
- }
- }
- else
- # Form ist ein Cons
- { # Feststellen, ob Macro-call, evtl. expandieren:
- macroexp(form,aktenv.var_env,aktenv.fun_env); form = value1;
- if (!nullp(value2)) # expandiert ?
- # jetzt erst richtig evaluieren:
- { skipSTACK(1); # Wert von *APPLYHOOK* vergessen
- check_SP(); check_STACK();
- eval(form); # expandierte Form evaluieren
- unwind(); # EVAL-Frame auflösen
- }
- else
- { var reg2 object fun = Car(form); # Funktionsbezeichnung
- if (funnamep(fun))
- { # Funktionsdefinition im Environment holen:
- fun = sym_function(fun,aktenv.fun_env);
- # je nach Typ der Funktion verzweigen:
- # unbound / SUBR/FSUBR/Closure / Macro-Cons
- switch (typecode(fun))
- { case_subr: # SUBR
- pushSTACK(Cdr(form)); # Argumentliste
- if (!nullp(STACK_1)) goto applyhook;
- eval_subr(fun);
- break;
- case_closure: # Closure
- pushSTACK(Cdr(form)); # Argumentliste
- closure: # fun ist eine Closure
- if (!nullp(STACK_1)) goto applyhook;
- eval_closure(fun);
- break;
- applyhook: # Wert von *APPLYHOOK* ist /= NIL.
- eval_applyhook(fun);
- break;
- case_orecord:
- if (TheRecord(fun)->rectype == Rectype_Fsubr)
- # Fsubr
- { eval_fsubr(fun,Cdr(form)); break; }
- #ifdef DYNAMIC_FFI
- if (TheRecord(fun)->rectype == Rectype_Ffunction)
- # Foreign-Function
- { pushSTACK(Cdr(form)); # Argumentliste
- if (!nullp(STACK_1)) goto applyhook;
- eval_ffunction(fun);
- break;
- }
- #endif
- default:
- pushSTACK(Car(form)); # Wert für Slot NAME von CELL-ERROR
- pushSTACK(STACK_0);
- //: DEUTSCH "EVAL: Die Funktion ~ ist undefiniert."
- //: ENGLISH "EVAL: undefined function ~"
- //: FRANCAIS "EVAL: La fonction ~ n'est pas définie."
- fehler(undefined_function, GETTEXT("EVAL: undefined function ~"));
- } }
- elif (consp(fun) && eq(Car(fun),S(lambda))) # Lambda-Ausdruck?
- { pushSTACK(Cdr(form)); # Argumentliste
- fun = get_closure(Cdr(fun),S(Klambda),&aktenv); # Closure im aktuellen Environment erzeugen
- goto closure; # und diese auf die Argumente anwenden, wie oben
- }
- else
- { pushSTACK(fun);
- //: DEUTSCH "EVAL: ~ ist keine Funktionsbezeichnung."
- //: ENGLISH "EVAL: ~ is not a function name"
- //: FRANCAIS "EVAL: ~ n'est pas un nom de fonction."
- fehler(error, GETTEXT("EVAL: ~ is not a function name"));
- }
- }
- }
- }
-
- # In EVAL: Wendet ein FSUBR auf eine Argumentliste an, räumt den STACK auf
- # und liefert die Werte.
- # eval_fsubr(fun,args);
- # > fun: ein FSUBR
- # > args: Argumentliste
- # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*.
- # < STACK: aufgeräumt
- # < mv_count/mv_space: Werte
- # verändert STACK
- # kann GC auslösen
- local Values eval_fsubr(fun,args)
- var reg2 object fun;
- var reg1 object args;
- { skipSTACK(1); # Wert von *APPLYHOOK* vergessen
- check_SP(); check_STACK();
- #if STACKCHECKS
- {var reg3 object* STACKbefore = STACK;
- #endif
- # Argumente in den STACK legen:
- switch ((uintW)posfixnum_to_L(TheFsubr(fun)->argtype))
- { # Macro für 1 required-Parameter:
- #define REQ_PAR() \
- { if (atomp(args)) goto fehler_zuwenig; \
- pushSTACK(Car(args)); # nächster Parameter in den STACK \
- args = Cdr(args); \
- }
- case (uintW)fsubr_argtype_2_0_nobody:
- # FSUBR mit 2 required-Parametern
- REQ_PAR();
- case (uintW)fsubr_argtype_1_0_nobody:
- # FSUBR mit 1 required-Parameter
- REQ_PAR();
- if (!nullp(args)) goto fehler_zuviel;
- break;
- case (uintW)fsubr_argtype_2_1_nobody:
- # FSUBR mit 2 required-Parametern und 1 optional-Parameter
- REQ_PAR();
- case (uintW)fsubr_argtype_1_1_nobody:
- # FSUBR mit 1 required-Parameter und 1 optional-Parameter
- REQ_PAR();
- if (consp(args))
- { pushSTACK(Car(args)); # optionalen Parameter in den STACK
- args = Cdr(args);
- if (!nullp(args)) goto fehler_zuviel;
- }
- else
- { pushSTACK(unbound); # unbound stattdessen in den STACK
- if (!nullp(args)) goto fehler_dotted;
- }
- break;
- case (uintW)fsubr_argtype_2_body:
- # FSUBR mit 2 required-Parametern und Body-Parameter
- REQ_PAR();
- case (uintW)fsubr_argtype_1_body:
- # FSUBR mit 1 required-Parameter und Body-Parameter
- REQ_PAR();
- case (uintW)fsubr_argtype_0_body:
- # FSUBR mit 0 required-Parametern und Body-Parameter
- pushSTACK(args); # restlichen Body in den STACK
- break;
- default: NOTREACHED
- fehler_zuwenig: # Argumentliste args ist vorzeitig ein Atom
- if (!nullp(args)) goto fehler_dotted;
- # STACK bis zum aufrufenden EVAL-Frame aufräumen:
- until (mtypecode(STACK_0) & bit(frame_bit_t)) { skipSTACK(1); }
- { var reg4 object form = STACK_(frame_form); # Form aus dem EVAL-Frame
- pushSTACK(form);
- pushSTACK(Car(form));
- //: DEUTSCH "EVAL: Zu wenig Parameter für Spezialform ~: ~"
- //: ENGLISH "EVAL: too few parameters for special-form ~: ~"
- //: FRANCAIS "EVAL: Trop peu de paramètres pour la forme spéciale ~ : ~"
- fehler(program_error, GETTEXT("EVAL: too few parameters for special-form ~: ~"));
- }
- fehler_zuviel: # Argumentliste args ist am Schluß nicht NIL
- if (atomp(args)) goto fehler_dotted;
- # STACK bis zum aufrufenden EVAL-Frame aufräumen:
- until (mtypecode(STACK_0) & bit(frame_bit_t)) { skipSTACK(1); }
- { var reg4 object form = STACK_(frame_form); # Form aus dem EVAL-Frame
- pushSTACK(form);
- pushSTACK(Car(form));
- //: DEUTSCH "EVAL: Zu viele Parameter für Spezialform ~: ~"
- //: ENGLISH "EVAL: too many parameters for special-form ~: ~"
- //: FRANCAIS "EVAL: Trop de paramètres pour la forme spéciale ~ : ~"
- fehler(program_error, GETTEXT("EVAL: too many parameters for special-form ~: ~"));
- }
- fehler_dotted: # Argumentliste args endet mit Atom /= NIL
- # STACK bis zum aufrufenden EVAL-Frame aufräumen:
- until (mtypecode(STACK_0) & bit(frame_bit_t)) { skipSTACK(1); }
- { var reg4 object form = STACK_(frame_form); # Form aus dem EVAL-Frame
- pushSTACK(form);
- pushSTACK(Car(form));
- //: DEUTSCH "EVAL: Parameterliste für Spezialform ~ ist dotted: ~"
- //: ENGLISH "EVAL: dotted parameter list for special form ~: ~"
- //: FRANCAIS "EVAL: La liste de paramètres pour la forme spéciale ~ est pointée."
- fehler(program_error, GETTEXT("EVAL: dotted parameter list for special form ~: ~"));
- }
- #undef REQ_PAR
- }
- # FSUBR selbst aufrufen:
- subr_self = fun;
- (*(fsubr_function*)TheMachine(TheFsubr(fun)->function))();
- #if STACKCHECKS
- if (!(STACK == STACKbefore)) # STACK so wie vorher?
- { abort(); } # nein -> ab in den Debugger
- }
- #endif
- unwind(); # EVAL-Frame auflösen
- }
-
- # In EVAL: Wendet *APPLYHOOK* auf eine Funktion (SUBR oder Closure) und
- # eine Argumentliste an, räumt den STACK auf und liefert die Werte.
- # eval_applyhook(fun);
- # > fun: Funktion, ein SUBR oder eine Closure
- # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK* (/= NIL), Argumentliste.
- # < STACK: aufgeräumt
- # < mv_count/mv_space: Werte
- # verändert STACK
- # kann GC auslösen
- local Values eval_applyhook(fun)
- var reg5 object fun;
- {
- var reg4 object *args_ptr = &STACK_0;
- var reg3 object *applyhook_value_ptr = &STACK_1;
- var reg2 object *fun_ptr;
- pushSTACK(fun); fun_ptr = &STACK_0;
-
- check_SP();
-
- # *EVALHOOK*, *APPLYHOOK* an NIL binden:
- bindhooks_NIL();
- #ifndef X3J13_005
- # (FUNCALL *APPLYHOOK* fun args env) ausführen:
- pushSTACK(*fun_ptr); # Funktion als 1. Argument
- pushSTACK(*args_ptr); # Argumentliste als 2. Argument
- pushSTACK(*applyhook_value_ptr); # Funktion retten
- {var reg2 environment* stack_env = nest_aktenv(); # Environments in den Stack,
- var reg1 object env = allocate_vector(5); # in neu allozierten Vektor
- *(environment*)(&TheSvector(env)->data[0]) = *stack_env; # hineinschieben
- skipSTACK(5);
- }
- { var reg3 object applyhook_value = popSTACK();
- pushSTACK(env); # gesamtes Environment als 3. Argument
- funcall(applyhook_value,3);
- }
- #else
- # (FUNCALL *APPLYHOOK* fun args) ausführen:
- pushSTACK(*fun_ptr); # Funktion als 1. Argument
- pushSTACK(*args_ptr); # Argumentliste als 2. Argument
- funcall(*applyhook_value_ptr,2);
- #endif
- # alte Werte von *EVALHOOK*, *APPLYHOOK* zurück:
- unwind();
- # EVAL-Frame auflösen:
- skipSTACK(3);
- unwind();
- }
-
- # In EVAL: Fehler bei zu wenig Argumenten
- nonreturning_function(local, fehler_eval_zuwenig, (object fun));
- local void fehler_eval_zuwenig(fun)
- var reg2 object fun;
- { var reg1 object form = STACK_(frame_form); # Form
- pushSTACK(form);
- pushSTACK(fun);
- //: DEUTSCH "EVAL: Zu wenig Argumente für ~: ~"
- //: ENGLISH "EVAL: too few arguments given to ~: ~"
- //: FRANCAIS "EVAL: Trop peu d'arguments pour ~ : ~"
- fehler(program_error, GETTEXT("EVAL: too few arguments given to ~: ~"));
- }
-
- # In EVAL: Fehler bei zu vielen Argumenten
- nonreturning_function(local, fehler_eval_zuviel, (object fun));
- local void fehler_eval_zuviel(fun)
- var reg2 object fun;
- { var reg1 object form = STACK_(frame_form); # Form
- pushSTACK(form);
- pushSTACK(fun);
- //: DEUTSCH "EVAL: Zu viele Argumente für ~: ~"
- //: ENGLISH "EVAL: too many arguments given to ~: ~"
- //: FRANCAIS "EVAL: Trop d'arguments pour ~ : ~"
- fehler(program_error, GETTEXT("EVAL: too many arguments given to ~: ~"));
- }
-
- # In EVAL: Fehler bei punktierter Argumentliste
- nonreturning_function(local, fehler_eval_dotted, (object fun));
- local void fehler_eval_dotted(fun)
- var reg2 object fun;
- { var reg1 object form = STACK_(frame_form); # Form
- pushSTACK(form);
- pushSTACK(fun);
- //: DEUTSCH "EVAL: Argumentliste für ~ ist dotted: ~"
- //: ENGLISH "EVAL: argument list given to ~ is dotted: ~"
- //: FRANCAIS "EVAL: La liste d'arguments passée à ~ est pointée."
- fehler(program_error, GETTEXT("EVAL: argument list given to ~ is dotted: ~"));
- }
-
- # In EVAL: Wendet ein SUBR auf eine Argumentliste an, räumt den STACK auf
- # und liefert die Werte.
- # eval_subr(fun);
- # > fun: Funktion, ein SUBR
- # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*, Argumentliste.
- # < STACK: aufgeräumt
- # < mv_count/mv_space: Werte
- # verändert STACK
- # kann GC auslösen
- local Values eval_subr(fun)
- var reg2 object fun;
- { var reg1 object args = popSTACK(); # Argumentliste
- skipSTACK(1); # Wert von *APPLYHOOK* vergessen
- check_SP(); check_STACK();
- {var reg1 object* args_pointer = args_end_pointer; # Pointer über die Argumente
- var reg1 object* rest_args_pointer; # Pointer über die restlichen Argumente
- var reg1 uintL argcount; # Anzahl der restlichen Argumente
- # Argumente ausgewertet in den STACK legen:
- # erst ein Dispatch für die wichtigsten Fälle:
- switch (TheSubr(fun)->argtype)
- { # Macro für ein required-Argument:
- #define REQ_ARG() \
- { if (atomp(args)) goto fehler_zuwenig; \
- pushSTACK(Cdr(args)); # restliche Argumente \
- eval(Car(args)); # nächstes Argument auswerten \
- args = STACK_0; STACK_0 = value1; # und in den STACK \
- }
- # Macro für das n-letzte optional-Argument:
- #define OPT_ARG(n) \
- { if (atomp(args)) goto unbound_optional_##n ; \
- pushSTACK(Cdr(args)); # restliche Argumente \
- eval(Car(args)); # nächstes Argument auswerten \
- args = STACK_0; STACK_0 = value1; # und in den STACK \
- }
- case (uintW)subr_argtype_6_0:
- # SUBR mit 6 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_5_0:
- # SUBR mit 5 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_4_0:
- # SUBR mit 4 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_3_0:
- # SUBR mit 3 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_2_0:
- # SUBR mit 2 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_0:
- # SUBR mit 1 required-Argument
- REQ_ARG();
- case (uintW)subr_argtype_0_0:
- # SUBR ohne Argumente
- if (!nullp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_4_1:
- # SUBR mit 4 required-Argumenten und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_3_1:
- # SUBR mit 3 required-Argumenten und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_2_1:
- # SUBR mit 2 required-Argumenten und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_1_1:
- # SUBR mit 1 required-Argument und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_0_1:
- # SUBR mit 1 optional-Argument
- OPT_ARG(1);
- if (!nullp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_2_2:
- # SUBR mit 2 required-Argumenten und 2 optional-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_2:
- # SUBR mit 1 required-Argument und 2 optional-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_2:
- # SUBR mit 2 optional-Argumenten
- OPT_ARG(2);
- OPT_ARG(1);
- if (!nullp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_0_5:
- # SUBR mit 5 optional-Argumenten
- OPT_ARG(5);
- case (uintW)subr_argtype_0_4:
- # SUBR mit 4 optional-Argumenten
- OPT_ARG(4);
- case (uintW)subr_argtype_0_3:
- # SUBR mit 3 optional-Argumenten
- OPT_ARG(3);
- OPT_ARG(2);
- OPT_ARG(1);
- if (!nullp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- unbound_optional_5: # Noch 5 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_4: # Noch 4 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_3: # Noch 3 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_2: # Noch 2 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_1: # Noch 1 optionales Argument, aber atomp(args)
- pushSTACK(unbound);
- if (!nullp(args)) goto fehler_dotted;
- goto apply_subr_norest;
- case (uintW)subr_argtype_3_0_rest:
- # SUBR mit 3 required-Argumenten und weiteren Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_2_0_rest:
- # SUBR mit 2 required-Argumenten und weiteren Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_0_rest:
- # SUBR mit 1 required-Argument und weiteren Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_0_rest:
- # SUBR mit weiteren Argumenten
- rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
- # alle weiteren Argumente auswerten und in den Stack:
- argcount = 0; # Zähler für die restlichen Argumente
- while (consp(args))
- { check_STACK();
- pushSTACK(Cdr(args)); # restliche Argumente
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den STACK
- argcount++;
- }
- goto apply_subr_rest;
- case (uintW)subr_argtype_4_0_key:
- # SUBR mit 4 required-Argumenten und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_3_0_key:
- # SUBR mit 3 required-Argumenten und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_2_0_key:
- # SUBR mit 2 required-Argumenten und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_0_key:
- # SUBR mit 1 required-Argument und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_0_key:
- # SUBR mit Keyword-Argumenten
- if (atomp(args)) goto unbound_optional_key_0;
- goto apply_subr_key;
- case (uintW)subr_argtype_1_1_key:
- # SUBR mit 1 required-Argument, 1 optional-Argument und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_1_key:
- # SUBR mit 1 optional-Argument und Keyword-Argumenten
- OPT_ARG(key_1);
- if (atomp(args)) goto unbound_optional_key_0;
- goto apply_subr_key;
- case (uintW)subr_argtype_1_2_key:
- # SUBR mit 1 required-Argument, 2 optional-Argumenten und Keyword-Argumenten
- REQ_ARG();
- OPT_ARG(key_2);
- OPT_ARG(key_1);
- if (atomp(args)) goto unbound_optional_key_0;
- goto apply_subr_key;
- unbound_optional_key_2: # Noch 2 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_1: # Noch 1 optionales Argument, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_0: # Vor den Keywords ist atomp(args)
- { var reg1 uintC count;
- dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
- }
- if (!nullp(args)) goto fehler_dotted;
- goto apply_subr_norest;
- default: NOTREACHED
- #undef OPT_ARG
- #undef REQ_ARG
- }
- # Nun die allgemeine Version:
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) *
- (uintL)(TheSubr(fun)->req_anz +
- TheSubr(fun)->opt_anz +
- TheSubr(fun)->key_anz));
- # required Parameter auswerten und in den Stack ablegen:
- { var reg1 uintC count;
- dotimesC(count,TheSubr(fun)->req_anz,
- { if (atomp(args)) goto fehler_zuwenig; # Argumentliste zu Ende?
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- });
- }
- # optionale Parameter auswerten und in den Stack ablegen:
- { var reg1 uintC count = TheSubr(fun)->opt_anz;
- loop
- { if (atomp(args)) break; # Argumentliste zu Ende?
- if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
- count--;
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- }
- # Argumentliste beendet.
- # Alle weiteren count optionalen Parameter bekommen den "Wert"
- # #<UNBOUND>, auch die Keyword-Parameter:
- dotimesC(count,count + TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
- if (TheSubr(fun)->rest_flag == subr_rest) # &REST-Flag?
- # ja -> 0 zusätzliche Argumente:
- { argcount = 0; rest_args_pointer = args_end_pointer; }
- # nein -> nichts zu tun
- goto los;
- }
- optionals_ok:
- # Rest- und Keyword-Parameter behandeln.
- # args = restliche Argumentliste (noch nicht zu Ende)
- if (TheSubr(fun)->key_flag == subr_nokey)
- # SUBR ohne KEY
- { if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne REST oder KEY -> Argumentliste müßte zu Ende sein
- { goto fehler_zuviel; }
- else
- # SUBR mit nur REST, ohne KEY: Behandlung der restlichen Argumente
- { rest_args_pointer = args_end_pointer;
- argcount = 0; # Zähler für die restlichen Argumente
- do { check_STACK();
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- argcount++;
- }
- while (consp(args));
- if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
- { goto fehler_zuviel; }
- } }
- else
- # SUBR mit Keywords.
- apply_subr_key:
- # args = restliche Argumentliste (noch nicht zu Ende)
- # Erst die Keyword-Parameter mit #<UNBOUND> vorbesetzen, dann
- # die restlichen Argumente auswerten und im Stack ablegen, dann
- # die Keywords zuordnen:
- { var reg1 object* key_args_pointer = args_end_pointer; # Pointer über Keyword-Parameter
- # alle Keyword-Parameter mit #<UNBOUND> vorbesetzen:
- { var reg1 uintC count;
- dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
- }
- rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
- # alle weiteren Argumente auswerten und in den Stack:
- argcount = 0; # Zähler für die restlichen Argumente
- do { check_STACK();
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- argcount++;
- }
- while (consp(args));
- if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
- { goto fehler_zuviel; }
- # Keywords zuordnen und evtl. restliche Argumente wegwerfen:
- match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
- }
- los: # Funktion anspringen
- # restliche Argumentliste muß =NIL sein:
- if (!nullp(args)) goto fehler_dotted;
- if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne &REST-Flag:
- apply_subr_norest:
- { subr_self = fun;
- (*(subr_norest_function*)(TheSubr(fun)->function))();
- }
- else
- # SUBR mit &REST-Flag:
- apply_subr_rest:
- { subr_self = fun;
- (*(subr_rest_function*)(TheSubr(fun)->function))
- (argcount,rest_args_pointer);
- }
- #if STACKCHECKS
- if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
- { abort(); } # nein -> ab in den Debugger
- #endif
- unwind(); # EVAL-Frame auflösen
- return; # fertig
- # Gesammelte Fehlermeldungen:
- fehler_zuwenig: # Argumentliste args ist vorzeitig ein Atom
- if (!nullp(args)) goto fehler_dotted;
- set_args_end_pointer(args_pointer); # STACK aufräumen
- fehler_eval_zuwenig(TheSubr(fun)->name);
- fehler_zuviel: # Argumentliste args ist am Schluß nicht NIL
- if (atomp(args)) goto fehler_dotted;
- set_args_end_pointer(args_pointer); # STACK aufräumen
- fehler_eval_zuviel(TheSubr(fun)->name);
- fehler_dotted: # Argumentliste args endet mit Atom /= NIL
- set_args_end_pointer(args_pointer); # STACK aufräumen
- fehler_eval_dotted(TheSubr(fun)->name);
- }}
-
- # In EVAL: Wendet eine Closure auf eine Argumentliste an, räumt den STACK auf
- # und liefert die Werte.
- # eval_closure(fun);
- # > fun: Funktion, eine Closure
- # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*, Argumentliste.
- # < STACK: aufgeräumt
- # < mv_count/mv_space: Werte
- # verändert STACK
- # kann GC auslösen
- local Values eval_closure(closure)
- var reg2 object closure;
- { var reg1 object args = popSTACK(); # Argumentliste
- skipSTACK(1); # Wert von *APPLYHOOK* vergessen
- # STACK-Aufbau: EVAL-Frame.
- check_SP(); check_STACK();
- pushSTACK(closure); # Closure retten
- {var reg1 object* closure_ = &STACK_0; # und merken, wo sie sitzt
- if (m_simple_bit_vector_p(TheClosure(closure)->clos_codevec))
- # closure ist eine compilierte Closure
- { var reg10 object* STACKbefore = STACK;
- var reg1 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
- # Argumente ausgewertet in den STACK legen:
- # erst ein Dispatch für die wichtigsten Fälle:
- switch (TheSbvector(codevec)->data[CCHD+5])
- { # Macro für ein required-Argument:
- #define REQ_ARG() \
- { if (atomp(args)) goto fehler_zuwenig; \
- pushSTACK(Cdr(args)); # restliche Argumente \
- eval(Car(args)); # nächstes Argument auswerten \
- args = STACK_0; STACK_0 = value1; # und in den STACK \
- }
- # Macro für das n-letzte optional-Argument:
- #define OPT_ARG(n) \
- { if (atomp(args)) goto unbound_optional_##n ; \
- pushSTACK(Cdr(args)); # restliche Argumente \
- eval(Car(args)); # nächstes Argument auswerten \
- args = STACK_0; STACK_0 = value1; # und in den STACK \
- }
- case (uintB)cclos_argtype_5_0:
- # 5 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_4_0:
- # 4 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_3_0:
- # 3 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_0:
- # 2 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_0:
- # 1 required-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_0_0:
- # keine Argumente
- noch_0_opt_args:
- if (!nullp(args)) goto fehler_zuviel;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_4_1:
- # 4 required-Argumente und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_3_1:
- # 3 required-Argumente und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_2_1:
- # 2 required-Argumente und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_1_1:
- # 1 required-Argument und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_0_1:
- # 1 optional-Argument
- noch_1_opt_args:
- OPT_ARG(1);
- goto noch_0_opt_args;
- case (uintB)cclos_argtype_3_2:
- # 3 required-Argumente und 2 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_2:
- # 2 required-Argumente und 2 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_2:
- # 1 required-Argument und 2 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_2:
- # 2 optional-Argumente
- noch_2_opt_args:
- OPT_ARG(2);
- goto noch_1_opt_args;
- case (uintB)cclos_argtype_2_3:
- # 2 required-Argumente und 3 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_3:
- # 1 required-Argument und 3 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_3:
- # 3 optional-Argumente
- noch_3_opt_args:
- OPT_ARG(3);
- goto noch_2_opt_args;
- case (uintB)cclos_argtype_1_4:
- # 1 required-Argument und 4 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_4:
- # 4 optional-Argumente
- noch_4_opt_args:
- OPT_ARG(4);
- goto noch_3_opt_args;
- case (uintB)cclos_argtype_0_5:
- # 5 optional-Argumente
- OPT_ARG(5);
- goto noch_4_opt_args;
- unbound_optional_5: # Noch 5 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_4: # Noch 4 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_3: # Noch 3 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_2: # Noch 2 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_1: # Noch 1 optionales Argument, aber atomp(args)
- pushSTACK(unbound);
- if (!nullp(args)) goto fehler_dotted;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_4_0_rest:
- # 4 required-Argumente, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_3_0_rest:
- # 3 required-Argumente, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_2_0_rest:
- # 2 required-Argumente, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_1_0_rest:
- # 1 required-Argument, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_0_0_rest:
- # keine Argumente, Rest-Parameter
- if (consp(args)) goto apply_cclosure_rest_nokey;
- if (!nullp(args)) goto fehler_dotted;
- pushSTACK(NIL); # Rest-Parameter := NIL
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_4_0_key:
- # 4 required-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_3_0_key:
- # 3 required-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_0_key:
- # 2 required-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_0_key:
- # 1 required-Argument, Keyword-Argumente
- REQ_ARG();
- noch_0_opt_args_key:
- closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
- case (uintB)cclos_argtype_0_0_key:
- # nur Keyword-Argumente
- if (atomp(args)) goto unbound_optional_key_0;
- goto apply_cclosure_key;
- case (uintB)cclos_argtype_3_1_key:
- # 3 required-Argumente und 1 optional-Argument, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_1_key:
- # 2 required-Argumente und 1 optional-Argument, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_1_key:
- # 1 required-Argument und 1 optional-Argument, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_1_key:
- # 1 optional-Argument, Keyword-Argumente
- noch_1_opt_args_key:
- OPT_ARG(key_1);
- goto noch_0_opt_args_key;
- case (uintB)cclos_argtype_2_2_key:
- # 2 required-Argumente und 2 optional-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_2_key:
- # 1 required-Argument und 2 optional-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_2_key:
- # 2 optional-Argumente, Keyword-Argumente
- noch_2_opt_args_key:
- OPT_ARG(key_2);
- goto noch_1_opt_args_key;
- case (uintB)cclos_argtype_1_3_key:
- # 1 required-Argument und 3 optional-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_3_key:
- # 3 optional-Argumente, Keyword-Argumente
- noch_3_opt_args_key:
- OPT_ARG(key_3);
- goto noch_2_opt_args_key;
- case (uintB)cclos_argtype_0_4_key:
- # 4 optional-Argumente, Keyword-Argumente
- OPT_ARG(key_4);
- goto noch_3_opt_args_key;
- unbound_optional_key_4: # Noch 4 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_3: # Noch 3 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_2: # Noch 2 optionale Argumente, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_1: # Noch 1 optionales Argument, aber atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_0: # Vor den Keywords ist atomp(args)
- if (!nullp(args)) goto fehler_dotted;
- goto apply_cclosure_key_noargs;
- case (uintB)cclos_argtype_default:
- # Allgemeine Version
- break;
- default: NOTREACHED
- #undef OPT_ARG
- #undef REQ_ARG
- }
- # Nun die allgemeine Version:
- { var reg1 uintL req_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]); # Anzahl required Parameter
- var reg1 uintL opt_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+2]); # Anzahl optionale Parameter
- var reg1 uintB flags = TheSbvector(codevec)->data[CCHD+4]; # Flags
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (req_anz+opt_anz));
- # required Parameter auswerten und in den Stack ablegen:
- { var reg1 uintC count;
- dotimesC(count,req_anz,
- { if (atomp(args)) goto fehler_zuwenig; # Argumentliste zu Ende?
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- });
- }
- # optionale Parameter auswerten und in den Stack ablegen:
- { var reg1 uintC count = opt_anz;
- loop
- { if (atomp(args)) break; # Argumentliste zu Ende?
- if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
- count--;
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- }
- # Argumentliste beendet.
- if (!nullp(args)) goto fehler_dotted;
- # Alle weiteren count optionalen Parameter bekommen den "Wert"
- # #<UNBOUND>, der &REST-Parameter den Wert NIL,
- # die Keyword-Parameter den Wert #<UNBOUND> :
- dotimesC(count,count, { pushSTACK(unbound); } );
- closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
- if (flags & bit(0)) # &REST-Flag?
- { pushSTACK(NIL); } # ja -> mit NIL initialisieren
- if (flags & bit(7)) # &KEY-Flag?
- apply_cclosure_key_noargs:
- { var reg1 uintC count = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
- dotimesC(count,count, { pushSTACK(unbound); } ); # mit #<UNBOUND> initialisieren
- interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
- }
- else
- { interpret_bytecode(closure,codevec,CCHD+6); } # Bytecode ab Byte 6 abinterpretieren
- goto fertig;
- }
- optionals_ok:
- # Rest- und Keyword-Parameter behandeln.
- # args = restliche Argumentliste (noch nicht zu Ende)
- closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
- if (flags == 0)
- # Closure ohne REST oder KEY -> Argumentliste müßte zu Ende sein
- { goto fehler_zuviel; }
- elif (flags & bit(7)) # Key-Flag?
- # Closure mit Keywords.
- # args = restliche Argumentliste (noch nicht zu Ende)
- # Erst die Keyword-Parameter mit #<UNBOUND> vorbesetzen, dann
- # die restlichen Argumente auswerten und im Stack ablegen, dann
- # die Keywords zuordnen:
- { # evtl. den Rest-Parameter vorbesetzen:
- if (flags & bit(0)) { pushSTACK(unbound); }
- apply_cclosure_key: # Closure mit nur &KEY anspringen:
- {var reg1 object* key_args_pointer = args_end_pointer; # Pointer über Keyword-Parameter
- # alle Keyword-Parameter mit #<UNBOUND> vorbesetzen:
- { var reg1 uintC count = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]);
- dotimesC(count,count, { pushSTACK(unbound); } );
- }
- {var reg1 object* rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
- # alle weiteren Argumente auswerten und in den Stack:
- var reg1 uintL argcount = 0; # Zähler für die restlichen Argumente
- do { check_STACK();
- pushSTACK(Cdr(args)); # restliche Argumentliste
- eval(Car(args)); # nächstes Argument auswerten
- args = STACK_0; STACK_0 = value1; # und in den Stack
- argcount++;
- }
- while (consp(args));
- # Argumentliste beendet.
- if (!nullp(args)) goto fehler_dotted;
- # Keywords zuordnen, Rest-Parameter bauen
- # und evtl. restliche Argumente wegwerfen:
- closure = match_cclosure_key(*closure_,argcount,key_args_pointer,rest_args_pointer);
- codevec = TheCclosure(closure)->clos_codevec;
- interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
- }}}
- else
- apply_cclosure_rest_nokey:
- # Closure mit nur REST, ohne KEY:
- # restlichen Argumente einzeln auswerten, zu einer Liste machen
- # args = restliche Argumentliste (noch nicht zu Ende)
- { pushSTACK(NIL); # bisher ausgewertete restliche Argumente
- pushSTACK(args); # restliche Argumente, unausgewertet
- do { args = STACK_0; STACK_0 = Cdr(args);
- eval(Car(args)); # nächstes Argument auswerten
- pushSTACK(value1);
- # und auf die Liste consen:
- {var reg1 object new_cons = allocate_cons();
- Car(new_cons) = popSTACK();
- Cdr(new_cons) = STACK_1;
- STACK_1 = new_cons;
- }}
- while (mconsp(STACK_0));
- args = popSTACK();
- # Liste STACK_0 umdrehen und als REST-Parameter verwenden:
- nreverse(STACK_0);
- # Argumentliste beendet.
- if (!nullp(args)) goto fehler_dotted;
- apply_cclosure_nokey: # Closure ohne &KEY anspringen:
- closure = *closure_; codevec = TheCclosure(closure)->clos_codevec;
- interpret_bytecode(closure,codevec,CCHD+6); # Bytecode ab Byte 6 abinterpretieren
- }
- fertig: ;
- }
- #if STACKCHECKC
- if (!(STACK == STACKbefore)) # STACK so wie vorher?
- { abort(); } # nein -> ab in den Debugger
- #endif
- skipSTACK(1); # Closure wegwerfen
- unwind(); # EVAL-Frame auflösen
- return; # fertig
- # Gesammelte Fehlermeldungen:
- fehler_zuwenig: # Argumentliste args ist vorzeitig ein Atom
- if (!nullp(args)) goto fehler_dotted;
- setSTACK(STACK = STACKbefore); # STACK aufräumen
- closure = popSTACK();
- fehler_eval_zuwenig(TheCclosure(closure)->clos_name);
- fehler_zuviel: # Argumentliste args ist am Schluß nicht NIL
- if (atomp(args)) goto fehler_dotted;
- setSTACK(STACK = STACKbefore); # STACK aufräumen
- closure = popSTACK();
- fehler_eval_zuviel(TheCclosure(closure)->clos_name);
- fehler_dotted: # Argumentliste args endet mit Atom /= NIL
- setSTACK(STACK = STACKbefore); # STACK aufräumen
- closure = popSTACK();
- fehler_eval_dotted(TheCclosure(closure)->clos_name);
- }
- else
- # closure ist eine interpretierte Closure
- { var reg7 object* args_pointer = args_end_pointer; # Pointer über die Argumente
- var reg6 uintC args_on_stack = 0; # Anzahl der Argumente
- while (consp(args))
- { pushSTACK(Cdr(args)); # Listenrest retten
- eval(Car(args)); # nächstes Element auswerten
- args = STACK_0; STACK_0 = value1; # Auswertungsergebnis in den STACK
- args_on_stack += 1;
- if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
- goto fehler_zuviel;
- }
- funcall_iclosure(*closure_,args_pointer,args_on_stack);
- skipSTACK(1); # Closure wegwerfen
- unwind(); # EVAL-Frame auflösen
- return; # fertig
- }
- }}
-
- #ifdef DYNAMIC_FFI
- # In EVAL: Wendet eine Foreign-Function auf eine Argumentliste an,
- # räumt den STACK auf und liefert die Werte.
- # eval_ffunction(fun);
- # > fun: Funktion, eine Foreign-Function
- # > STACK-Aufbau: EVAL-Frame, *APPLYHOOK*, Argumentliste.
- # < STACK: aufgeräumt
- # < mv_count/mv_space: Werte
- # verändert STACK
- # kann GC auslösen
- local Values eval_ffunction(ffun)
- var reg3 object ffun;
- { var reg1 object args = popSTACK(); # Argumentliste
- skipSTACK(1); # Wert von *APPLYHOOK* vergessen
- # STACK-Aufbau: EVAL-Frame.
- # (ffun arg ...) --> (FFI::FOREIGN-CALL-OUT ffun arg ...)
- check_SP(); check_STACK();
- pushSTACK(ffun); # Foreign-Funktion als 1. Argument
- { var reg4 object* args_pointer = args_end_pointer; # Pointer über die Argumente
- var reg2 uintC args_on_stack = 1; # Anzahl der Argumente
- while (consp(args))
- { pushSTACK(Cdr(args)); # Listenrest retten
- eval(Car(args)); # nächstes Element auswerten
- args = STACK_0; STACK_0 = value1; # Auswertungsergebnis in den STACK
- args_on_stack += 1;
- if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
- { set_args_end_pointer(args_pointer);
- fehler_eval_zuviel(popSTACK());
- }
- }
- funcall(L(foreign_call_out),args_on_stack);
- }
- unwind(); # EVAL-Frame auflösen
- return; # fertig
- }
- #endif
-
-
- # ----------------------- A P P L Y -----------------------
-
- # später:
- local Values apply_subr (object fun, uintC args_on_stack, object other_args);
- local Values apply_closure (object fun, uintC args_on_stack, object other_args);
-
- # UP: Wendet eine Funktion auf ihre Argumente an.
- # apply(function,args_on_stack,other_args);
- # > function: Funktion
- # > Argumente: args_on_stack Argumente auf dem STACK,
- # restliche Argumentliste in other_args
- # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- global Values apply (object fun, uintC args_on_stack, object other_args);
- global Values apply(fun,args_on_stack,other_args)
- var reg2 object fun;
- var reg4 uintC args_on_stack;
- var reg3 object other_args;
- { # fun muß ein SUBR oder eine Closure oder ein Cons (LAMBDA ...) sein:
- var reg1 tint type = typecode(fun); # Typinfo
- if (type == subr_type) # SUBR ?
- { return_Values apply_subr(fun,args_on_stack,other_args); }
- elif (type == closure_type) # Closure ?
- { return_Values apply_closure(fun,args_on_stack,other_args); }
- elif (symbolp(fun)) # Symbol ?
- # Symbol anwenden: globale Definition Symbol_function(fun) gilt.
- { type = mtypecode(Symbol_function(fun)); # Typinfo davon
- if (type == subr_type) # SUBR -> anwenden
- { return_Values apply_subr(Symbol_function(fun),args_on_stack,other_args); }
- elif (type == closure_type) # Closure -> anwenden
- { return_Values apply_closure(Symbol_function(fun),args_on_stack,other_args); }
- elif (type == orecord_type)
- {
- #ifdef DYNAMIC_FFI
- if (ffunctionp(Symbol_function(fun))) # Foreign-Function ?
- { fun = Symbol_function(fun); goto call_ffunction; }
- #endif
- # FSUBR -> Fehler
- pushSTACK(fun);
- //: DEUTSCH "APPLY: ~ ist eine Spezialform, keine Funktion."
- //: ENGLISH "APPLY: ~ is a special form, not a function"
- //: FRANCAIS "APPLY: ~ est une forme spéciale et non une fonction."
- fehler(error, GETTEXT("APPLY: ~ is a special form, not a function"));
- }
- elif (mconsp(Symbol_function(fun))) # Macro-Cons -> Fehler
- { pushSTACK(fun);
- //: DEUTSCH "APPLY: ~ ist ein Macro, keine Funktion."
- //: ENGLISH "APPLY: ~ is a macro, not a function"
- //: FRANCAIS "APPLY: ~ est un macro et non une fonction."
- fehler(error, GETTEXT("APPLY: ~ is a macro, not a function"));
- }
- else
- # wenn kein SUBR, keine Closure, kein FSUBR, kein Cons:
- # Symbol_function(fun) muß #<UNBOUND> sein.
- undef:
- { pushSTACK(fun); # Wert für Slot NAME von CELL-ERROR
- pushSTACK(fun);
- //: DEUTSCH "APPLY: Die Funktion ~ ist undefiniert."
- //: ENGLISH "APPLY: the function ~ is undefined"
- //: FRANCAIS "APPLY: La fonction ~ n'est pas définie."
- fehler(undefined_function, GETTEXT("APPLY: the function ~ is undefined"));
- }
- }
- elif (funnamep(fun)) # Liste (SETF symbol) ?
- # globale Definition (symbol-function (get-setf-symbol symbol)) gilt.
- { var reg5 object symbol = get(Car(Cdr(fun)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
- if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
- goto undef; # sonst undefiniert
- type = mtypecode(Symbol_function(symbol)); # Typinfo davon
- if (type == closure_type) # Closure -> anwenden
- { return_Values apply_closure(Symbol_function(symbol),args_on_stack,other_args); }
- elif (type == subr_type) # SUBR -> anwenden
- { return_Values apply_subr(Symbol_function(symbol),args_on_stack,other_args); }
- else
- # Solche Funktionsnamen können keine FSUBRs oder Macros bezeichnen.
- # Symbol_function(symbol) wird vermutlich #<UNBOUND> sein.
- goto undef;
- }
- elif (consp(fun) && eq(Car(fun),S(lambda))) # Cons (LAMBDA ...) ?
- # Lambda-Ausdruck: zu einer Funktion mit leerem Environment machen
- { pushSTACK(other_args); # Argumentliste retten
- # leeres Environment bauen:
- {var reg5 environment* env5;
- make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env5 = );
- fun = get_closure(Cdr(fun), # Lambdabody (lambda-list {decl|doc} . body)
- S(Klambda), # :LAMBDA als Name
- env5); # im leeren Environment
- skipSTACK(5); # Environment wieder vergessen
- other_args = popSTACK();
- # und neu erzeugte Closure anwenden:
- return_Values apply_closure(fun,args_on_stack,other_args);
- }}
- #ifdef DYNAMIC_FFI
- elif (ffunctionp(fun)) # Foreign-Function ?
- # (SYS::FOREIGN-CALL-OUT foreign-function . args) aufrufen
- call_ffunction:
- { # Dazu erst die Argumente im Stack um 1 nach unten verschieben.
- var reg6 uintC count;
- var reg5 object* ptr = &STACK_0;
- dotimesC(count,args_on_stack,
- { *(ptr STACKop -1) = *ptr; ptr skipSTACKop 1; }
- );
- *(ptr STACKop -1) = fun;
- skipSTACK(-1);
- return_Values apply_subr(L(foreign_call_out),args_on_stack+1,other_args);
- }
- #endif
- else
- { pushSTACK(fun);
- //: DEUTSCH "APPLY: ~ ist keine Funktionsbezeichnung."
- //: ENGLISH "APPLY: ~ is not a function name"
- //: FRANCAIS "APPLY: ~ n'est pas un nom de fonction."
- fehler(error, GETTEXT("APPLY: ~ is not a function name"));
- }
- }
-
- # Fehler wegen punktierter Argumentliste
- # > name: Name der Funktion
- nonreturning_function(local, fehler_apply_dotted, (object name));
- local void fehler_apply_dotted(name)
- var reg1 object name;
- { pushSTACK(name);
- //: DEUTSCH "APPLY: Argumentliste für ~ ist dotted."
- //: ENGLISH "APPLY: argument list given to ~ is dotted"
- //: FRANCAIS "APPLY: La liste d'arguments pour ~ est pointée."
- fehler(error, GETTEXT("APPLY: argument list given to ~ is dotted"));
- }
-
- # Fehler wegen zu vielen Argumenten
- # > name: Name der Funktion
- nonreturning_function(local, fehler_apply_zuviel, (object name));
- local void fehler_apply_zuviel(name)
- var reg1 object name;
- { pushSTACK(name);
- //: DEUTSCH "APPLY: Zu viele Argumente für ~"
- //: ENGLISH "APPLY: too many arguments given to ~"
- //: FRANCAIS "APPLY: Trop d'arguments pour ~"
- fehler(error, GETTEXT("APPLY: too many arguments given to ~"));
- }
-
- # Fehler wegen zu wenig Argumenten
- # > name: Name der Funktion
- nonreturning_function(local, fehler_apply_zuwenig, (object name));
- local void fehler_apply_zuwenig(name)
- var reg1 object name;
- { pushSTACK(name);
- //: DEUTSCH "APPLY: Zu wenig Argumente für ~"
- //: ENGLISH "APPLY: too few arguments given to ~"
- //: FRANCAIS "APPLY: Trop peu d'arguments pour ~"
- fehler(error, GETTEXT("APPLY: too few arguments given to ~"));
- }
-
- # Fehler wegen zu vielen Argumenten für ein SUBR
- # > fun: Funktion, ein SUBR
- nonreturning_function(local, fehler_subr_zuviel, (object fun));
- #define fehler_subr_zuviel(fun) fehler_apply_zuviel(TheSubr(fun)->name)
-
- # Fehler wegen zu wenig Argumenten für ein SUBR
- # > fun: Funktion, ein SUBR
- nonreturning_function(local, fehler_subr_zuwenig, (object fun));
- #define fehler_subr_zuwenig(fun) fehler_apply_zuwenig(TheSubr(fun)->name)
-
- # In APPLY: Wendet ein SUBR auf eine Argumentliste an, räumt den STACK auf
- # und liefert die Werte.
- # apply_subr(fun,args_on_stack,other_args);
- # > fun: Funktion, ein SUBR
- # > Argumente: args_on_stack Argumente auf dem STACK,
- # restliche Argumentliste in other_args
- # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- local Values apply_subr(fun,args_on_stack,args)
- var reg4 object fun;
- var reg3 uintC args_on_stack;
- var reg2 object args;
- {
- #if STACKCHECKS
- var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
- #endif
- var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
- var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
- var reg8 uintL argcount; # Anzahl der restlichen Argumente
- #ifdef DEBUG_EVAL
- if (sym_streamp(S(funcall_trace_output)))
- { pushSTACK(fun); trace_call(fun,'A','S'); fun = popSTACK(); }
- #endif
- # Argumente in den STACK legen:
- # erst ein Dispatch für die wichtigsten Fälle:
- switch (TheSubr(fun)->argtype)
- { # Macro für ein required-Argument:
- #define REQ_ARG() \
- { if (args_on_stack>0) { args_on_stack--; } \
- elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
- else goto fehler_zuwenig; \
- }
- # Macro für das n-letzte optional-Argument:
- #define OPT_ARG(n) \
- { if (args_on_stack>0) { args_on_stack--; } \
- elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
- else goto unbound_optional_##n; \
- }
- case (uintW)subr_argtype_6_0:
- # SUBR mit 6 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_5_0:
- # SUBR mit 5 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_4_0:
- # SUBR mit 4 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_3_0:
- # SUBR mit 3 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_2_0:
- # SUBR mit 2 required-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_0:
- # SUBR mit 1 required-Argument
- REQ_ARG();
- case (uintW)subr_argtype_0_0:
- # SUBR ohne Argumente
- if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_4_1:
- # SUBR mit 4 required-Argumenten und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_3_1:
- # SUBR mit 3 required-Argumenten und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_2_1:
- # SUBR mit 2 required-Argumenten und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_1_1:
- # SUBR mit 1 required-Argument und 1 optional-Argument
- REQ_ARG();
- case (uintW)subr_argtype_0_1:
- # SUBR mit 1 optional-Argument
- OPT_ARG(1);
- if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_2_2:
- # SUBR mit 2 required-Argumenten und 2 optional-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_2:
- # SUBR mit 1 required-Argument und 2 optional-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_2:
- # SUBR mit 2 optional-Argumenten
- OPT_ARG(2);
- OPT_ARG(1);
- if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_0_5:
- # SUBR mit 5 optional-Argumenten
- OPT_ARG(5);
- case (uintW)subr_argtype_0_4:
- # SUBR mit 4 optional-Argumenten
- OPT_ARG(4);
- case (uintW)subr_argtype_0_3:
- # SUBR mit 3 optional-Argumenten
- OPT_ARG(3);
- OPT_ARG(2);
- OPT_ARG(1);
- if ((args_on_stack>0) || consp(args)) goto fehler_zuviel;
- goto apply_subr_norest;
- unbound_optional_5: # Noch 5 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_4: # Noch 4 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_3: # Noch 3 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- goto apply_subr_norest;
- case (uintW)subr_argtype_3_0_rest:
- # SUBR mit 3 required-Argumenten und weiteren Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_2_0_rest:
- # SUBR mit 2 required-Argumenten und weiteren Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_0_rest:
- # SUBR mit 1 required-Argument und weiteren Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_0_rest:
- # SUBR mit weiteren Argumenten
- if (args_on_stack==0)
- goto apply_subr_rest_onlylist;
- else
- goto apply_subr_rest_withlist;
- case (uintW)subr_argtype_4_0_key:
- # SUBR mit 4 required-Argumenten und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_3_0_key:
- # SUBR mit 3 required-Argumenten und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_2_0_key:
- # SUBR mit 2 required-Argumenten und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_1_0_key:
- # SUBR mit 1 required-Argument und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_0_key:
- # SUBR mit Keyword-Argumenten
- if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
- goto apply_subr_key;
- case (uintW)subr_argtype_1_1_key:
- # SUBR mit 1 required-Argument, 1 optional-Argument und Keyword-Argumenten
- REQ_ARG();
- case (uintW)subr_argtype_0_1_key:
- # SUBR mit 1 optional-Argument und Keyword-Argumenten
- OPT_ARG(key_1);
- if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
- goto apply_subr_key;
- case (uintW)subr_argtype_1_2_key:
- # SUBR mit 1 required-Argument, 2 optional-Argumenten und Keyword-Argumenten
- REQ_ARG();
- OPT_ARG(key_2);
- OPT_ARG(key_1);
- if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
- goto apply_subr_key;
- unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0 und atomp(args)
- { var reg1 uintC count;
- dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
- }
- goto apply_subr_norest;
- default: NOTREACHED
- #undef OPT_ARG
- #undef REQ_ARG
- }
- # Nun die allgemeine Version:
- {var reg5 uintC req_anz = TheSubr(fun)->req_anz;
- var reg6 uintC opt_anz = TheSubr(fun)->opt_anz;
- var reg7 uintC key_anz = TheSubr(fun)->key_anz;
- if (args_on_stack < req_anz)
- # weniger Argumente da als verlangt
- { req_anz = req_anz - args_on_stack; # soviele müssen noch auf den STACK
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (uintL)(req_anz + opt_anz + key_anz));
- # required Parameter in den Stack ablegen:
- { var reg1 uintC count;
- dotimespC(count,req_anz,
- { if (atomp(args)) { goto fehler_zuwenig; }
- pushSTACK(Car(args)); # nächstes Argument ablegen
- args = Cdr(args);
- });
- }
- goto optionals_from_list;
- }
- args_on_stack -= req_anz; # verbleibende Anzahl
- if (args_on_stack < opt_anz)
- # Argumente im Stack reichen nicht für die optionalen
- { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (uintL)(opt_anz + key_anz));
- optionals_from_list:
- # optionale Parameter in den Stack ablegen:
- { var reg1 uintC count = opt_anz;
- loop
- { if (atomp(args)) break; # Argumentliste zu Ende?
- if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
- count--;
- pushSTACK(Car(args)); # nächstes Argument ablegen
- args = Cdr(args);
- }
- # Argumentliste beendet.
- # Alle weiteren count optionalen Parameter bekommen den "Wert"
- # #<UNBOUND>, auch die Keyword-Parameter:
- dotimesC(count,count + key_anz, { pushSTACK(unbound); } );
- if (TheSubr(fun)->rest_flag == subr_rest) # &REST-Flag?
- # ja -> 0 zusätzliche Argumente:
- { argcount = 0; rest_args_pointer = args_end_pointer;
- goto apply_subr_rest;
- }
- else
- # nein -> nichts zu tun
- { goto apply_subr_norest; }
- }
- optionals_ok: # optionale Argumente OK, (nichtleere) Liste weiter abarbeiten
- if (TheSubr(fun)->key_flag == subr_nokey)
- # SUBR ohne KEY
- { if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne REST oder KEY
- { fehler_subr_zuviel(fun); } # zuviele Argumente
- else
- # SUBR mit nur REST, ohne KEY
- apply_subr_rest_onlylist:
- { argcount = 0; rest_args_pointer = args_end_pointer;
- goto rest_from_list;
- }
- }
- else
- # SUBR mit KEY
- { key_args_pointer = args_end_pointer;
- { var reg1 uintC count;
- dotimesC(count,key_anz, { pushSTACK(unbound); } );
- }
- rest_args_pointer = args_end_pointer;
- argcount = 0;
- goto key_from_list;
- }
- }
- args_on_stack -= opt_anz; # verbleibende Anzahl
- if (TheSubr(fun)->key_flag == subr_nokey)
- # SUBR ohne KEY
- { if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne REST oder KEY
- { if ((args_on_stack>0) || consp(args)) # noch Argumente?
- { fehler_subr_zuviel(fun); }
- goto apply_subr_norest;
- }
- else
- # SUBR mit nur REST, ohne KEY
- apply_subr_rest_withlist:
- { argcount = args_on_stack;
- rest_args_pointer = args_end_pointer STACKop argcount;
- rest_from_list: # restliche Argumente aus der Liste nehmen
- while (consp(args))
- { check_STACK(); pushSTACK(Car(args)); # nächstes Argument in den Stack
- args = Cdr(args);
- argcount++;
- }
- if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1)) # zu viele Argumente?
- { goto fehler_zuviel; }
- goto apply_subr_rest;
- }
- }
- else
- # SUBR mit Keywords.
- { if (FALSE)
- apply_subr_key: { key_anz = TheSubr(fun)->key_anz; }
- # restliche Argumente im STACK nach unten schieben und dadurch
- # Platz für die Keyword-Parameter schaffen:
- argcount = args_on_stack;
- get_space_on_STACK(sizeof(object) * (uintL)key_anz);
- {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)key_anz;
- var reg1 object* ptr1 = args_end_pointer;
- var reg1 object* ptr2 = new_args_end_pointer;
- var reg1 uintC count;
- dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
- key_args_pointer = ptr1;
- rest_args_pointer = ptr2;
- dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
- set_args_end_pointer(new_args_end_pointer);
- }
- key_from_list: # restliche Argumente für Keywords aus der Liste nehmen
- while (consp(args))
- { check_STACK(); pushSTACK(Car(args)); # nächstes Argument in den Stack
- args = Cdr(args);
- argcount++;
- }
- # Keywords zuordnen und evtl. restliche Argumente wegwerfen:
- match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
- if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne &REST-Flag:
- apply_subr_norest:
- { if (!nullp(args)) goto fehler_dotted;
- subr_self = fun;
- (*(subr_norest_function*)(TheSubr(fun)->function))();
- }
- else
- # SUBR mit &REST-Flag:
- apply_subr_rest:
- { if (!nullp(args)) goto fehler_dotted;
- subr_self = fun;
- (*(subr_rest_function*)(TheSubr(fun)->function))
- (argcount,rest_args_pointer);
- }
- } }
- #if STACKCHECKS
- if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
- { abort(); } # nein -> ab in den Debugger
- #endif
- return; # fertig
- # Gesammelte Fehlermeldungen:
- fehler_zuwenig: fehler_subr_zuwenig(fun);
- fehler_zuviel: fehler_subr_zuviel(fun);
- fehler_dotted: fehler_apply_dotted(TheSubr(fun)->name);
- }
-
- # Fehler wegen zu vielen Argumenten für eine Closure
- # > closure: Funktion, eine Closure
- nonreturning_function(local, fehler_closure_zuviel, (object closure));
- #define fehler_closure_zuviel(closure) fehler_apply_zuviel(closure)
-
- # Fehler wegen zu wenig Argumenten für eine Closure
- # > closure: Funktion, eine Closure
- nonreturning_function(local, fehler_closure_zuwenig, (object closure));
- #define fehler_closure_zuwenig(closure) fehler_apply_zuwenig(closure)
-
- # In APPLY: Wendet eine Closure auf eine Argumentliste an, räumt den STACK auf
- # und liefert die Werte.
- # apply_closure(fun,args_on_stack,other_args);
- # > fun: Funktion, eine Closure
- # > Argumente: args_on_stack Argumente auf dem STACK,
- # restliche Argumentliste in other_args
- # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- local Values apply_closure(closure,args_on_stack,args)
- var reg5 object closure;
- var reg3 uintC args_on_stack;
- var reg2 object args;
- {
- #ifdef DEBUG_EVAL
- if (sym_streamp(S(funcall_trace_output)))
- { pushSTACK(closure); trace_call(closure,'A','C'); closure = popSTACK(); }
- #endif
- if (m_simple_bit_vector_p(TheClosure(closure)->clos_codevec))
- # closure ist eine compilierte Closure
- {
- #if STACKCHECKC
- var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
- #endif
- var reg4 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
- var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
- var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
- var reg8 uintL argcount; # Anzahl der restlichen Argumente
- check_SP(); check_STACK();
- # Argumente in den STACK legen:
- # erst ein Dispatch für die wichtigsten Fälle:
- switch (TheSbvector(codevec)->data[CCHD+5])
- { # Macro für ein required-Argument:
- #define REQ_ARG() \
- { if (args_on_stack>0) { args_on_stack--; } \
- elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
- else goto fehler_zuwenig; \
- }
- # Macro für das n-letzte optional-Argument:
- #define OPT_ARG(n) \
- { if (args_on_stack>0) { args_on_stack--; } \
- elif (consp(args)) { pushSTACK(Car(args)); args = Cdr(args); } \
- else goto unbound_optional_##n; \
- }
- case (uintB)cclos_argtype_5_0:
- # 5 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_4_0:
- # 4 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_3_0:
- # 3 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_0:
- # 2 required-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_0:
- # 1 required-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_0_0:
- # keine Argumente
- noch_0_opt_args:
- if (args_on_stack>0) goto fehler_zuviel;
- if (!nullp(args))
- { if (consp(args))
- goto fehler_zuviel;
- else
- goto fehler_dotted;
- }
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_4_1:
- # 4 required-Argumente und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_3_1:
- # 3 required-Argumente und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_2_1:
- # 2 required-Argumente und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_1_1:
- # 1 required-Argument und 1 optional-Argument
- REQ_ARG();
- case (uintB)cclos_argtype_0_1:
- # 1 optional-Argument
- noch_1_opt_args:
- OPT_ARG(1);
- goto noch_0_opt_args;
- case (uintB)cclos_argtype_3_2:
- # 3 required-Argumente und 2 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_2:
- # 2 required-Argumente und 2 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_2:
- # 1 required-Argument und 2 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_2:
- # 2 optional-Argumente
- noch_2_opt_args:
- OPT_ARG(2);
- goto noch_1_opt_args;
- case (uintB)cclos_argtype_2_3:
- # 2 required-Argumente und 3 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_3:
- # 1 required-Argument und 3 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_3:
- # 3 optional-Argumente
- noch_3_opt_args:
- OPT_ARG(3);
- goto noch_2_opt_args;
- case (uintB)cclos_argtype_1_4:
- # 1 required-Argument und 4 optional-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_4:
- # 4 optional-Argumente
- noch_4_opt_args:
- OPT_ARG(4);
- goto noch_3_opt_args;
- case (uintB)cclos_argtype_0_5:
- # 5 optional-Argumente
- OPT_ARG(5);
- goto noch_4_opt_args;
- unbound_optional_5: # Noch 5 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_4: # Noch 4 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_3: # Noch 3 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- if (!nullp(args)) goto fehler_dotted;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_4_0_rest:
- # 4 required-Argumente, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_3_0_rest:
- # 3 required-Argumente, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_2_0_rest:
- # 2 required-Argumente, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_1_0_rest:
- # 1 required-Argument, Rest-Parameter
- REQ_ARG();
- case (uintB)cclos_argtype_0_0_rest:
- # keine Argumente, Rest-Parameter
- goto apply_cclosure_rest_nokey;
- case (uintB)cclos_argtype_4_0_key:
- # 4 required-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_3_0_key:
- # 3 required-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_0_key:
- # 2 required-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_0_key:
- # 1 required-Argument, Keyword-Argumente
- REQ_ARG();
- noch_0_opt_args_key:
- case (uintB)cclos_argtype_0_0_key:
- # nur Keyword-Argumente
- if ((args_on_stack==0) && atomp(args)) goto unbound_optional_key_0;
- goto apply_cclosure_key_withlist;
- case (uintB)cclos_argtype_3_1_key:
- # 3 required-Argumente und 1 optional-Argument, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_2_1_key:
- # 2 required-Argumente und 1 optional-Argument, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_1_key:
- # 1 required-Argument und 1 optional-Argument, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_1_key:
- # 1 optional-Argument, Keyword-Argumente
- noch_1_opt_args_key:
- OPT_ARG(key_1);
- goto noch_0_opt_args_key;
- case (uintB)cclos_argtype_2_2_key:
- # 2 required-Argumente und 2 optional-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_1_2_key:
- # 1 required-Argument und 2 optional-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_2_key:
- # 2 optional-Argumente, Keyword-Argumente
- noch_2_opt_args_key:
- OPT_ARG(key_2);
- goto noch_1_opt_args_key;
- case (uintB)cclos_argtype_1_3_key:
- # 1 required-Argument und 3 optional-Argumente, Keyword-Argumente
- REQ_ARG();
- case (uintB)cclos_argtype_0_3_key:
- # 3 optional-Argumente, Keyword-Argumente
- noch_3_opt_args_key:
- OPT_ARG(key_3);
- goto noch_2_opt_args_key;
- case (uintB)cclos_argtype_0_4_key:
- # 4 optional-Argumente, Keyword-Argumente
- OPT_ARG(key_4);
- goto noch_3_opt_args_key;
- unbound_optional_key_4: # Noch 4 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_3: # Noch 3 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0 und atomp(args)
- pushSTACK(unbound);
- unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0 und atomp(args)
- if (!nullp(args)) goto fehler_dotted;
- goto apply_cclosure_key_noargs;
- case (uintB)cclos_argtype_default:
- # Allgemeine Version
- break;
- default: NOTREACHED
- #undef OPT_ARG
- #undef REQ_ARG
- }
- # Nun die allgemeine Version:
- {var reg5 uintC req_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]); # Anzahl required Parameter
- var reg6 uintC opt_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+2]); # Anzahl optionale Parameter
- var reg7 uintB flags = TheSbvector(codevec)->data[CCHD+4]; # Flags
- if (args_on_stack < req_anz)
- # weniger Argumente da als verlangt
- { req_anz = req_anz - args_on_stack; # soviele müssen noch auf den STACK
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (uintL)(req_anz + opt_anz));
- # required Parameter in den Stack ablegen:
- { var reg1 uintC count;
- dotimespC(count,req_anz,
- { if (atomp(args)) { goto fehler_zuwenig; }
- pushSTACK(Car(args)); # nächstes Argument ablegen
- args = Cdr(args);
- });
- }
- goto optionals_from_list;
- }
- args_on_stack -= req_anz; # verbleibende Anzahl
- if (args_on_stack < opt_anz)
- # Argumente im Stack reichen nicht für die optionalen
- { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (uintL)opt_anz);
- optionals_from_list:
- # optionale Parameter in den Stack ablegen:
- { var reg1 uintC count = opt_anz;
- loop
- { if (atomp(args)) break; # Argumentliste zu Ende?
- if (count==0) goto optionals_ok; # alle optionalen Parameter versorgt?
- count--;
- pushSTACK(Car(args)); # nächstes Argument ablegen
- args = Cdr(args);
- }
- # Argumentliste beendet.
- if (!nullp(args)) goto fehler_dotted;
- # Alle weiteren count optionalen Parameter bekommen den "Wert"
- # #<UNBOUND>, der &REST-Parameter den Wert NIL,
- # die Keyword-Parameter den Wert #<UNBOUND> :
- dotimesC(count,count, { pushSTACK(unbound); } );
- if (flags & bit(0)) # &REST-Flag?
- { pushSTACK(NIL); } # ja -> mit NIL initialisieren
- if (flags & bit(7)) # &KEY-Flag?
- apply_cclosure_key_noargs:
- { var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
- get_space_on_STACK(sizeof(object) * (uintL)key_anz);
- {var reg1 uintC count;
- dotimesC(count,key_anz, { pushSTACK(unbound); } ); # mit #<UNBOUND> initialisieren
- }
- goto apply_cclosure_key;
- }
- else
- goto apply_cclosure_nokey;
- }
- optionals_ok:
- # Rest- und Keyword-Parameter behandeln.
- # args = restliche Argumentliste (noch nicht zu Ende)
- if (flags == 0)
- # Closure ohne REST oder KEY -> Argumentliste müßte zu Ende sein
- { goto fehler_zuviel; }
- # evtl. den Rest-Parameter füllen:
- if (flags & bit(0))
- { pushSTACK(args); }
- if (flags & bit(7)) # Key-Flag?
- # Closure mit Keywords.
- # args = restliche Argumentliste (noch nicht zu Ende)
- # Erst die Keyword-Parameter mit #<UNBOUND> vorbesetzen,
- # dann die restlichen Argumente im Stack ablegen,
- # dann die Keywords zuordnen:
- { key_args_pointer = args_end_pointer; # Pointer über Keyword-Parameter
- # alle Keyword-Parameter mit #<UNBOUND> vorbesetzen:
- { var reg1 uintC count = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]);
- dotimesC(count,count, { pushSTACK(unbound); } );
- }
- rest_args_pointer = args_end_pointer; # Pointer über die restlichen Argumente
- argcount = 0; # Zähler für die restlichen Argumente
- goto key_from_list;
- }
- else
- # Closure mit nur REST, ohne KEY:
- goto apply_cclosure_nokey;
- }
- args_on_stack -= opt_anz; # verbleibende Anzahl
- if (flags & bit(7)) # Key-Flag?
- { if (FALSE)
- apply_cclosure_key_withlist:
- { flags = TheSbvector(codevec)->data[CCHD+4]; } # Flags initialisieren!
- # Closure mit Keywords
- {var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
- # restliche Argumente im STACK nach unten schieben und dadurch
- # Platz für die Keyword-Parameter (und evtl. Rest-Parameter)
- # schaffen:
- var reg1 uintL shift = key_anz;
- if (flags & bit(0)) { shift++; } # evtl. 1 mehr für Rest-Parameter
- argcount = args_on_stack;
- get_space_on_STACK(sizeof(object) * shift);
- {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)shift;
- var reg1 object* ptr1 = args_end_pointer;
- var reg1 object* ptr2 = new_args_end_pointer;
- var reg1 uintC count;
- dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
- if (flags & bit(0)) { NEXT(ptr1) = unbound; } # Rest-Parameter
- key_args_pointer = ptr1;
- rest_args_pointer = ptr2;
- dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
- set_args_end_pointer(new_args_end_pointer);
- }
- key_from_list: # restliche Argumente für Keywords aus der Liste nehmen
- while (consp(args))
- { check_STACK(); pushSTACK(Car(args)); # nächstes Argument in den Stack
- args = Cdr(args);
- argcount++;
- }
- # Argumentliste beendet.
- if (!nullp(args)) goto fehler_dotted;
- # Keywords zuordnen, Rest-Parameter bauen
- # und evtl. restliche Argumente wegwerfen:
- closure = match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer);
- codevec = TheCclosure(closure)->clos_codevec;
- apply_cclosure_key:
- interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
- }}
- elif (flags & bit(0))
- apply_cclosure_rest_nokey:
- # Closure mit nur REST, ohne KEY:
- { # muß noch args_on_stack Argumente aus dem Stack auf args consen:
- pushSTACK(args);
- pushSTACK(closure); # Closure muß gerettet werden
- dotimesC(args_on_stack,args_on_stack,
- { var reg1 object new_cons = allocate_cons();
- Cdr(new_cons) = STACK_1;
- Car(new_cons) = STACK_2; # nächstes Argument draufconsen
- STACK_2 = new_cons;
- STACK_1 = STACK_0; skipSTACK(1);
- });
- closure = popSTACK(); codevec = TheCclosure(closure)->clos_codevec;
- goto apply_cclosure_nokey;
- }
- else
- # Closure ohne REST oder KEY
- { if ((args_on_stack>0) || consp(args)) # noch Argumente?
- goto fehler_zuviel;
- apply_cclosure_nokey: # Closure ohne &KEY anspringen:
- interpret_bytecode(closure,codevec,CCHD+6); # Bytecode ab Byte 6 abinterpretieren
- }
- }
- #if STACKCHECKC
- if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
- { abort(); } # nein -> ab in den Debugger
- #endif
- return; # fertig
- # Gesammelte Fehlermeldungen:
- fehler_zuwenig: fehler_closure_zuwenig(closure);
- fehler_zuviel: fehler_closure_zuviel(closure);
- fehler_dotted: fehler_apply_dotted(closure);
- }
- else
- # closure ist eine interpretierte Closure
- { # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * llength(args));
- while (consp(args)) # Noch Argumente in der Liste?
- { pushSTACK(Car(args)); # nächstes Element in den STACK
- args = Cdr(args);
- args_on_stack += 1;
- if (((uintL)~(uintL)0 > ca_limit_1) && (args_on_stack > ca_limit_1))
- goto fehler_zuviel;
- }
- funcall_iclosure(closure,args_end_pointer STACKop args_on_stack,args_on_stack);
- }
- }
-
-
- # ----------------------- F U N C A L L -----------------------
-
- # später:
- local Values funcall_subr (object fun, uintC args_on_stack);
- local Values funcall_closure (object fun, uintC args_on_stack);
-
- # UP: Wendet eine Funktion auf ihre Argumente an.
- # funcall(function,argcount);
- # > function: Funktion
- # > Argumente: argcount Argumente auf dem STACK
- # < STACK: aufgeräumt (d.h. STACK wird um argcount erhöht)
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- global Values funcall (object fun, uintC argcount);
- global Values funcall(fun,args_on_stack)
- var reg2 object fun;
- var reg3 uintC args_on_stack;
- { # fun muß ein SUBR oder eine Closure oder ein Cons (LAMBDA ...) sein:
- var reg1 tint type = typecode(fun); # Typinfo
- if (type == subr_type) # SUBR ?
- { return_Values funcall_subr(fun,args_on_stack); }
- elif (type == closure_type) # Closure ?
- { return_Values funcall_closure(fun,args_on_stack); }
- elif (symbolp(fun)) # Symbol ?
- # Symbol anwenden: globale Definition Symbol_function(fun) gilt.
- { type = mtypecode(Symbol_function(fun)); # Typinfo davon
- if (type == subr_type) # SUBR -> anwenden
- { return_Values funcall_subr(Symbol_function(fun),args_on_stack); }
- elif (type == closure_type) # Closure -> anwenden
- { return_Values funcall_closure(Symbol_function(fun),args_on_stack); }
- elif (type == orecord_type)
- {
- #ifdef DYNAMIC_FFI
- if (ffunctionp(Symbol_function(fun))) # Foreign-Function ?
- { fun = Symbol_function(fun); goto call_ffunction; }
- #endif
- # FSUBR -> Fehler
- pushSTACK(fun);
- # dpANS sagt: undefined_function ??
- //: DEUTSCH "FUNCALL: ~ ist eine Spezialform, keine Funktion."
- //: ENGLISH "FUNCALL: ~ is a special form, not a function"
- //: FRANCAIS "FUNCALL: ~ est une forme spéciale et non une fonction."
- fehler(error, GETTEXT("FUNCALL: ~ is a special form, not a function"));
- }
- elif (mconsp(Symbol_function(fun))) # Macro-Cons -> Fehler
- { pushSTACK(fun);
- # dpANS sagt: undefined_function ??
- //: DEUTSCH "FUNCALL: ~ ist ein Macro, keine Funktion."
- //: ENGLISH "FUNCALL: ~ is a macro, not a function"
- //: FRANCAIS "FUNCALL: ~ est un macro et non une fonction."
- fehler(error, GETTEXT("FUNCALL: ~ is a macro, not a function"));
- }
- else
- # wenn kein SUBR, keine Closure, kein FSUBR, kein Cons:
- # Symbol_function(fun) muß #<UNBOUND> sein.
- undef:
- { pushSTACK(fun); # Wert für Slot NAME von CELL-ERROR
- pushSTACK(fun);
- //: DEUTSCH "FUNCALL: Die Funktion ~ ist undefiniert."
- //: ENGLISH "FUNCALL: the function ~ is undefined"
- //: FRANCAIS "FUNCALL: La fonction ~ n'est pas définie."
- fehler(undefined_function, GETTEXT("FUNCALL: the function ~ is undefined"));
- }
- }
- elif (funnamep(fun)) # Liste (SETF symbol) ?
- # globale Definition (symbol-function (get-setf-symbol symbol)) gilt.
- { var reg5 object symbol = get(Car(Cdr(fun)),S(setf_function)); # (get ... 'SYS::SETF-FUNCTION)
- if (!symbolp(symbol)) # sollte (uninterniertes) Symbol sein
- goto undef; # sonst undefiniert
- type = mtypecode(Symbol_function(symbol)); # Typinfo davon
- if (type == closure_type) # Closure -> anwenden
- { return_Values funcall_closure(Symbol_function(symbol),args_on_stack); }
- elif (type == subr_type) # SUBR -> anwenden
- { return_Values funcall_subr(Symbol_function(symbol),args_on_stack); }
- else
- # Solche Funktionsnamen können keine FSUBRs oder Macros bezeichnen.
- # Symbol_function(symbol) wird vermutlich #<UNBOUND> sein.
- goto undef;
- }
- elif (consp(fun) && eq(Car(fun),S(lambda))) # Cons (LAMBDA ...) ?
- # Lambda-Ausdruck: zu einer Funktion mit leerem Environment machen
- { # leeres Environment bauen:
- {var reg5 environment* env5;
- make_STACK_env(NIL,NIL,NIL,NIL,O(top_decl_env), env5 = );
- fun = get_closure(Cdr(fun), # Lambdabody (lambda-list {decl|doc} . body)
- S(Klambda), # :LAMBDA als Name
- env5); # im leeren Environment
- skipSTACK(5); # Environment wieder vergessen
- # und neu erzeugte Closure anwenden:
- return_Values funcall_closure(fun,args_on_stack);
- }}
- #ifdef DYNAMIC_FFI
- elif (ffunctionp(fun)) # Foreign-Function ?
- # (SYS::FOREIGN-CALL-OUT foreign-function . args) aufrufen
- call_ffunction:
- { # Dazu erst die Argumente im Stack um 1 nach unten verschieben.
- var reg6 uintC count;
- var reg5 object* ptr = &STACK_0;
- dotimesC(count,args_on_stack,
- { *(ptr STACKop -1) = *ptr; ptr skipSTACKop 1; }
- );
- *(ptr STACKop -1) = fun;
- skipSTACK(-1);
- return_Values funcall_subr(L(foreign_call_out),args_on_stack+1);
- }
- #endif
- else
- { pushSTACK(fun);
- //: DEUTSCH "FUNCALL: ~ ist keine Funktionsbezeichnung."
- //: ENGLISH "FUNCALL: ~ is not a function name"
- //: FRANCAIS "FUNCALL: ~ n'est pas un nom de fonction."
- fehler(error, GETTEXT("FUNCALL: ~ is not a function name"));
- }
- }
-
- # In FUNCALL: Wendet ein SUBR auf Argumente an, räumt den STACK auf
- # und liefert die Werte.
- # funcall_subr(fun,args_on_stack);
- # > fun: Funktion, ein SUBR
- # > Argumente: args_on_stack Argumente auf dem STACK
- # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- local Values funcall_subr(fun,args_on_stack)
- var reg4 object fun;
- var reg3 uintC args_on_stack;
- {
- #if STACKCHECKS
- var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
- #endif
- var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
- var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
- var reg8 uintL argcount; # Anzahl der restlichen Argumente
- #ifdef DEBUG_EVAL
- if (sym_streamp(S(funcall_trace_output)))
- { pushSTACK(fun); trace_call(fun,'F','S'); fun = popSTACK(); }
- #endif
- # Argumente in den STACK legen:
- # erst ein Dispatch für die wichtigsten Fälle:
- switch (TheSubr(fun)->argtype)
- { case (uintW)subr_argtype_0_0:
- # SUBR ohne Argumente
- if (!(args_on_stack==0)) goto fehler_zuviel;
- goto apply_subr_norest;
- case (uintW)subr_argtype_1_0:
- # SUBR mit 1 required-Argument
- if (!(args_on_stack==1)) goto fehler_anzahl;
- goto apply_subr_norest;
- case (uintW)subr_argtype_2_0:
- # SUBR mit 2 required-Argumenten
- if (!(args_on_stack==2)) goto fehler_anzahl;
- goto apply_subr_norest;
- case (uintW)subr_argtype_3_0:
- # SUBR mit 3 required-Argumenten
- if (!(args_on_stack==3)) goto fehler_anzahl;
- goto apply_subr_norest;
- case (uintW)subr_argtype_4_0:
- # SUBR mit 4 required-Argumenten
- if (!(args_on_stack==4)) goto fehler_anzahl;
- goto apply_subr_norest;
- case (uintW)subr_argtype_5_0:
- # SUBR mit 5 required-Argumenten
- if (!(args_on_stack==5)) goto fehler_anzahl;
- goto apply_subr_norest;
- case (uintW)subr_argtype_6_0:
- # SUBR mit 6 required-Argumenten
- if (!(args_on_stack==6)) goto fehler_anzahl;
- goto apply_subr_norest;
- case (uintW)subr_argtype_0_1:
- # SUBR mit 1 optional-Argument
- if (args_on_stack==1) goto apply_subr_norest;
- elif (args_on_stack>1) goto fehler_zuviel;
- else { pushSTACK(unbound); goto apply_subr_norest; }
- case (uintW)subr_argtype_1_1:
- # SUBR mit 1 required-Argument und 1 optional-Argument
- if (args_on_stack==2) goto apply_subr_norest;
- elif (args_on_stack>2) goto fehler_zuviel;
- elif (args_on_stack==0) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_subr_norest; }
- case (uintW)subr_argtype_2_1:
- # SUBR mit 2 required-Argumenten und 1 optional-Argument
- if (args_on_stack==3) goto apply_subr_norest;
- elif (args_on_stack>3) goto fehler_zuviel;
- elif (args_on_stack<2) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_subr_norest; }
- case (uintW)subr_argtype_3_1:
- # SUBR mit 3 required-Argumenten und 1 optional-Argument
- if (args_on_stack==4) goto apply_subr_norest;
- elif (args_on_stack>4) goto fehler_zuviel;
- elif (args_on_stack<3) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_subr_norest; }
- case (uintW)subr_argtype_4_1:
- # SUBR mit 4 required-Argumenten und 1 optional-Argument
- if (args_on_stack==5) goto apply_subr_norest;
- elif (args_on_stack>5) goto fehler_zuviel;
- elif (args_on_stack<4) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_subr_norest; }
- case (uintW)subr_argtype_0_2:
- # SUBR mit 2 optional-Argumenten
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: goto apply_subr_norest;
- default: goto fehler_zuviel;
- }
- case (uintW)subr_argtype_1_2:
- # SUBR mit 1 required-Argument und 2 optional-Argumenten
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: goto apply_subr_norest;
- default: goto fehler_zuviel;
- }
- case (uintW)subr_argtype_2_2:
- # SUBR mit 2 required-Argumenten und 2 optional-Argumenten
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: goto fehler_zuwenig;
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: goto apply_subr_norest;
- default: goto fehler_zuviel;
- }
- case (uintW)subr_argtype_0_3:
- # SUBR mit 3 optional-Argumenten
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: goto apply_subr_norest;
- default: goto fehler_zuviel;
- }
- case (uintW)subr_argtype_0_4:
- # SUBR mit 4 optional-Argumenten
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: goto apply_subr_norest;
- default: goto fehler_zuviel;
- }
- case (uintW)subr_argtype_0_5:
- # SUBR mit 5 optional-Argumenten
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: pushSTACK(unbound);
- case 5: goto apply_subr_norest;
- default: goto fehler_zuviel;
- }
- case (uintW)subr_argtype_0_0_rest:
- # SUBR mit weiteren Argumenten
- goto apply_subr_rest_ok;
- case (uintW)subr_argtype_1_0_rest:
- # SUBR mit 1 required-Argument und weiteren Argumenten
- if (args_on_stack==0) goto fehler_zuwenig;
- args_on_stack -= 1;
- goto apply_subr_rest_ok;
- case (uintW)subr_argtype_2_0_rest:
- # SUBR mit 2 required-Argumenten und weiteren Argumenten
- if (args_on_stack<2) goto fehler_zuwenig;
- args_on_stack -= 2;
- goto apply_subr_rest_ok;
- case (uintW)subr_argtype_3_0_rest:
- # SUBR mit 3 required-Argumenten und weiteren Argumenten
- if (args_on_stack<3) goto fehler_zuwenig;
- args_on_stack -= 3;
- goto apply_subr_rest_ok;
- case (uintW)subr_argtype_0_0_key:
- # SUBR mit Keyword-Argumenten
- if (args_on_stack==0) goto unbound_optional_key_0;
- else goto apply_subr_key;
- case (uintW)subr_argtype_1_0_key:
- # SUBR mit 1 required-Argument und Keyword-Argumenten
- if (args_on_stack==1) goto unbound_optional_key_0;
- elif (args_on_stack<1) goto fehler_zuwenig;
- else { args_on_stack -= 1; goto apply_subr_key; }
- case (uintW)subr_argtype_2_0_key:
- # SUBR mit 2 required-Argumenten und Keyword-Argumenten
- if (args_on_stack==2) goto unbound_optional_key_0;
- elif (args_on_stack<2) goto fehler_zuwenig;
- else { args_on_stack -= 2; goto apply_subr_key; }
- case (uintW)subr_argtype_3_0_key:
- # SUBR mit 3 required-Argumenten und Keyword-Argumenten
- if (args_on_stack==3) goto unbound_optional_key_0;
- elif (args_on_stack<3) goto fehler_zuwenig;
- else { args_on_stack -= 3; goto apply_subr_key; }
- case (uintW)subr_argtype_4_0_key:
- # SUBR mit 4 required-Argumenten und Keyword-Argumenten
- if (args_on_stack==4) goto unbound_optional_key_0;
- elif (args_on_stack<4) goto fehler_zuwenig;
- else { args_on_stack -= 4; goto apply_subr_key; }
- case (uintW)subr_argtype_0_1_key:
- # SUBR mit 1 optional-Argument und Keyword-Argumenten
- switch (args_on_stack)
- { case 0: goto unbound_optional_key_1;
- case 1: goto unbound_optional_key_0;
- default: args_on_stack -= 1; goto apply_subr_key;
- }
- case (uintW)subr_argtype_1_1_key:
- # SUBR mit 1 required-Argument, 1 optional-Argument und Keyword-Argumenten
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: goto unbound_optional_key_1;
- case 2: goto unbound_optional_key_0;
- default: args_on_stack -= 2; goto apply_subr_key;
- }
- case (uintW)subr_argtype_1_2_key:
- # SUBR mit 1 required-Argument, 2 optional-Argumenten und Keyword-Argumenten
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: goto unbound_optional_key_2;
- case 2: goto unbound_optional_key_1;
- case 3: goto unbound_optional_key_0;
- default: args_on_stack -= 3; goto apply_subr_key;
- }
- unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0
- pushSTACK(unbound);
- unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0
- pushSTACK(unbound);
- unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0
- { var reg1 uintC count;
- dotimesC(count,TheSubr(fun)->key_anz, { pushSTACK(unbound); } );
- }
- goto apply_subr_norest;
- default: NOTREACHED
- #undef OPT_ARG
- #undef REQ_ARG
- }
- # Nun die allgemeine Version:
- {var reg5 uintC req_anz = TheSubr(fun)->req_anz;
- var reg6 uintC opt_anz = TheSubr(fun)->opt_anz;
- var reg7 uintC key_anz = TheSubr(fun)->key_anz;
- if (args_on_stack < req_anz)
- # weniger Argumente da als verlangt
- goto fehler_zuwenig;
- args_on_stack -= req_anz; # verbleibende Anzahl
- if (args_on_stack <= opt_anz)
- # Argumente im Stack reichen nicht für die optionalen
- { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (uintL)(opt_anz + key_anz));
- # Alle weiteren count optionalen Parameter bekommen den "Wert"
- # #<UNBOUND>, auch die Keyword-Parameter:
- { var reg1 uintC count;
- dotimesC(count,opt_anz + key_anz, { pushSTACK(unbound); } );
- if (TheSubr(fun)->rest_flag == subr_rest) # &REST-Flag?
- # ja -> 0 zusätzliche Argumente:
- { argcount = 0; rest_args_pointer = args_end_pointer;
- goto apply_subr_rest;
- }
- else
- # nein -> nichts zu tun
- { goto apply_subr_norest; }
- } }
- args_on_stack -= opt_anz; # verbleibende Anzahl (> 0)
- if (TheSubr(fun)->key_flag == subr_nokey)
- # SUBR ohne KEY
- { if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne REST oder KEY
- { goto fehler_zuviel; } # noch Argumente!
- else
- # SUBR mit nur REST, ohne KEY
- apply_subr_rest_ok:
- { argcount = args_on_stack;
- rest_args_pointer = args_end_pointer STACKop argcount;
- goto apply_subr_rest;
- }
- }
- else
- # SUBR mit Keywords.
- { if (FALSE)
- apply_subr_key: { key_anz = TheSubr(fun)->key_anz; }
- # restliche Argumente im STACK nach unten schieben und dadurch
- # Platz für die Keyword-Parameter schaffen:
- argcount = args_on_stack; # (> 0)
- get_space_on_STACK(sizeof(object) * (uintL)key_anz);
- {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)key_anz;
- var reg1 object* ptr1 = args_end_pointer;
- var reg1 object* ptr2 = new_args_end_pointer;
- var reg1 uintC count;
- dotimespC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
- key_args_pointer = ptr1;
- rest_args_pointer = ptr2;
- dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
- set_args_end_pointer(new_args_end_pointer);
- }
- # Keywords zuordnen und evtl. restliche Argumente wegwerfen:
- match_subr_key(fun,argcount,key_args_pointer,rest_args_pointer);
- if (TheSubr(fun)->rest_flag == subr_norest)
- # SUBR ohne &REST-Flag:
- apply_subr_norest:
- { subr_self = fun;
- (*(subr_norest_function*)(TheSubr(fun)->function))();
- }
- else
- # SUBR mit &REST-Flag:
- apply_subr_rest:
- { subr_self = fun;
- (*(subr_rest_function*)(TheSubr(fun)->function))
- (argcount,rest_args_pointer);
- }
- } }
- #if STACKCHECKS
- if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
- { abort(); } # nein -> ab in den Debugger
- #endif
- return; # fertig
- # Gesammelte Fehlermeldungen:
- fehler_anzahl:
- if (args_on_stack < TheSubr(fun)->req_anz)
- { goto fehler_zuwenig; } # zu wenig Argumente
- else
- { goto fehler_zuviel; } # zu viele Argumente
- fehler_zuwenig: fehler_subr_zuwenig(fun);
- fehler_zuviel: fehler_subr_zuviel(fun);
- }
-
- # In FUNCALL: Wendet eine Closure auf Argumente an, räumt den STACK auf
- # und liefert die Werte.
- # funcall_closure(fun,args_on_stack);
- # > fun: Funktion, eine Closure
- # > Argumente: args_on_stack Argumente auf dem STACK
- # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- local Values funcall_closure(closure,args_on_stack)
- var reg5 object closure;
- var reg3 uintC args_on_stack;
- {
- #ifdef DEBUG_EVAL
- if (sym_streamp(S(funcall_trace_output)))
- { pushSTACK(closure); trace_call(closure,'F','C'); closure = popSTACK(); }
- #endif
- if (m_simple_bit_vector_p(TheClosure(closure)->clos_codevec))
- # closure ist eine compilierte Closure
- {
- #if STACKCHECKC
- var reg9 object* args_pointer = args_end_pointer STACKop args_on_stack; # Pointer über die Argumente
- #endif
- var reg4 object codevec = TheCclosure(closure)->clos_codevec; # Code-Vektor
- var reg9 object* key_args_pointer; # Pointer über die Keyword-Argumente
- var reg9 object* rest_args_pointer; # Pointer über die restlichen Argumente
- var reg8 uintL argcount; # Anzahl der restlichen Argumente
- check_SP(); check_STACK();
- # Argumente in den STACK legen:
- # erst ein Dispatch für die wichtigsten Fälle:
- switch (TheSbvector(codevec)->data[CCHD+5])
- { case (uintB)cclos_argtype_0_0:
- # keine Argumente
- if (!(args_on_stack==0)) goto fehler_zuviel;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_1_0:
- # 1 required-Argument
- if (!(args_on_stack==1)) goto fehler_anzahl;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_2_0:
- # 2 required-Argumente
- if (!(args_on_stack==2)) goto fehler_anzahl;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_3_0:
- # 3 required-Argumente
- if (!(args_on_stack==3)) goto fehler_anzahl;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_4_0:
- # 4 required-Argumente
- if (!(args_on_stack==4)) goto fehler_anzahl;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_5_0:
- # 5 required-Argumente
- if (!(args_on_stack==5)) goto fehler_anzahl;
- goto apply_cclosure_nokey;
- case (uintB)cclos_argtype_0_1:
- # 1 optional-Argument
- if (args_on_stack==1) goto apply_cclosure_nokey;
- elif (args_on_stack>1) goto fehler_zuviel;
- else { pushSTACK(unbound); goto apply_cclosure_nokey; }
- case (uintB)cclos_argtype_1_1:
- # 1 required-Argument und 1 optional-Argument
- if (args_on_stack==2) goto apply_cclosure_nokey;
- elif (args_on_stack>2) goto fehler_zuviel;
- elif (args_on_stack==0) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_cclosure_nokey; }
- case (uintB)cclos_argtype_2_1:
- # 2 required-Argumente und 1 optional-Argument
- if (args_on_stack==3) goto apply_cclosure_nokey;
- elif (args_on_stack>3) goto fehler_zuviel;
- elif (args_on_stack<2) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_cclosure_nokey; }
- case (uintB)cclos_argtype_3_1:
- # 3 required-Argumente und 1 optional-Argument
- if (args_on_stack==4) goto apply_cclosure_nokey;
- elif (args_on_stack>4) goto fehler_zuviel;
- elif (args_on_stack<3) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_cclosure_nokey; }
- case (uintB)cclos_argtype_4_1:
- # 4 required-Argumente und 1 optional-Argument
- if (args_on_stack==5) goto apply_cclosure_nokey;
- elif (args_on_stack>5) goto fehler_zuviel;
- elif (args_on_stack<4) goto fehler_zuwenig;
- else { pushSTACK(unbound); goto apply_cclosure_nokey; }
- case (uintB)cclos_argtype_0_2:
- # 2 optional-Argumente
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_1_2:
- # 1 required-Argument und 2 optional-Argumente
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_2_2:
- # 2 required-Argumente und 2 optional-Argumente
- switch (args_on_stack)
- { case 0: case 1: goto fehler_zuwenig;
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_3_2:
- # 3 required-Argumente und 2 optional-Argumente
- switch (args_on_stack)
- { case 0: case 1: case 2: goto fehler_zuwenig;
- case 3: pushSTACK(unbound);
- case 4: pushSTACK(unbound);
- case 5: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_0_3:
- # 3 optional-Argumente
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_1_3:
- # 1 required-Argument und 3 optional-Argumente
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_2_3:
- # 2 required-Argumente und 3 optional-Argumente
- switch (args_on_stack)
- { case 0: case 1: goto fehler_zuwenig;
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: pushSTACK(unbound);
- case 5: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_0_4:
- # 4 optional-Argumente
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_1_4:
- # 1 required-Argument und 4 optional-Argumente
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: pushSTACK(unbound);
- case 5: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_0_5:
- # 5 optional-Argumente
- switch (args_on_stack)
- { case 0: pushSTACK(unbound);
- case 1: pushSTACK(unbound);
- case 2: pushSTACK(unbound);
- case 3: pushSTACK(unbound);
- case 4: pushSTACK(unbound);
- case 5: goto apply_cclosure_nokey;
- default: goto fehler_zuviel;
- }
- case (uintB)cclos_argtype_0_0_rest:
- # keine Argumente, Rest-Parameter
- goto apply_cclosure_rest_nokey;
- case (uintB)cclos_argtype_1_0_rest:
- # 1 required-Argument, Rest-Parameter
- if (args_on_stack==0) goto fehler_zuwenig;
- args_on_stack -= 1;
- goto apply_cclosure_rest_nokey;
- case (uintB)cclos_argtype_2_0_rest:
- # 2 required-Argumente, Rest-Parameter
- if (args_on_stack<2) goto fehler_zuwenig;
- args_on_stack -= 2;
- goto apply_cclosure_rest_nokey;
- case (uintB)cclos_argtype_3_0_rest:
- # 3 required-Argumente, Rest-Parameter
- if (args_on_stack<3) goto fehler_zuwenig;
- args_on_stack -= 3;
- goto apply_cclosure_rest_nokey;
- case (uintB)cclos_argtype_4_0_rest:
- # 4 required-Argumente, Rest-Parameter
- if (args_on_stack<4) goto fehler_zuwenig;
- args_on_stack -= 4;
- goto apply_cclosure_rest_nokey;
- case (uintB)cclos_argtype_0_0_key:
- # nur Keyword-Argumente
- if (args_on_stack==0) goto unbound_optional_key_0;
- else goto apply_cclosure_key_withargs;
- case (uintB)cclos_argtype_1_0_key:
- # 1 required-Argument, Keyword-Argumente
- if (args_on_stack==1) goto unbound_optional_key_0;
- elif (args_on_stack<1) goto fehler_zuwenig;
- else { args_on_stack -= 1; goto apply_cclosure_key_withargs; }
- case (uintB)cclos_argtype_2_0_key:
- # 2 required-Argumente, Keyword-Argumente
- if (args_on_stack==2) goto unbound_optional_key_0;
- elif (args_on_stack<2) goto fehler_zuwenig;
- else { args_on_stack -= 2; goto apply_cclosure_key_withargs; }
- case (uintB)cclos_argtype_3_0_key:
- # 3 required-Argumente, Keyword-Argumente
- if (args_on_stack==3) goto unbound_optional_key_0;
- elif (args_on_stack<3) goto fehler_zuwenig;
- else { args_on_stack -= 3; goto apply_cclosure_key_withargs; }
- case (uintB)cclos_argtype_4_0_key:
- # 4 required-Argumente, Keyword-Argumente
- if (args_on_stack==4) goto unbound_optional_key_0;
- elif (args_on_stack<4) goto fehler_zuwenig;
- else { args_on_stack -= 4; goto apply_cclosure_key_withargs; }
- case (uintB)cclos_argtype_0_1_key:
- # 1 optional-Argument, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto unbound_optional_key_1;
- case 1: goto unbound_optional_key_0;
- default: args_on_stack -= 1; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_1_1_key:
- # 1 required-Argument und 1 optional-Argument, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: goto unbound_optional_key_1;
- case 2: goto unbound_optional_key_0;
- default: args_on_stack -= 2; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_2_1_key:
- # 2 required-Argumente und 1 optional-Argument, Keyword-Argumente
- switch (args_on_stack)
- { case 0: case 1: goto fehler_zuwenig;
- case 2: goto unbound_optional_key_1;
- case 3: goto unbound_optional_key_0;
- default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_3_1_key:
- # 3 required-Argumente und 1 optional-Argument, Keyword-Argumente
- switch (args_on_stack)
- { case 0: case 1: case 2: goto fehler_zuwenig;
- case 3: goto unbound_optional_key_1;
- case 4: goto unbound_optional_key_0;
- default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_0_2_key:
- # 2 optional-Argumente, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto unbound_optional_key_2;
- case 1: goto unbound_optional_key_1;
- case 2: goto unbound_optional_key_0;
- default: args_on_stack -= 2; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_1_2_key:
- # 1 required-Argument und 2 optional-Argumente, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: goto unbound_optional_key_2;
- case 2: goto unbound_optional_key_1;
- case 3: goto unbound_optional_key_0;
- default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_2_2_key:
- # 2 required-Argumente und 2 optional-Argumente, Keyword-Argumente
- switch (args_on_stack)
- { case 0: case 1: goto fehler_zuwenig;
- case 2: goto unbound_optional_key_2;
- case 3: goto unbound_optional_key_1;
- case 4: goto unbound_optional_key_0;
- default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_0_3_key:
- # 3 optional-Argumente, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto unbound_optional_key_3;
- case 1: goto unbound_optional_key_2;
- case 2: goto unbound_optional_key_1;
- case 3: goto unbound_optional_key_0;
- default: args_on_stack -= 3; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_1_3_key:
- # 1 required-Argument und 3 optional-Argumente, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto fehler_zuwenig;
- case 1: goto unbound_optional_key_3;
- case 2: goto unbound_optional_key_2;
- case 3: goto unbound_optional_key_1;
- case 4: goto unbound_optional_key_0;
- default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
- }
- case (uintB)cclos_argtype_0_4_key:
- # 4 optional-Argumente, Keyword-Argumente
- switch (args_on_stack)
- { case 0: goto unbound_optional_key_4;
- case 1: goto unbound_optional_key_3;
- case 2: goto unbound_optional_key_2;
- case 3: goto unbound_optional_key_1;
- case 4: goto unbound_optional_key_0;
- default: args_on_stack -= 4; goto apply_cclosure_key_withargs;
- }
- unbound_optional_key_4: # Noch 4 optionale Argumente, aber args_on_stack=0
- pushSTACK(unbound);
- unbound_optional_key_3: # Noch 3 optionale Argumente, aber args_on_stack=0
- pushSTACK(unbound);
- unbound_optional_key_2: # Noch 2 optionale Argumente, aber args_on_stack=0
- pushSTACK(unbound);
- unbound_optional_key_1: # Noch 1 optionales Argument, aber args_on_stack=0
- pushSTACK(unbound);
- unbound_optional_key_0: # Vor den Keywords ist args_on_stack=0
- goto apply_cclosure_key_noargs;
- case (uintB)cclos_argtype_default:
- # Allgemeine Version
- break;
- default: NOTREACHED
- }
- # Nun die allgemeine Version:
- {var reg5 uintC req_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]); # Anzahl required Parameter
- var reg6 uintC opt_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+2]); # Anzahl optionale Parameter
- var reg7 uintB flags = TheSbvector(codevec)->data[CCHD+4]; # Flags
- if (args_on_stack < req_anz)
- # weniger Argumente da als verlangt
- { goto fehler_zuwenig; }
- args_on_stack -= req_anz; # verbleibende Anzahl
- if (args_on_stack <= opt_anz)
- # Argumente im Stack reichen nicht für die optionalen
- { opt_anz = opt_anz - args_on_stack; # soviele müssen noch auf den STACK
- # Platz auf dem STACK reservieren:
- get_space_on_STACK(sizeof(object) * (uintL)opt_anz);
- # Alle weiteren count optionalen Parameter bekommen den "Wert"
- # #<UNBOUND>, der &REST-Parameter den Wert NIL,
- # die Keyword-Parameter den Wert #<UNBOUND> :
- { var reg1 uintC count;
- dotimesC(count,opt_anz, { pushSTACK(unbound); } );
- }
- if (flags & bit(0)) # &REST-Flag?
- { pushSTACK(NIL); } # ja -> mit NIL initialisieren
- if (flags & bit(7)) # &KEY-Flag?
- apply_cclosure_key_noargs:
- { var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
- get_space_on_STACK(sizeof(object) * (uintL)key_anz);
- {var reg1 uintC count;
- dotimesC(count,key_anz, { pushSTACK(unbound); } ); # mit #<UNBOUND> initialisieren
- }
- goto apply_cclosure_key;
- }
- else
- goto apply_cclosure_nokey;
- }
- args_on_stack -= opt_anz; # verbleibende Anzahl
- if (flags & bit(7)) # Key-Flag?
- { if (FALSE)
- apply_cclosure_key_withargs:
- { flags = TheSbvector(codevec)->data[CCHD+4]; } # Flags initialisieren!
- # Closure mit Keywords
- {var reg1 uintC key_anz = *(uintW*)(&TheSbvector(codevec)->data[CCHD+6]); # Anzahl Keyword-Parameter
- # restliche Argumente im STACK nach unten schieben und dadurch
- # Platz für die Keyword-Parameter (und evtl. Rest-Parameter)
- # schaffen:
- var reg1 uintL shift = key_anz;
- if (flags & bit(0)) { shift++; } # evtl. 1 mehr für Rest-Parameter
- argcount = args_on_stack;
- get_space_on_STACK(sizeof(object) * shift);
- {var reg9 object* new_args_end_pointer = args_end_pointer STACKop -(uintP)shift;
- var reg1 object* ptr1 = args_end_pointer;
- var reg1 object* ptr2 = new_args_end_pointer;
- var reg1 uintC count;
- dotimesC(count,args_on_stack, { BEFORE(ptr2) = BEFORE(ptr1); } );
- if (flags & bit(0)) { NEXT(ptr1) = unbound; } # Rest-Parameter
- key_args_pointer = ptr1;
- rest_args_pointer = ptr2;
- dotimesC(count,key_anz, { NEXT(ptr1) = unbound; } );
- set_args_end_pointer(new_args_end_pointer);
- }
- # Keywords zuordnen, Rest-Parameter bauen
- # und evtl. restliche Argumente wegwerfen:
- closure = match_cclosure_key(closure,argcount,key_args_pointer,rest_args_pointer);
- codevec = TheCclosure(closure)->clos_codevec;
- apply_cclosure_key:
- interpret_bytecode(closure,codevec,CCHD+10); # Bytecode ab Byte 10 abinterpretieren
- }}
- elif (flags & bit(0))
- apply_cclosure_rest_nokey:
- # Closure mit nur REST, ohne KEY:
- { # muß noch args_on_stack Argumente aus dem Stack zusammenconsen:
- pushSTACK(NIL);
- pushSTACK(closure); # Closure muß gerettet werden
- dotimesC(args_on_stack,args_on_stack,
- { var reg1 object new_cons = allocate_cons();
- Cdr(new_cons) = STACK_1;
- Car(new_cons) = STACK_2; # nächstes Argument draufconsen
- STACK_2 = new_cons;
- STACK_1 = STACK_0; skipSTACK(1);
- });
- closure = popSTACK(); codevec = TheCclosure(closure)->clos_codevec;
- goto apply_cclosure_nokey;
- }
- else
- # Closure ohne REST oder KEY
- { if (args_on_stack>0) # noch Argumente?
- goto fehler_zuviel;
- apply_cclosure_nokey: # Closure ohne &KEY anspringen:
- interpret_bytecode(closure,codevec,CCHD+6); # Bytecode ab Byte 6 abinterpretieren
- }
- }
- #if STACKCHECKC
- if (!(args_pointer == args_end_pointer)) # Stack aufgeräumt?
- { abort(); } # nein -> ab in den Debugger
- #endif
- return; # fertig
- # Gesammelte Fehlermeldungen:
- fehler_anzahl:
- if (args_on_stack < *(uintW*)(&TheSbvector(codevec)->data[CCHD+0]))
- { goto fehler_zuwenig; } # zu wenig Argumente
- else
- { goto fehler_zuviel; } # zu viele Argumente
- fehler_zuwenig: fehler_closure_zuwenig(closure);
- fehler_zuviel: fehler_closure_zuviel(closure);
- }
- else
- # closure ist eine interpretierte Closure
- { funcall_iclosure(closure,args_end_pointer STACKop args_on_stack,args_on_stack); }
- }
-
-
- # ---------------------- BYTECODE-INTERPRETER ----------------------
-
- # Interpretiert den Bytecode einer compilierten Closure.
- # interpret_bytecode_(closure,codeptr,byteptr);
- # > closure: compilierte Closure
- # > codeptr: ihr Codevektor, ein Simple-Bit-Vector, pointable
- # > byteptr: Start-Bytecodepointer
- # < mv_count/mv_space: Werte
- # verändert STACK, kann GC auslösen
- # Syntax lokaler Labels in GNU-C Assembler-Anweisungen:
- #if defined(GNU) && !defined(NO_ASM)
- # LD(x) definiert Label mit Nummer x
- # LR(x,f) referenziert Label mit Nummer x vorwärts
- # LR(x,b) referenziert Label mit Nummer x rückwärts
- # Der Sichtbarkeitsbereich der Labels ist nur die eine Assembler-Anweisung.
- #if defined(I80Z86) && !defined(UNIX_NEXTSTEP)
- #define LD(nr) CONCAT("LASM%=X",STRING(nr))
- #define LR(nr,fb) CONCAT("LASM%=X",STRING(nr))
- #else
- #define LD(nr) STRING(nr)
- #define LR(nr,fb) CONCAT(STRING(nr),STRING(fb))
- #endif
- #endif
- # Den GNU-C dazu überreden, closure und byteptr in Registern zu halten:
- #ifdef GNU
- #ifdef MC680X0
- #define closure_register "a2"
- #define byteptr_register "a3"
- #endif
- #ifdef SPARC
- #define closure_register "%l0"
- #define byteptr_register "%l1"
- #endif
- #ifdef I80Z86
- #if (__GNUC__ >= 2) # Die Namen der Register haben sich verändert
- #define byteptr_register "%edi"
- #else
- #define byteptr_register "di"
- #endif
- #endif
- #ifdef CONVEX
- #define closure_register "a5"
- #define byteptr_register "a4"
- #endif
- #ifdef DECALPHA
- #define byteptr_register "$14"
- #endif
- #ifdef WIDE_SOFT
- # Ein `object' paßt nicht in ein einzelnes Register, GCC ist überfordert.
- #undef closure_register
- #endif
- #endif
- #ifndef closure_register
- #define closure_in closure
- #endif
- #ifndef byteptr_register
- #define byteptr_in byteptr
- #endif
- local Values interpret_bytecode_(closure_in,codeptr,byteptr_in)
- var reg3 object closure_in;
- var reg8 Sbvector codeptr;
- var reg1 uintB* byteptr_in;
- { # Argument closure im Register unterbringen:
- #ifdef closure_register
- var reg3 object closure __asm__(closure_register);
- closure = closure_in;
- #endif
- {# Argument byteptr im Register unterbringen:
- #ifdef byteptr_register
- var reg1 uintB* byteptr __asm__(byteptr_register);
- byteptr = byteptr_in;
- #endif
- #ifdef DEBUG_EVAL
- if (sym_streamp(S(funcall_trace_output)))
- { pushSTACK(closure); trace_call(closure,'B','C'); closure = popSTACK(); }
- #endif
- {# Closure im STACK unterbringen, unter die Argumente:
- var reg5 object* closureptr = (pushSTACK(closure), &STACK_0);
- #ifndef FAST_SP
- # Hat man keinen schnellen SP-Zugriff, muß man einen extra Pointer
- # einführen:
- var reg10 uintL private_SP_length = (uintL)(*(uintW*)(&codeptr->data[0]));
- var DYNAMIC_ARRAY(_EMA_,private_SP_space,SPint,private_SP_length);
- var reg6 SPint* private_SP = &private_SP_space[private_SP_length];
- #undef SP_
- #undef _SP_
- #undef skipSP
- #undef pushSP
- #undef popSP
- #define SP_(n) (private_SP[n])
- #define _SP_(n) &SP_(n)
- #define skipSP(n) (private_SP += (n))
- #define pushSP(item) (*--private_SP = (item))
- #define popSP(item_zuweisung) (item_zuweisung *private_SP++)
- #endif
- # var JMPBUF_on_SP(name); alloziert einen jmp_buf im SP.
- # FREE_JMPBUF_on_SP(); dealloziert ihn wieder.
- # finish_entry_frame_1(frametype,returner,reentry_statement); ist wie
- # finish_entry_frame(frametype,returner,_EMA_,reentry_statement); nur daß
- # auch private_SP gerettet wird.
- #ifndef FAST_SP
- #define JMPBUF_on_SP(name) \
- jmp_buf* name = (jmp_buf*)(private_SP -= jmpbufsize);
- #define FREE_JMPBUF_on_SP() \
- private_SP += jmpbufsize;
- #define finish_entry_frame_1(frametype,returner,reentry_statement) \
- finish_entry_frame(frametype,&!*returner, # Beim Eintritt: returner = private_SP \
- returner = (jmp_buf*) , # returner wird beim Rücksprung wieder gesetzt \
- { private_SP = (SPint*)returner; reentry_statement } # und private_SP rekonstruiert \
- )
- #else
- #ifdef SP_DOWN
- #define JMPBUF_on_SP(name) \
- jmp_buf* name; \
- {var reg1 SPint* sp = (SPint*)SP(); \
- sp -= jmpbufsize; \
- setSP(sp); \
- name = (jmp_buf*)&sp[SPoffset]; \
- }
- #endif
- #ifdef SP_UP
- #define JMPBUF_on_SP(name) \
- jmp_buf* name; \
- {var reg1 SPint* sp = (SPint*)SP(); \
- name = (jmp_buf*)&sp[SPoffset+1]; \
- sp += jmpbufsize; \
- setSP(sp); \
- }
- #endif
- #define FREE_JMPBUF_on_SP() \
- skipSP(jmpbufsize);
- #define finish_entry_frame_1(frametype,returner,reentry_statement) \
- finish_entry_frame(frametype,&!*returner,_EMA_,reentry_statement)
- #endif
- #
- #ifdef FAST_DISPATCH
- static void* cod_labels[] = {
- #define BYTECODE(code) &&code,
- #include "bytecode.c"
- #undef BYTECODE
- };
- #endif
- #
- # nächstes Byte abzuinterpretieren
- # > mv_count/mv_space: aktuelle Werte
- # > closureptr: Pointer auf die compilierte Closure im Stack
- # > closure: compilierte Closure
- # > codeptr: ihr Codevektor, ein Simple-Bit-Vektor, pointable
- # (kein LISP-Objekt, aber dennoch GC-gefährdet!)
- # > byteptr: Pointer auf das nächste Byte im Code
- # (kein LISP-Objekt, aber dennoch GC-gefährdet!)
- next_byte:
- # Fallunterscheidung nach abzuinterpretierendem Byte
- #ifndef FAST_DISPATCH
- switch (*byteptr++)
- #define CASE case (uintB)
- #else # FAST_DISPATCH
- # Das ist etwa 2% schneller, weil die Index-Überprüfung entfällt.
- goto *cod_labels[*byteptr++];
- #define CASE
- #ifdef FAST_DISPATCH_THREADED
- # Die Sprunganweisung goto next_byte; kann man sich auch sparen:
- #define next_byte *cod_labels[*byteptr++]
- #endif
- #endif
- { # Holen der Operanden:
- # nächstes Byte:
- # Bit 7 = 0 --> Bits 6..0 sind der Operand (7 Bits).
- # Bit 7 = 1 --> Bits 6..0 und nächstes Byte bilden den
- # Operanden (15 Bits).
- # Bei Sprungdistanzen: Sollte dieser =0 sein, so
- # bilden die nächsten 4 Bytes den Operanden
- # (32 Bits).
- #
- # Macro B_operand(where);
- # bringt den nächsten Operanden (ein Byte als Unsigned Integer)
- # nach (uintL)where und rückt dabei den Bytecodepointer weiter.
- #define B_operand(where) \
- { where = *byteptr++; }
- #
- # Macro U_operand(where);
- # bringt den nächsten Operanden (ein Unsigned Integer)
- # nach (uintL)where oder (uintC)where
- # und rückt dabei den Bytecodepointer weiter.
- #define U_operand(where) \
- { where = *byteptr++; # erstes Byte lesen \
- if ((uintB)where & bit(7)) # Bit 7 gesetzt? \
- { where &= ~bit(7); # ja -> löschen \
- where = where << 8; \
- where |= *byteptr++; # und nächstes Byte lesen \
- } }
- #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
- #undef U_operand
- #define U_operand(where) \
- __asm__("\
- moveq #0,%0 ; \
- moveb %1@+,%0 ; \
- bpl 1f ; \
- addb %0,%0 ; \
- lslw #7,%0 ; \
- moveb %1@+,%0 ; \
- 1: \
- " : "=d" (where), "=a" (byteptr) : "1" (byteptr) )
- #endif
- #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
- #undef U_operand
- #define U_operand(where) \
- { var reg1 uintL dummy; \
- __asm__("\
- ldub [%1],%0 ; \
- andcc %0,0x80,%%g0 ; \
- be 1f ; \
- add %1,1,%1 ; \
- sll %0,25,%2 ; \
- ldub [%1],%0 ; \
- srl %2,17,%2 ; \
- add %1,1,%1 ; \
- or %0,%2,%0 ; \
- 1: \
- " : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
- }
- #endif
- #if defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
- # Bei manchen Assemblern muß das Ergebnis in %eax liegen:
- #if !defined(SUN386) && !defined(UHC) && !defined(UNIX_SINIX)
- # GNU-Assembler: in beliebigem Register.
- # "testb %edx,%edx" wird als "testb %dl,%dl" assembliert.
- #define OUT_EAX "=q"
- #define EAX "%0"
- #define AL "%0"
- #else
- # sonstiger Assembler: in %eax. "testb %edx,%edx" ist illegal.
- #define OUT_EAX "=a"
- #define EAX "%%eax"
- #define AL "%%al"
- #endif
- #undef U_operand
- #define U_operand(where) \
- __asm__("\
- movzbl (%1),"EAX" ; \
- incl %1 ; \
- testb "AL","AL" ; \
- jge "LR(1,f)" ; \
- andb $127,"AL" ; \
- sall $8,"EAX" ; \
- movb (%1),"AL" ; \
- incl %1 ; \
- "LD(1)": \
- " : OUT_EAX (where), "=r" (byteptr) : "1" (byteptr) );
- # Vorsicht: 1. Der Sun-Assembler kennt diese Syntax für lokale Labels nicht.
- # Daher generieren wir unsere lokalen Labels selbst.
- # Vorsicht: 2. ccr wird verändert. Wie deklariert man das??
- #endif
- #
- # Macro S_operand(where);
- # bringt den nächsten Operanden (ein Signed Integer)
- # nach (uintL)where und rückt dabei den Bytecodepointer weiter.
- #define S_operand(where) \
- { where = *byteptr++; # erstes Byte lesen \
- if ((uintB)where & bit(7)) \
- # Bit 7 war gesetzt \
- { where = where << 8; \
- where |= *byteptr++; # nächstes Byte dazunehmen \
- # Sign-Extend von 15 auf 32 Bits: \
- where = (sintL)((sintL)(sintWL)((sintWL)where << (intWLsize-15)) >> (intWLsize-15)); \
- if (where == 0) \
- # Sonderfall: 2-Byte-Operand = 0 -> 6-Byte-Operand \
- { where = (uintL)( ((uintWL)(byteptr[0]) << 8) \
- | (uintWL)(byteptr[1]) \
- ) << 16 \
- | (uintL)( ((uintWL)(byteptr[2]) << 8) \
- | (uintWL)(byteptr[3]) \
- ); \
- byteptr += 4; \
- } } \
- else \
- # Bit 7 war gelöscht \
- { # Sign-Extend von 7 auf 32 Bits: \
- where = (sintL)((sintL)(sintBWL)((sintBWL)where << (intBWLsize-7)) >> (intBWLsize-7)); \
- } \
- }
- #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
- #undef S_operand
- #define S_operand(where) \
- __asm__("\
- moveb %1@+,%0 ; \
- bpl 1f ; \
- lslw #8,%0 ; \
- moveb %1@+,%0 ; \
- addw %0,%0 ; \
- asrw #1,%0 ; \
- bne 2f ; \
- moveb %1@(2),%0 ; \
- swap %0 ; \
- moveb %1@+,%0 ; \
- lsll #8,%0 ; \
- moveb %1@,%0 ; \
- swap %0 ; \
- addql #2,%0 ; \
- moveb %1@+,%0 ; \
- jra 3f ; \
- 1: \
- addb %0,%0 ; \
- asrb #1,%0 ; \
- extw %0 ; \
- 2: \
- extl %0 ; \
- 3: \
- " : "=d" (where), "=a" (byteptr) : "1" (byteptr) )
- #endif
- #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
- #undef S_operand
- #define S_operand(where) \
- { var reg1 uintL dummy; \
- __asm__("\
- ldub [%1],%0 ; \
- andcc %0,0x80,%%g0 ; \
- be 2f ; \
- add %1,1,%1 ; \
- sll %0,25,%2 ; \
- ldub [%1],%0 ; \
- sra %2,17,%2 ; \
- orcc %2,%0,%0 ; \
- bne 3f ; \
- add %1,1,%1 ; \
- ldub [%1],%0 ; \
- sll %0,24,%2 ; \
- ldub [%1+1],%0 ; \
- sll %0,16,%0 ; \
- or %2,%0,%2 ; \
- ldub [%1+2],%0 ; \
- sll %0,8,%0 ; \
- or %2,%0,%2 ; \
- ldub [%1+3],%0 ; \
- or %2,%0,%0 ; \
- b 3f ; \
- add %1,4,%1 ; \
- 2: \
- sll %0,25,%0 ; \
- sra %0,25,%0 ; \
- 3: \
- " : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
- }
- #endif
- #if defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
- #undef S_operand
- #define S_operand(where) \
- __asm__("\
- movzbl (%1),"EAX" ; \
- incl %1 ; \
- testb "AL","AL" ; \
- jge "LR(1,f)" ; \
- sall $8,"EAX" ; \
- movb (%1),"AL" ; \
- incl %1 ; \
- sall $17,"EAX" ; \
- sarl $17,"EAX" ; \
- jne "LR(2,f)" ; \
- movb (%1),"AL" ; \
- sall $8,"EAX" ; \
- movb 1(%1),"AL" ; \
- sall $8,"EAX" ; \
- movb 2(%1),"AL" ; \
- sall $8,"EAX" ; \
- movb 3(%1),"AL" ; \
- addl $4,"EAX" ; \
- jmp "LR(2,f)" ; \
- "LD(1)": \
- sall $25,"EAX" ; \
- sarl $25,"EAX" ; \
- "LD(2)": \
- " : OUT_EAX (where), "=r" (byteptr) : "1" (byteptr) );
- #endif
- #
- # Macro S_operand_ignore();
- # übergeht den nächsten Operanden (ein Signed Integer)
- # und rückt dabei den Bytecodepointer weiter.
- #define S_operand_ignore() \
- { var reg1 uintB where = *byteptr++; # erstes Byte lesen \
- if ((uintB)where & bit(7)) \
- # Bit 7 war gesetzt \
- { if ((uintB)((where<<1) | *byteptr++) == 0) # nächstes Byte dazu \
- # Sonderfall: 2-Byte-Operand = 0 -> 6-Byte-Operand \
- { byteptr += 4; } \
- } }
- #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
- #undef S_operand_ignore
- #define S_operand_ignore() \
- { var reg1 uintB where; \
- __asm__("\
- moveb %1@+,%0 ; \
- bpl 1f ; \
- addb %0,%0 ; \
- orb %1@+,%0 ; \
- bne 1f ; \
- addql #4,%1 ; \
- 1: \
- " : "=d" (where), "=a" (byteptr) : "1" (byteptr) ); \
- }
- #endif
- #if defined(GNU) && defined(SPARC) && !defined(NO_ASM)
- #undef S_operand_ignore
- #define S_operand_ignore() \
- { var reg1 uintL where; \
- var reg2 uintL dummy; \
- __asm__("\
- ldub [%1],%0 ; \
- andcc %0,0x80,%%g0 ; \
- be 1f ; \
- add %1,1,%1 ; \
- sll %0,1,%2 ; \
- ldub [%1],%0 ; \
- orcc %2,%0,%0 ; \
- bne 1f ; \
- add %1,1,%1 ; \
- add %1,4,%1 ; \
- 1: \
- " : "=r" (where), "=r" (byteptr), "=r" (dummy) : "1" (byteptr) : "ccr" ); \
- }
- #endif
- #
- # Macro L_operand(where);
- # bringt den nächsten Operanden (ein Label)
- # nach (uintB*)where und rückt dabei den Bytecodepointer weiter.
- #define L_operand(Lwhere) \
- { var reg1 uintL where; # Variable fürs Displacement \
- S_operand(where); # Displacement \
- Lwhere = byteptr + (sintL)where; # addieren \
- }
- #
- # Macro L_operand_ignore();
- # übergeht den nächsten Operanden (ein Label)
- # und rückt dabei den Bytecodepointer weiter.
- #define L_operand_ignore() S_operand_ignore()
- #
- # Die einzelnen Bytecodes werden interpretiert:
- # Dabei ist meist mv_count/mv_space = Werte,
- # closureptr = Pointer auf die compilierte Closure im Stack,
- # closure = compilierte Closure,
- # codeptr = Pointer auf ihren Codevektor,
- # byteptr = Pointer auf das nächste Byte im Code.
- # (byteptr ist kein LISP-Objekt, aber dennoch GC-gefährdet! Um es
- # GC-invariant zu machen, muß man CODEPTR
- # davon subtrahieren. Addiert man dann Fixnum_0 dazu,
- # so hat man die Bytenummer als Fixnum.)
- #if 0
- #define CODEPTR (&codeptr->data[0])
- #else # liefert effizienteren Code
- #define CODEPTR (uintB*)(codeptr)
- #endif
- #
- # Kontextinformation aufbewahren:
- # Wird etwas aufgerufen, das eine GC auslösen kann, so muß dies in ein
- # with_saved_context( ... ) eingebaut werden.
- #define with_saved_context(statement) \
- { var reg9 uintL index = byteptr - CODEPTR; \
- statement; \
- closure = *closureptr; # Closure aus dem Stack holen \
- codeptr = TheSbvector(TheCclosure(closure)->clos_codevec); \
- byteptr = CODEPTR + index; \
- }
- #
- # ------------------- (1) Konstanten -----------------------
- CASE cod_nil: # (NIL)
- code_nil:
- value1 = NIL; mv_count = 1;
- goto next_byte;
- CASE cod_nil_push: # (NIL&PUSH)
- pushSTACK(NIL);
- goto next_byte;
- CASE cod_push_nil: # (PUSH-NIL n)
- { var reg2 uintC n;
- U_operand(n);
- dotimesC(n,n, { pushSTACK(NIL); } );
- }
- goto next_byte;
- CASE cod_t: # (T)
- code_t:
- value1 = T; mv_count = 1;
- goto next_byte;
- CASE cod_t_push: # (T&PUSH)
- pushSTACK(T);
- goto next_byte;
- CASE cod_const: # (CONST n)
- { var reg2 uintL n;
- U_operand(n);
- value1 = TheCclosure(closure)->clos_consts[n]; mv_count=1;
- }
- goto next_byte;
- CASE cod_const_push: # (CONST&PUSH n)
- { var reg2 uintL n;
- U_operand(n);
- pushSTACK(TheCclosure(closure)->clos_consts[n]);
- }
- goto next_byte;
- # ------------------- (2) statische Variablen -----------------------
- CASE cod_load: # (LOAD n)
- { var reg2 uintL n;
- U_operand(n);
- value1 = STACK_(n); mv_count=1;
- }
- goto next_byte;
- CASE cod_load_push: # (LOAD&PUSH n)
- { var reg2 uintL n;
- U_operand(n);
- pushSTACK(STACK_(n));
- }
- goto next_byte;
- CASE cod_loadi: # (LOADI k n)
- { var reg4 uintL k;
- var reg4 uintL n;
- U_operand(k);
- U_operand(n);
- {var reg2 object* FRAME = (object*) SP_(k);
- value1 = FRAME_(n); mv_count=1;
- }}
- goto next_byte;
- CASE cod_loadi_push: # (LOADI&PUSH k n)
- { var reg4 uintL k;
- var reg4 uintL n;
- U_operand(k);
- U_operand(n);
- {var reg2 object* FRAME = (object*) SP_(k);
- pushSTACK(FRAME_(n));
- }}
- goto next_byte;
- CASE cod_loadc: # (LOADC n m)
- { var reg4 uintL n;
- var reg2 uintL m;
- U_operand(n);
- U_operand(m);
- value1 = TheSvector(STACK_(n))->data[1+m]; mv_count=1;
- }
- goto next_byte;
- CASE cod_loadc_push: # (LOADC&PUSH n m)
- { var reg4 uintL n;
- var reg2 uintL m;
- U_operand(n);
- U_operand(m);
- pushSTACK(TheSvector(STACK_(n))->data[1+m]);
- }
- goto next_byte;
- CASE cod_loadv: # (LOADV k m)
- { var reg4 uintC k;
- var reg7 uintL m;
- U_operand(k);
- U_operand(m);
- {var reg2 object venv = TheCclosure(closure)->clos_venv; # VenvConst
- # k mal (svref ... 0) nehmen:
- dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
- # (svref ... m) holen:
- value1 = TheSvector(venv)->data[m]; mv_count=1;
- }}
- goto next_byte;
- CASE cod_loadv_push: # (LOADV&PUSH k m)
- { var reg4 uintC k;
- var reg7 uintL m;
- U_operand(k);
- U_operand(m);
- {var reg2 object venv = TheCclosure(closure)->clos_venv; # VenvConst
- # k mal (svref ... 0) nehmen:
- dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
- # (svref ... m) holen:
- pushSTACK(TheSvector(venv)->data[m]);
- }}
- goto next_byte;
- CASE cod_loadic: # (LOADIC k n m)
- { var reg8 uintL k;
- var reg7 uintL n;
- var reg4 uintL m;
- U_operand(k);
- U_operand(n);
- U_operand(m);
- {var reg2 object* FRAME = (object*) SP_(k);
- value1 = TheSvector(FRAME_(n))->data[1+m]; mv_count=1;
- }}
- goto next_byte;
- CASE cod_store: store: # (STORE n)
- { var reg2 uintL n;
- U_operand(n);
- STACK_(n) = value1; mv_count=1;
- }
- goto next_byte;
- CASE cod_pop_store: # (POP&STORE n)
- { var reg2 uintL n;
- U_operand(n);
- {var reg4 object obj = popSTACK();
- STACK_(n) = value1 = obj; mv_count=1;
- }}
- goto next_byte;
- CASE cod_storei: # (STOREI k n)
- { var reg4 uintL k;
- var reg4 uintL n;
- U_operand(k);
- U_operand(n);
- {var reg2 object* FRAME = (object*) SP_(k);
- FRAME_(n) = value1; mv_count=1;
- }}
- goto next_byte;
- CASE cod_load_storec: # (LOAD&STOREC k m n)
- { var reg2 uintL k;
- U_operand(k);
- value1 = STACK_(k);
- }
- CASE cod_storec: # (STOREC n m)
- { var reg4 uintL n;
- var reg2 uintL m;
- U_operand(n);
- U_operand(m);
- TheSvector(STACK_(n))->data[1+m] = value1; mv_count=1;
- }
- goto next_byte;
- CASE cod_storev: # (STOREV k m)
- { var reg4 uintC k;
- var reg7 uintL m;
- U_operand(k);
- U_operand(m);
- {var reg2 object venv = TheCclosure(closure)->clos_venv; # VenvConst
- # k mal (svref ... 0) nehmen:
- dotimesC(k,k, { venv = TheSvector(venv)->data[0]; } );
- # (svref ... m) abspeichern:
- TheSvector(venv)->data[m] = value1; mv_count=1;
- }}
- goto next_byte;
- CASE cod_storeic: # (STOREIC k n m)
- { var reg8 uintL k;
- var reg7 uintL n;
- var reg4 uintL m;
- U_operand(k);
- U_operand(n);
- U_operand(m);
- {var reg2 object* FRAME = (object*) SP_(k);
- TheSvector(FRAME_(n))->data[1+m] = value1; mv_count=1;
- }}
- goto next_byte;
- # ------------------- (3) dynamische Variablen -----------------------
- CASE cod_getvalue: # (GETVALUE n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object symbol = TheCclosure(closure)->clos_consts[n];
- # Der Compiler hat schon überprüft, daß es ein Symbol ist.
- if (eq(Symbol_value(symbol),unbound))
- { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
- pushSTACK(symbol);
- //: DEUTSCH "Symbol ~ hat keinen Wert."
- //: ENGLISH "symbol ~ has no value"
- //: FRANCAIS "Le symbôle ~ n'a pas de valeur."
- fehler(unbound_variable, GETTEXT("symbol ~ has no value"));
- }
- value1 = Symbol_value(symbol); mv_count=1;
- }}
- goto next_byte;
- CASE cod_getvalue_push: # (GETVALUE&PUSH n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object symbol = TheCclosure(closure)->clos_consts[n];
- # Der Compiler hat schon überprüft, daß es ein Symbol ist.
- if (eq(Symbol_value(symbol),unbound))
- { pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
- pushSTACK(symbol);
- //: DEUTSCH "Symbol ~ hat keinen Wert."
- //: ENGLISH "symbol ~ has no value"
- //: FRANCAIS "Le symbôle ~ n'a pas de valeur."
- fehler(unbound_variable, GETTEXT("symbol ~ has no value"));
- }
- pushSTACK(Symbol_value(symbol));
- }}
- goto next_byte;
- CASE cod_setvalue: # (SETVALUE n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object symbol = TheCclosure(closure)->clos_consts[n];
- # Der Compiler hat schon überprüft, daß es ein Symbol ist.
- if (constantp(TheSymbol(symbol)))
- { pushSTACK(symbol);
- //: DEUTSCH "Zuweisung nicht möglich auf das konstante Symbol ~"
- //: ENGLISH "assignment to constant symbol ~ is impossible"
- //: FRANCAIS "Une assignation du symbôle constant ~ n'est pas possible."
- fehler(error, GETTEXT("assignment to constant symbol ~ is impossible"));
- }
- set_Symbol_value(symbol,value1); mv_count=1;
- }}
- goto next_byte;
- CASE cod_bind: # (BIND n)
- { var reg2 uintL n;
- U_operand(n);
- with_saved_context(
- dynamic_bind(TheCclosure(closure)->clos_consts[n],value1);
- );
- }
- goto next_byte;
- CASE cod_unbind1: # (UNBIND1)
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == DYNBIND_frame_info))
- goto fehler_STACK_putt;
- #endif
- # Variablenbindungsframe auflösen:
- { var reg7 object* new_STACK = topofframe(STACK_0); # Pointer übern Frame
- var reg4 object* frame_end = STACKpointable(new_STACK);
- var reg2 object* bindingptr = &STACK_1; # Beginn der Bindungen
- # bindingptr läuft durch die Bindungen hoch
- until (bindingptr == frame_end)
- { # alten Wert zurückschreiben:
- set_Symbol_symvalue(*(bindingptr STACKop 0),*(bindingptr STACKop 1));
- bindingptr skipSTACKop 2; # nächste Bindung
- }
- #ifdef DYNBIND_LIST
- delete_frame_from_binding_list(&STACK_0);
- #endif
- # STACK neu setzen, dadurch Frame auflösen:
- setSTACK(STACK = new_STACK);
- }
- goto next_byte;
- CASE cod_unbind: # (UNBIND n)
- { var reg8 uintC n;
- U_operand(n); # n>0
- {var reg2 object* FRAME = STACK;
- do {
- #if STACKCHECKC
- if (!(mtypecode(FRAME_(0)) == DYNBIND_frame_info))
- goto fehler_STACK_putt;
- #endif
- # Variablenbindungsframe auflösen:
- { var reg7 object* new_FRAME = topofframe(FRAME_(0)); # Pointer übern Frame
- var reg4 object* frame_end = STACKpointable(new_FRAME);
- var reg2 object* bindingptr = &FRAME_(1); # Beginn der Bindungen
- # bindingptr läuft durch die Bindungen hoch
- until (bindingptr == frame_end)
- { # alten Wert zurückschreiben:
- set_Symbol_symvalue(*(bindingptr STACKop 0),*(bindingptr STACKop 1));
- bindingptr skipSTACKop 2; # nächste Bindung
- }
- #ifdef DYNBIND_LIST
- delete_frame_from_binding_list(&STACK_0);
- #endif
- FRAME = new_FRAME;
- }}
- until (--n == 0);
- setSTACK(STACK = FRAME); # STACK neu setzen
- }}
- goto next_byte;
- CASE cod_progv: # (PROGV)
- { var reg2 object vallist = value1; # Wertliste
- var reg4 object symlist = popSTACK(); # Symbolliste
- pushSP((aint)STACK); # STACK in den SP legen
- with_saved_context(
- progv(symlist,vallist); # Frame aufbauen
- );
- }
- goto next_byte;
- # ------------------- (4) Stackoperationen -----------------------
- CASE cod_push: # (PUSH)
- pushSTACK(value1);
- goto next_byte;
- CASE cod_pop: # (POP)
- value1 = popSTACK(); mv_count=1;
- goto next_byte;
- CASE cod_skip: # (SKIP n)
- { var reg2 uintL n;
- U_operand(n);
- skipSTACK(n);
- }
- goto next_byte;
- CASE cod_skipi: # (SKIPI k n)
- { var reg2 uintL k;
- var reg4 uintL n;
- U_operand(k);
- U_operand(n);
- skipSP(k);
- {var reg2 object* newSTACK;
- popSP( newSTACK = (object*) );
- setSTACK(STACK = newSTACK STACKop n);
- }}
- goto next_byte;
- CASE cod_skipsp: # (SKIPSP k)
- { var reg2 uintL k;
- U_operand(k);
- skipSP(k);
- }
- goto next_byte;
- # ------------------- (5) Programmfluß und Sprünge -----------------------
- CASE cod_skip_ret: # (SKIP&RET n)
- { var reg2 uintL n;
- U_operand(n);
- skipSTACK(n);
- goto finished; # Rücksprung zum Aufrufer
- }
- #define JMP() \
- { var reg2 uintB* label_byteptr; \
- L_operand(label_byteptr); \
- byteptr = label_byteptr; \
- goto next_byte; \
- }
- #define NOTJMP() \
- { L_operand_ignore(); goto next_byte; }
- jmp1: mv_count=1;
- CASE cod_jmp: jmp: # (JMP label)
- JMP();
- CASE cod_jmpif: # (JMPIF label)
- if (!nullp(value1)) goto jmp;
- notjmp:
- NOTJMP();
- CASE cod_jmpifnot: # (JMPIFNOT label)
- if (nullp(value1)) goto jmp;
- NOTJMP();
- CASE cod_jmpif1: # (JMPIF1 label)
- if (!nullp(value1)) goto jmp1;
- NOTJMP();
- CASE cod_jmpifnot1: # (JMPIFNOT1 label)
- if (nullp(value1)) goto jmp1;
- NOTJMP();
- CASE cod_jmpifatom: # (JMPIFATOM label)
- if (atomp(value1)) goto jmp;
- NOTJMP();
- CASE cod_jmpifconsp: # (JMPIFCONSP label)
- if (consp(value1)) goto jmp;
- NOTJMP();
- CASE cod_jmpifeq: # (JMPIFEQ label)
- if (eq(popSTACK(),value1)) goto jmp;
- NOTJMP();
- CASE cod_jmpifnoteq: # (JMPIFNOTEQ label)
- if (!eq(popSTACK(),value1)) goto jmp;
- NOTJMP();
- CASE cod_jmpifeqto: # (JMPIFEQTO n label)
- { var reg2 uintL n;
- U_operand(n);
- if (eq(popSTACK(),TheCclosure(closure)->clos_consts[n])) goto jmp;
- }
- NOTJMP();
- CASE cod_jmpifnoteqto: # (JMPIFNOTEQTO n label)
- { var reg2 uintL n;
- U_operand(n);
- if (!eq(popSTACK(),TheCclosure(closure)->clos_consts[n])) goto jmp;
- }
- NOTJMP();
- CASE cod_jmphash: # (JMPHASH n label)
- { var reg7 uintL n;
- U_operand(n);
- {var reg4 object hashvalue = # value1 in der Hash-Tabelle suchen
- gethash(value1,TheCclosure(closure)->clos_consts[n]);
- if (eq(hashvalue,nullobj))
- goto jmp; # nicht gefunden -> zu label springen
- else # gefundenes Fixnum als Label interpretieren:
- { byteptr += fixnum_to_L(hashvalue); }
- }}
- goto next_byte;
- CASE cod_jmphashv: # (JMPHASHV n label)
- { var reg7 uintL n;
- U_operand(n);
- {var reg4 object hashvalue = # value1 in der Hash-Tabelle suchen
- gethash(value1,TheSvector(TheCclosure(closure)->clos_consts[0])->data[n]);
- if (eq(hashvalue,nullobj))
- goto jmp; # nicht gefunden -> zu label springen
- else # gefundenes Fixnum als Label interpretieren:
- { byteptr += fixnum_to_L(hashvalue); }
- }}
- goto next_byte;
- # Führt einen (JSR label)-Befehl aus.
- #define JSR() \
- check_STACK(); check_SP(); \
- { var reg2 uintB* label_byteptr; \
- L_operand(label_byteptr); \
- with_saved_context( \
- interpret_bytecode_(closure,codeptr,label_byteptr); \
- ); \
- }
- CASE cod_jsr: # (JSR label)
- JSR();
- goto next_byte;
- CASE cod_jsr_push: # (JSR&PUSH label)
- JSR(); pushSTACK(value1);
- goto next_byte;
- CASE cod_jmptail: # (JMPTAIL m n label)
- { var reg7 uintL m;
- var reg8 uintL n;
- U_operand(m);
- U_operand(n);
- # Es gilt n>=m. m Stackeinträge um n-m nach oben kopieren:
- {var reg4 object* ptr1 = STACK STACKop m;
- var reg2 object* ptr2 = STACK STACKop n;
- var reg6 uintC count;
- dotimesC(count,m, { NEXT(ptr2) = NEXT(ptr1); } );
- # Nun ist ptr1 = STACK und ptr2 = STACK STACKop (n-m).
- *(closureptr = &NEXT(ptr2)) = closure; # Closure im Stack ablegen
- setSTACK(STACK = ptr2); # STACK verkürzen
- }}
- JMP(); # an label springen
- # ------------------- (6) Environments und Closures -----------------------
- CASE cod_venv: # (VENV)
- # VenvConst aus der Closure holen:
- value1 = TheCclosure(closure)->clos_venv; mv_count=1;
- goto next_byte;
- CASE cod_make_vector1_push: # (MAKE-VECTOR1&PUSH n)
- { var reg4 uintL n;
- U_operand(n);
- pushSTACK(value1);
- # Vektor erzeugen:
- {var reg2 object vec;
- with_saved_context( { vec = allocate_vector(n+1); } );
- # Erstes Element eintragen:
- TheSvector(vec)->data[0] = STACK_0;
- STACK_0 = vec;
- }}
- goto next_byte;
- CASE cod_copy_closure: # (COPY-CLOSURE m n)
- { var reg9 object old;
- # zu kopierende Closure holen:
- {var reg2 uintL m;
- U_operand(m);
- old = TheCclosure(closure)->clos_consts[m];
- }
- # Closure gleicher Länge allozieren:
- {var reg8 object new;
- pushSTACK(old);
- with_saved_context(
- new = allocate_srecord(0,Rectype_Closure,TheCclosure(old)->reclength,closure_type);
- );
- old = popSTACK();
- # Inhalt der alten in die neue Closure kopieren:
- { var reg2 object* newptr = &((Srecord)TheCclosure(new))->recdata[0];
- var reg4 object* oldptr = &((Srecord)TheCclosure(old))->recdata[0];
- var reg6 uintC count;
- dotimespC(count,((Srecord)TheCclosure(old))->reclength,
- { *newptr++ = *oldptr++; }
- );
- }
- # Stackinhalt in die neue Closure kopieren:
- { var reg7 uintL n;
- U_operand(n);
- {var reg2 object* newptr = &TheCclosure(new)->clos_consts[n];
- dotimespL(n,n, { *--newptr = popSTACK(); } );
- }}
- value1 = new; mv_count=1;
- }}
- goto next_byte;
- CASE cod_copy_closure_push: # (COPY-CLOSURE&PUSH m n)
- { var reg9 object old;
- # zu kopierende Closure holen:
- {var reg2 uintL m;
- U_operand(m);
- old = TheCclosure(closure)->clos_consts[m];
- }
- # Closure gleicher Länge allozieren:
- {var reg8 object new;
- pushSTACK(old);
- with_saved_context(
- new = allocate_srecord(0,Rectype_Closure,TheCclosure(old)->reclength,closure_type);
- );
- old = popSTACK();
- # Inhalt der alten in die neue Closure kopieren:
- { var reg2 object* newptr = &((Srecord)TheCclosure(new))->recdata[0];
- var reg4 object* oldptr = &((Srecord)TheCclosure(old))->recdata[0];
- var reg6 uintC count;
- dotimespC(count,((Srecord)TheCclosure(old))->reclength,
- { *newptr++ = *oldptr++; }
- );
- }
- # Stackinhalt in die neue Closure kopieren:
- { var reg7 uintL n;
- U_operand(n);
- {var reg2 object* newptr = &TheCclosure(new)->clos_consts[n];
- dotimespL(n,n, { *--newptr = popSTACK(); } );
- }}
- pushSTACK(new);
- }}
- goto next_byte;
- # ------------------- (7) Funktionsaufrufe -----------------------
- # Führt (CALL k n)-Befehl aus.
- #define CALL() \
- { var reg4 uintC k; # Argumentezahl \
- var reg2 uintL n; \
- U_operand(k); \
- U_operand(n); \
- with_saved_context( \
- funcall(TheCclosure(closure)->clos_consts[n],k); \
- ); \
- }
- # Führt (CALL0 n)-Befehl aus.
- #define CALL0() \
- { var reg2 uintL n; \
- U_operand(n); \
- with_saved_context( \
- funcall(TheCclosure(closure)->clos_consts[n],0); \
- ); \
- }
- # Führt (CALL1 n)-Befehl aus.
- #define CALL1() \
- { var reg2 uintL n; \
- U_operand(n); \
- with_saved_context( \
- funcall(TheCclosure(closure)->clos_consts[n],1); \
- ); \
- }
- # Führt (CALL2 n)-Befehl aus.
- #define CALL2() \
- { var reg2 uintL n; \
- U_operand(n); \
- with_saved_context( \
- funcall(TheCclosure(closure)->clos_consts[n],2); \
- ); \
- }
- # Führt (CALLS1 n)-Befehl aus.
- #define CALLS1() \
- { var reg2 uintL n; \
- B_operand(n); \
- # Der Compiler hat die Argumentüberprüfung schon gemacht. \
- {var reg2 Subr fun = FUNTAB1[n]; \
- subr_self = subr_tab_ptr_as_object(fun); \
- with_saved_context( \
- (*(subr_norest_function*)(fun->function))(); \
- ); \
- }}
- # Führt (CALLS2 n)-Befehl aus.
- #define CALLS2() \
- { var reg2 uintL n; \
- B_operand(n); \
- # Der Compiler hat die Argumentüberprüfung schon gemacht. \
- {var reg2 Subr fun = FUNTAB2[n]; \
- subr_self = subr_tab_ptr_as_object(fun); \
- with_saved_context( \
- (*(subr_norest_function*)(fun->function))(); \
- ); \
- }}
- # Führt (CALLSR m n)-Befehl aus.
- #define CALLSR() \
- { var reg4 uintL m; \
- var reg2 uintL n; \
- U_operand(m); \
- B_operand(n); \
- # Der Compiler hat die Argumentüberprüfung schon gemacht. \
- {var reg2 Subr fun = FUNTABR[n]; \
- subr_self = subr_tab_ptr_as_object(fun); \
- with_saved_context( \
- (*(subr_rest_function*)(fun->function))(m,args_end_pointer STACKop m); \
- ); \
- }}
- CASE cod_call: # (CALL k n)
- CALL();
- goto next_byte;
- CASE cod_call_push: # (CALL&PUSH k n)
- CALL(); pushSTACK(value1);
- goto next_byte;
- CASE cod_call0: # (CALL0 n)
- CALL0();
- goto next_byte;
- CASE cod_call1: # (CALL1 n)
- CALL1();
- goto next_byte;
- CASE cod_call1_push: # (CALL1&PUSH n)
- CALL1(); pushSTACK(value1);
- goto next_byte;
- CASE cod_call2: # (CALL2 n)
- CALL2();
- goto next_byte;
- CASE cod_call2_push: # (CALL2&PUSH n)
- CALL2(); pushSTACK(value1);
- goto next_byte;
- CASE cod_calls1: # (CALLS1 n)
- CALLS1();
- goto next_byte;
- CASE cod_calls1_push: # (CALLS1&PUSH n)
- CALLS1(); pushSTACK(value1);
- goto next_byte;
- CASE cod_calls2: # (CALLS2 n)
- CALLS2();
- goto next_byte;
- CASE cod_calls2_push: # (CALLS2&PUSH n)
- CALLS2(); pushSTACK(value1);
- goto next_byte;
- CASE cod_callsr: # (CALLSR m n)
- CALLSR();
- goto next_byte;
- CASE cod_callsr_push: # (CALLSR&PUSH m n)
- CALLSR(); pushSTACK(value1);
- goto next_byte;
- # Führt einen (CALLC)-Befehl aus.
- #define CALLC() \
- { check_STACK(); check_SP(); # STACK und SP überprüfen \
- with_saved_context( \
- # compilierte Closure ab Byte 6 interpretieren: \
- interpret_bytecode(value1,TheCclosure(value1)->clos_codevec,CCHD+6); \
- ); \
- }
- # Führt einen (CALLCKEY)-Befehl aus.
- #define CALLCKEY() \
- { check_STACK(); check_SP(); # STACK und SP überprüfen \
- with_saved_context( \
- # compilierte Closure ab Byte 10 interpretieren: \
- interpret_bytecode(value1,TheCclosure(value1)->clos_codevec,CCHD+10); \
- ); \
- }
- CASE cod_callc: # (CALLC)
- CALLC();
- goto next_byte;
- CASE cod_callc_push: # (CALLC&PUSH)
- CALLC(); pushSTACK(value1);
- goto next_byte;
- CASE cod_callckey: # (CALLCKEY)
- CALLCKEY();
- goto next_byte;
- CASE cod_callckey_push: # (CALLCKEY&PUSH)
- CALLCKEY(); pushSTACK(value1);
- goto next_byte;
- CASE cod_funcall: # (FUNCALL n)
- { var reg2 uintL n;
- U_operand(n);
- {var reg4 object fun = STACK_(n); # Funktion
- with_saved_context( funcall(fun,n); ); # Funktion aufrufen
- skipSTACK(1); # Funktion aus dem Stack streichen
- }}
- goto next_byte;
- CASE cod_funcall_push: # (FUNCALL&PUSH n)
- { var reg2 uintL n;
- U_operand(n);
- {var reg4 object fun = STACK_(n); # Funktion
- with_saved_context( funcall(fun,n); ); # Funktion aufrufen
- STACK_0 = value1; # Funktion im Stack durch den Wert ersetzen
- }}
- goto next_byte;
- CASE cod_apply: # (APPLY n)
- { var reg2 uintL n;
- U_operand(n);
- {var reg4 object fun = STACK_(n); # Funktion
- with_saved_context( apply(fun,n,value1); ); # Funktion aufrufen
- skipSTACK(1); # Funktion aus dem Stack streichen
- }}
- goto next_byte;
- CASE cod_apply_push: # (APPLY&PUSH n)
- { var reg2 uintL n;
- U_operand(n);
- {var reg4 object fun = STACK_(n); # Funktion
- with_saved_context( apply(fun,n,value1); ); # Funktion aufrufen
- STACK_0 = value1; # Funktion im Stack durch den Wert ersetzen
- }}
- goto next_byte;
- # ------------------- (8) optionale und Keyword-Argumente -----------------------
- CASE cod_push_unbound: # (PUSH-UNBOUND n)
- { var reg2 uintC n;
- U_operand(n);
- dotimesC(n,n, { pushSTACK(unbound); } );
- }
- goto next_byte;
- CASE cod_unlist: # (UNLIST n m)
- { var reg4 uintC n;
- var reg5 uintC m;
- U_operand(n);
- U_operand(m);
- {var reg2 object l = value1;
- if (n > 0)
- do { if (atomp(l)) goto unlist_unbound;
- pushSTACK(Car(l)); l = Cdr(l);
- }
- until (--n == 0);
- if (atomp(l))
- goto next_byte;
- else
- fehler_apply_zuviel(S(lambda));
- unlist_unbound:
- if (n > m) fehler_apply_zuwenig(S(lambda));
- do { pushSTACK(unbound); } until (--n == 0);
- goto next_byte;
- }}
- CASE cod_unliststern: # (UNLIST* n m)
- { var reg4 uintC n;
- var reg5 uintC m;
- U_operand(n);
- U_operand(m);
- {var reg2 object l = value1;
- do { if (atomp(l)) goto unliststern_unbound;
- pushSTACK(Car(l)); l = Cdr(l);
- }
- until (--n == 0);
- pushSTACK(l);
- goto next_byte;
- unliststern_unbound:
- if (n > m) fehler_apply_zuwenig(S(lambda));
- do { pushSTACK(unbound); } until (--n == 0);
- pushSTACK(NIL);
- goto next_byte;
- }}
- CASE cod_jmpifboundp: # (JMPIFBOUNDP n label)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object obj = STACK_(n);
- if (eq(obj,unbound)) goto notjmp;
- value1 = obj; mv_count=1; JMP();
- }}
- CASE cod_boundp: # (BOUNDP n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object obj = STACK_(n);
- if (eq(obj,unbound)) goto code_nil; else goto code_t;
- }}
- CASE cod_unbound_nil: # (UNBOUND->NIL n)
- { var reg2 uintL n;
- U_operand(n);
- if (eq(STACK_(n),unbound)) { STACK_(n) = NIL; }
- }
- goto next_byte;
- # ------------------- (9) Behandlung mehrerer Werte -----------------------
- CASE cod_values0: # (VALUES0)
- value1 = NIL; mv_count = 0;
- goto next_byte;
- CASE cod_values1: # (VALUES1)
- mv_count = 1;
- goto next_byte;
- CASE cod_stack_to_mv: # (STACK-TO-MV n)
- { var reg2 uintL n;
- U_operand(n);
- if (n >= mv_limit) goto fehler_zuviele_werte;
- STACK_to_mv(n);
- }
- goto next_byte;
- CASE cod_mv_to_stack: # (MV-TO-STACK)
- mv_to_STACK(); # Werte auf den Stack schieben
- goto next_byte;
- CASE cod_nv_to_stack: # (NV-TO-STACK n)
- { var reg4 uintL n;
- U_operand(n);
- # Test auf Stacküberlauf:
- get_space_on_STACK(n*sizeof(object));
- # n Werte in den Stack schieben:
- {var reg7 uintC count = mv_count;
- if (n==0) goto nv_to_stack_end; # kein Wert gewünscht -> fertig
- # mindestens 1 Wert gewünscht
- pushSTACK(value1);
- n--; if (n==0) goto nv_to_stack_end; # nur 1 Wert gewünscht -> fertig
- if (count<=1) goto nv_to_stack_fill; # nur 1 Wert vorhanden -> mit NILs auffüllen
- count--;
- # mindestens 2 Werte gewünscht und vorhanden
- { var reg2 object* mvp = &mv_space[1];
- loop
- { pushSTACK(*mvp++);
- n--; if (n==0) goto nv_to_stack_end; # kein Wert mehr gewünscht -> fertig
- count--; if (count==0) goto nv_to_stack_fill; # kein Wert mehr vorhanden -> mit NILs auffüllen
- } }
- nv_to_stack_fill: # Auffüllen mit n>0 NILs als zusätzlichen Werten:
- dotimespL(n,n, { pushSTACK(NIL); } );
- nv_to_stack_end: ;
- }}
- goto next_byte;
- CASE cod_mv_to_list: # (MV-TO-LIST)
- with_saved_context(
- # Werte auf den Stack schieben und daraus Liste basteln:
- mv_to_list();
- );
- value1 = popSTACK(); mv_count=1;
- goto next_byte;
- CASE cod_list_to_mv: # (LIST-TO-MV)
- list_to_mv(value1, { goto fehler_zuviele_werte; } );
- goto next_byte;
- CASE cod_mvcallp: # (MVCALLP)
- pushSP((aint)STACK); # STACK retten
- pushSTACK(value1); # auszuführende Funktion retten
- goto next_byte;
- CASE cod_mvcall: # (MVCALL)
- { var reg2 object* FRAME; popSP( FRAME = (object*) ); # Pointer über Argumente und Funktion
- {var reg7 object fun = NEXT(FRAME); # Funktion
- with_saved_context(
- {var reg4 uintL argcount = # Anzahl der Argumente auf dem Stack
- STACK_item_count(STACK,FRAME);
- if (((uintL)~(uintL)0 > ca_limit_1) && (argcount > ca_limit_1))
- fehler_zuviel_caller(fun,S(multiple_value_call));
- # Funktion anwenden, Stack anheben bis unter die Funktion:
- funcall(fun,argcount);
- skipSTACK(1); # Funktion aus dem STACK streichen
- });
- }}
- goto next_byte;
- # ------------------- (10) BLOCK -----------------------
- CASE cod_block_open: # (BLOCK-OPEN n label)
- # belegt 3 STACK-Einträge und 1 SP-jmp_buf-Eintrag und 2 SP-Einträge
- { var reg4 uintL n;
- var reg7 sintL label_dist;
- U_operand(n);
- S_operand(label_dist);
- # Block_Cons erzeugen:
- {var reg2 object block_cons;
- with_saved_context(
- block_cons = allocate_cons();
- label_dist += index; # CODEPTR+label_dist ist das Sprungziel
- );
- # Block-Cons füllen: (CONST n) als CAR
- Car(block_cons) = TheCclosure(closure)->clos_consts[n];
- # Sprungziel in den SP:
- pushSP(label_dist); pushSP((aint)closureptr);
- # CBLOCK-Frame aufbauen:
- { var reg7 object* top_of_frame = STACK; # Pointer übern Frame
- pushSTACK(block_cons); # Cons ( (CONST n) . ...)
- {var reg4 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
- finish_entry_frame_1(CBLOCK,returner, goto block_return; );
- }}
- # Framepointer im Block-Cons ablegen:
- Cdr(block_cons) = make_framepointer(STACK);
- }}
- goto next_byte;
- block_return: # Hierher wird gesprungen, wenn der oben aufgebaute
- # CBLOCK-Frame ein RETURN-FROM gefangen hat.
- { FREE_JMPBUF_on_SP();
- skipSTACK(2); # CBLOCK-Frame auflösen, dabei
- Cdr(popSTACK()) = disabled; # Block-Cons als Disabled markieren
- {var reg2 uintL index;
- # closure zurück, byteptr:=label_byteptr :
- popSP(closureptr = (object*) ); popSP(index = );
- closure = *closureptr; # Closure aus dem Stack holen
- codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
- byteptr = CODEPTR + index;
- }}
- goto next_byte; # am Label weiterinterpretieren
- CASE cod_block_close: # (BLOCK-CLOSE)
- # CBLOCK-Frame auflösen:
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == CBLOCK_frame_info))
- goto fehler_STACK_putt;
- #endif
- { FREE_JMPBUF_on_SP();
- skipSTACK(2); # CBLOCK-Frame auflösen, dabei
- Cdr(popSTACK()) = disabled; # Block-Cons als Disabled markieren
- skipSP(2); # Ziel-Closureptr und Ziel-Label kennen wir
- }
- goto next_byte; # am Label gleich weiterinterpretieren
- CASE cod_return_from: # (RETURN-FROM n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object block_cons = TheCclosure(closure)->clos_consts[n];
- if (eq(Cdr(block_cons),disabled))
- { fehler_block_left(Car(block_cons)); }
- # Bis zum Block-Frame unwinden, dann seine Routine zum Auflösen anspringen:
- #ifndef FAST_SP
- FREE_DYNAMIC_ARRAY(private_SP_space);
- #endif
- unwind_upto(uTheFramepointer(Cdr(block_cons)));
- }}
- CASE cod_return_from_i: # (RETURN-FROM-I k n)
- { var reg4 uintL k;
- var reg4 uintL n;
- U_operand(k);
- U_operand(n);
- {var reg2 object* FRAME = (object*) SP_(k);
- var reg2 object block_cons = FRAME_(n);
- if (eq(Cdr(block_cons),disabled))
- { fehler_block_left(Car(block_cons)); }
- # Bis zum Block-Frame unwinden, dann seine Routine zum Auflösen anspringen:
- #ifndef FAST_SP
- FREE_DYNAMIC_ARRAY(private_SP_space);
- #endif
- unwind_upto(uTheFramepointer(Cdr(block_cons)));
- }}
- # ------------------- (11) TAGBODY -----------------------
- CASE cod_tagbody_open: # (TAGBODY-OPEN n label1 ... labelm)
- # belegt 3+m STACK-Einträge und 1 SP-jmp_buf-Eintrag und 1 SP-Eintrag
- { var reg7 uintL n;
- U_operand(n);
- # Tagbody-Cons erzeugen:
- {var reg2 object tagbody_cons;
- with_saved_context(
- tagbody_cons = allocate_cons();
- );
- # Tagbody-Cons füllen: Tag-Vektor (CONST n) als CAR
- {var reg6 object tag_vector = TheCclosure(closure)->clos_consts[n];
- var reg7 uintL m = TheSvector(tag_vector)->length;
- Car(tagbody_cons) = tag_vector;
- get_space_on_STACK(m*sizeof(object)); # Platz reservieren
- # alle labeli als Fixnums auf den STACK legen:
- {var reg4 uintL count;
- dotimespL(count,m,
- { var reg2 uintB* label_byteptr;
- L_operand(label_byteptr);
- pushSTACK(fixnum(label_byteptr - CODEPTR));
- });
- }}
- # Sprungziel in den SP:
- pushSP((aint)closureptr);
- # CTAGBODY-Frame aufbauen:
- { var reg9 object* top_of_frame = STACK; # Pointer übern Frame
- pushSTACK(tagbody_cons); # Cons ( (CONST n) . ...)
- {var reg4 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
- finish_entry_frame_1(CTAGBODY,returner, goto tagbody_go; );
- }}
- # Framepointer im Tagbody-Cons ablegen:
- Cdr(tagbody_cons) = make_framepointer(STACK);
- }}
- goto next_byte;
- tagbody_go: # Hierher wird gesprungen, wenn der oben aufgebaute
- # CTAGBODY-Frame ein GO zum Label Nummer i gefangen hat.
- { var reg7 uintL m = TheSvector(Car(STACK_2))->length; # Anzahl der Labels
- # (Könnte auch das obige m als 'auto' deklarieren und hier benutzen.)
- var reg4 uintL i = posfixnum_to_L(value1); # Nummer des Labels
- var reg2 uintL index = posfixnum_to_L(STACK_((m-i)+3)); # labeli
- # closure zurück, byteptr:=labeli_byteptr :
- closureptr = (object*) SP_(jmpbufsize+0);
- closure = *closureptr; # Closure aus dem Stack holen
- codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
- byteptr = CODEPTR + index;
- }
- goto next_byte; # am Label i weiterinterpretieren
- CASE cod_tagbody_close_nil: # (TAGBODY-CLOSE-NIL)
- value1 = NIL; mv_count=1; # Wert des Tagbody ist NIL
- CASE cod_tagbody_close: # (TAGBODY-CLOSE)
- # CTAGBODY-Frame auflösen:
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == CTAGBODY_frame_info))
- goto fehler_STACK_putt;
- #endif
- { FREE_JMPBUF_on_SP();
- {var reg2 object tagbody_cons = STACK_2; # Tagbody-Cons
- Cdr(tagbody_cons) = disabled; # als Disabled markieren
- skipSTACK(3+TheSvector(Car(tagbody_cons))->length);
- skipSP(1);
- }}
- goto next_byte;
- CASE cod_go: # (GO n l)
- { var reg7 uintL n;
- var reg7 uintL l;
- U_operand(n);
- U_operand(l);
- {var reg2 object tagbody_cons = # (CONST n)
- TheCclosure(closure)->clos_consts[n];
- if (eq(Cdr(tagbody_cons),disabled))
- { var reg8 object tag_vector = Car(tagbody_cons);
- pushSTACK(tag_vector);
- pushSTACK(TheSvector(tag_vector)->data[l]); # Marke l
- pushSTACK(S(go));
- //: DEUTSCH "(~ ~): Der Tagbody mit den Marken ~ wurde bereits verlassen."
- //: ENGLISH "(~ ~): the tagbody of the tags ~ has already been left"
- //: FRANCAIS "(~ ~): Le «tagbody» avec les marqueurs ~ a déjà été quitté."
- fehler(control_error, GETTEXT("(~ ~): the tagbody of the tags ~ has already been left"));
- }
- # Übergabewert an den Tagbody:
- # Bei CTAGBODY-Frames 1+l als Fixnum,
- # bei ITAGBODY-Frames die Formenliste zu Tag Nummer l.
- {var reg4 object* FRAME = uTheFramepointer(Cdr(tagbody_cons));
- value1 = (mtypecode(FRAME_(0)) == CTAGBODY_frame_info
- ? fixnum(1+l)
- : FRAME_(frame_bindings+2*l+1)
- );
- mv_count=1;
- # Bis zum Tagbody-Frame unwinden, dann seine Routine anspringen,
- # die zum Label l springt:
- #ifndef FAST_SP
- FREE_DYNAMIC_ARRAY(private_SP_space);
- #endif
- unwind_upto(FRAME);
- }}}
- CASE cod_go_i: # (GO-I k n l)
- { var reg7 uintL k;
- var reg7 uintL n;
- var reg7 uintL l;
- U_operand(k);
- U_operand(n);
- U_operand(l);
- {var reg2 object* FRAME = (object*) SP_(k);
- var reg2 object tagbody_cons = FRAME_(n);
- if (eq(Cdr(tagbody_cons),disabled))
- { var reg8 object tag_vector = Car(tagbody_cons);
- pushSTACK(tag_vector);
- pushSTACK(TheSvector(tag_vector)->data[l]); # Marke l
- pushSTACK(S(go));
- //: DEUTSCH "(~ ~): Der Tagbody mit den Marken ~ wurde bereits verlassen."
- //: ENGLISH "(~ ~): the tagbody of the tags ~ has already been left"
- //: FRANCAIS "(~ ~): Le «tagbody» avec les marqueurs ~ a déjà été quitté."
- fehler(control_error, GETTEXT("(~ ~): the tagbody of the tags ~ has already been left"));
- }
- # Übergabewert an den Tagbody:
- # Bei CTAGBODY-Frames 1+l als Fixnum.
- {var reg4 object* FRAME = uTheFramepointer(Cdr(tagbody_cons));
- value1 = fixnum(1+l); mv_count=1;
- # Bis zum Tagbody-Frame unwinden, dann seine Routine anspringen,
- # die zum Label l springt:
- #ifndef FAST_SP
- FREE_DYNAMIC_ARRAY(private_SP_space);
- #endif
- unwind_upto(FRAME);
- }}}
- # ------------------- (12) CATCH und THROW -----------------------
- CASE cod_catch_open: # (CATCH-OPEN label)
- # belegt 3 STACK-Einträge und 1 SP-jmp_buf-Eintrag und 2 SP-Einträge
- { var reg2 uintB* label_byteptr;
- L_operand(label_byteptr);
- # closureptr, label_byteptr retten:
- pushSP(label_byteptr - CODEPTR); pushSP((aint)closureptr);
- } # Frame aufbauen:
- { var reg4 object* top_of_frame = STACK;
- pushSTACK(value1); # Tag
- {var reg2 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
- finish_entry_frame_1(CATCH,returner, goto catch_return; );
- }}
- goto next_byte;
- catch_return: # Hierher wird gesprungen, wenn der oben aufgebaute
- # Catch-Frame einen Throw gefangen hat.
- { FREE_JMPBUF_on_SP();
- skipSTACK(3); # CATCH-Frame auflösen
- {var reg2 uintL index;
- # closure zurück, byteptr:=label_byteptr :
- popSP(closureptr = (object*) ); popSP(index = );
- closure = *closureptr; # Closure aus dem Stack holen
- codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
- byteptr = CODEPTR + index;
- }}
- goto next_byte; # am Label weiterinterpretieren
- CASE cod_catch_close: # (CATCH-CLOSE)
- # Es muß ein CATCH-Frame kommen:
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == CATCH_frame_info))
- goto fehler_STACK_putt;
- #endif
- FREE_JMPBUF_on_SP();
- #if STACKCHECKC
- if (!(closureptr == (object*)SP_(0))) # dort stehender Closureptr muß der jetzige sein
- goto fehler_STACK_putt;
- #endif
- skipSP(2); skipSTACK(3); # CATCH-Frame auflösen
- goto next_byte;
- CASE cod_throw: # (THROW)
- { var reg2 object tag = popSTACK();
- throw(tag);
- pushSTACK(tag);
- pushSTACK(S(throw));
- //: DEUTSCH "~: Es gibt kein CATCH zur Marke ~."
- //: ENGLISH "~: There is no CATCHer for tag ~"
- //: FRANCAIS "~: Il n'y a pas de CATCH pour le marqueur ~."
- fehler(control_error, GETTEXT("~: There is no CATCHer for tag ~"));
- }
- # ------------------- (13) UNWIND-PROTECT -----------------------
- CASE cod_uwp_open: # (UNWIND-PROTECT-OPEN label)
- # belegt 2 STACK-Einträge und 1 SP-jmp_buf-Eintrag und 2 SP-Einträge
- { var reg2 uintB* label_byteptr;
- L_operand(label_byteptr);
- # closureptr, label_byteptr retten:
- pushSP(label_byteptr - CODEPTR); pushSP((aint)closureptr);
- } # Frame aufbauen:
- { var reg4 object* top_of_frame = STACK;
- var reg2 JMPBUF_on_SP(returner); # Rücksprungpunkt merken
- finish_entry_frame_1(UNWIND_PROTECT,returner, goto throw_save; );
- }
- goto next_byte;
- throw_save: # Hierher wird gesprungen, wenn der oben aufgebaute
- # Unwind-Protect-Frame einen Throw aufgehalten hat.
- # unwind_protect_to_save ist zu retten und am Schluß anzuspringen.
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == UNWIND_PROTECT_frame_info))
- //: DEUTSCH "STACK kaputt."
- //: ENGLISH "STACK corrupted"
- //: FRANCAIS "Pile STACK est corrompue."
- { fehler(serious_condition, GETTEXT("STACK corrupted"));
- }
- #endif
- # Frame auflösen:
- FREE_JMPBUF_on_SP();
- skipSTACK(2);
- { var reg2 uintL index;
- # closure zurück, byteptr:=label_byteptr :
- popSP(closureptr = (object*) );
- popSP(index = );
- # unwind_protect_to_save retten:
- pushSP((aint)unwind_protect_to_save.fun);
- pushSP((aint)unwind_protect_to_save.upto_frame);
- pushSP((aint)STACK); # Pointer übern Frame zusätzlich auf den SP
- # alle Werte auf den Stack:
- mv_to_STACK();
- # Cleanup-Formen ausführen:
- closure = *closureptr; # Closure aus dem Stack holen
- codeptr = TheSbvector(TheCclosure(closure)->clos_codevec);
- byteptr = CODEPTR + index;
- }
- goto next_byte;
- CASE cod_uwp_normal_exit: # (UNWIND-PROTECT-NORMAL-EXIT)
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == UNWIND_PROTECT_frame_info))
- goto fehler_STACK_putt;
- if (!(closureptr == (object*)SP_(jmpbufsize+0))) # dort stehender Closureptr muß der jetzige sein
- goto fehler_STACK_putt;
- #endif
- # Frame auflösen:
- # Nichts zu tun, da closure und byteptr unverändert bleiben.
- FREE_JMPBUF_on_SP(); skipSP(2);
- skipSTACK(2);
- # Dummy-Werte für 'unwind_protect_to_save':
- pushSP((aint)NULL); pushSP((aint)NULL); # NULL,NULL -> uwp_continue
- pushSP((aint)STACK); # Pointer übern Frame zusätzlich auf den SP
- # alle Werte auf den Stack:
- mv_to_STACK();
- # Cleanup-Formen ausführen:
- goto next_byte;
- CASE cod_uwp_close: # (UNWIND-PROTECT-CLOSE)
- # Hierher wird am Ende der Cleanup-Formen gesprungen.
- { var reg4 object* oldSTACK; # Wert von STACK vor dem Retten der Werte
- popSP( oldSTACK = (object*) );
- {var reg2 uintL mvcount = # Anzahl der geretteten Werte auf dem Stack
- STACK_item_count(STACK,oldSTACK);
- if (mvcount >= mv_limit) goto fehler_zuviele_werte;
- STACK_to_mv(mvcount);
- }}
- # Rücksprung zum geretteten unwind_protect_to_save.fun :
- { var reg4 restart fun;
- var reg2 object* arg;
- popSP( arg = (object*) ); popSP( fun = (restart) );
- # Rücksprung zu uwp_continue oder uwp_jmpback oder unwind_upto:
- if (!(fun == (restart)NULL))
- { (*fun)(arg); NOTREACHED } # Rücksprung zu unwind_upto o.ä.
- if (arg == (object*)NULL)
- { # uwp_continue:
- # Hierher wird gesprungen, wenn nach dem Ausführen der
- # Cleanup-Formen einfach weiterinterpretiert werden soll.
- goto next_byte;
- }
- else
- { # uwp_jmpback:
- # Hierher wird gesprungen, wenn nach dem Ausführen der
- # Cleanup-Formen an der alten Stelle in derselben Closure
- # weiterinterpretiert werden soll.
- byteptr = CODEPTR + (uintP)arg;
- goto next_byte;
- } }
- CASE cod_uwp_cleanup: # (UNWIND-PROTECT-CLEANUP)
- # Dies wird ausgeführt, wenn innerhalb derselben Closure ein
- # Ausführen des Cleanup-Codes nötig ist.
- #if STACKCHECKC
- if (!(mtypecode(STACK_0) == UNWIND_PROTECT_frame_info))
- goto fehler_STACK_putt;
- if (!(closureptr == (object*)SP_(jmpbufsize+0))) # dort stehender Closureptr muß der jetzige sein
- goto fehler_STACK_putt;
- #endif
- # closure bleibt, byteptr:=label_byteptr :
- { var reg2 uintL index = SP_(jmpbufsize+1);
- # Frame auflösen:
- FREE_JMPBUF_on_SP(); skipSP(2);
- skipSTACK(2);
- # Dummy-Werte für 'unwind_protect_to_save':
- pushSP((aint)NULL); # NULL -> uwp_jmpback
- pushSP(byteptr - CODEPTR);
- pushSP((aint)STACK); # Pointer übern Frame zusätzlich auf den SP
- # alle Werte auf den Stack:
- mv_to_STACK();
- # Cleanup-Formen ausführen:
- byteptr = CODEPTR + index;
- }
- goto next_byte;
- # ------------------- (14) HANDLER-BIND -----------------------
- CASE cod_handler_open: # (HANDLER-OPEN n)
- # belegt 4 STACK-Einträge
- { var reg2 uintL n;
- U_operand(n);
- # Frame aufbauen:
- {var reg5 object* top_of_frame = STACK; # Pointer übern Frame
- pushSTACK(TheCclosure(closure)->clos_consts[n]);
- pushSTACK(closure);
- pushSTACK(as_object((aint)(_SP_(0))));
- finish_frame(HANDLER);
- }}
- goto next_byte;
- CASE cod_handler_begin_push: # (HANDLER-BEGIN&PUSH)
- # baut SP neu auf, belegt 1 SP-Eintrag und
- # beginnt einen neuen STACK-Bereich.
- { var reg5 uintL count = handler_args.spdepth;
- if (count > 0)
- { var reg2 SPint* oldsp = handler_args.sp; # war früher &SP_(0)
- # oldsp[0..count-1] auf den jetzigen SP kopieren:
- oldsp skipSPop count;
- dotimespL(count,count, { oldsp skipSPop -1; pushSP(*oldsp); } );
- } }
- pushSP((aint)handler_args.stack); # Pointer übern Handler-Frame
- value1 = handler_args.condition; mv_count=1;
- pushSTACK(value1);
- goto next_byte;
- # ------------------- (15) einige Funktionen -----------------------
- CASE cod_not: # (NOT)
- if (nullp(value1)) goto code_t; else goto code_nil;
- CASE cod_eq: # (EQ)
- if (!eq(value1,popSTACK())) goto code_nil; else goto code_t;
- CASE cod_car: # (CAR)
- { var reg2 object arg = value1;
- if (consp(arg)) { value1 = Car(arg); } # CAR eines Cons
- elif (nullp(arg)) {} # (CAR NIL) = NIL: value1 bleibt NIL
- else { subr_self = L(car); fehler_list(arg); }
- mv_count=1;
- }
- goto next_byte;
- CASE cod_car_push: # (CAR&PUSH)
- { var reg2 object arg = value1;
- if (consp(arg)) { pushSTACK(Car(arg)); } # CAR eines Cons
- elif (nullp(arg)) { pushSTACK(arg); } # (CAR NIL) = NIL
- else { subr_self = L(car); fehler_list(arg); }
- }
- goto next_byte;
- CASE cod_load_car_push: # (LOAD&CAR&PUSH n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object arg = STACK_(n);
- if (consp(arg)) { pushSTACK(Car(arg)); } # CAR eines Cons
- elif (nullp(arg)) { pushSTACK(arg); } # (CAR NIL) = NIL
- else { subr_self = L(car); fehler_list(arg); }
- }}
- goto next_byte;
- CASE cod_load_car_store: # (LOAD&CAR&STORE m n)
- { var reg7 uintL m;
- var reg4 uintL n;
- U_operand(m);
- U_operand(n);
- {var reg2 object arg = STACK_(m);
- if (consp(arg)) { STACK_(n) = value1 = Car(arg); } # CAR eines Cons
- elif (nullp(arg)) { STACK_(n) = value1 = arg; } # (CAR NIL) = NIL
- else { subr_self = L(car); fehler_list(arg); }
- mv_count=1;
- }}
- goto next_byte;
- CASE cod_cdr: # (CDR)
- { var reg2 object arg = value1;
- if (consp(arg)) { value1 = Cdr(arg); } # CDR eines Cons
- elif (nullp(arg)) {} # (CDR NIL) = NIL: value1 bleibt NIL
- else { subr_self = L(cdr); fehler_list(arg); }
- mv_count=1;
- }
- goto next_byte;
- CASE cod_cdr_push: # (CDR&PUSH)
- { var reg2 object arg = value1;
- if (consp(arg)) { pushSTACK(Cdr(arg)); } # CDR eines Cons
- elif (nullp(arg)) { pushSTACK(arg); } # (CDR NIL) = NIL
- else { subr_self = L(cdr); fehler_list(arg); }
- }
- goto next_byte;
- CASE cod_load_cdr_push: # (LOAD&CDR&PUSH n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object arg = STACK_(n);
- if (consp(arg)) { pushSTACK(Cdr(arg)); } # CDR eines Cons
- elif (nullp(arg)) { pushSTACK(arg); } # (CDR NIL) = NIL
- else { subr_self = L(cdr); fehler_list(arg); }
- }}
- goto next_byte;
- CASE cod_load_cdr_store: # (LOAD&CDR&STORE n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg4 object* arg_ = &STACK_(n);
- var reg2 object arg = *arg_;
- if (consp(arg)) { *arg_ = value1 = Cdr(arg); } # CDR eines Cons
- elif (nullp(arg)) { value1 = arg; } # (CDR NIL) = NIL
- else { subr_self = L(cdr); fehler_list(arg); }
- mv_count=1;
- }}
- goto next_byte;
- CASE cod_cons: # (CONS)
- pushSTACK(value1);
- # Cons anfordern:
- {var reg2 object new_cons;
- with_saved_context( { new_cons = allocate_cons(); } );
- # Cons füllen:
- Cdr(new_cons) = popSTACK();
- Car(new_cons) = popSTACK();
- value1 = new_cons; mv_count=1;
- }
- goto next_byte;
- CASE cod_cons_push: # (CONS&PUSH)
- pushSTACK(value1);
- # Cons anfordern:
- {var reg2 object new_cons;
- with_saved_context( { new_cons = allocate_cons(); } );
- # Cons füllen:
- Cdr(new_cons) = popSTACK();
- Car(new_cons) = STACK_0;
- STACK_0 = new_cons;
- }
- goto next_byte;
- CASE cod_load_cons_store: # (LOAD&CONS&STORE n)
- { var reg4 uintL n;
- U_operand(n);
- # Cons anfordern:
- {var reg2 object new_cons;
- with_saved_context( { new_cons = allocate_cons(); } );
- # Cons füllen:
- Car(new_cons) = popSTACK();
- {var reg4 object* arg_ = &STACK_(n);
- Cdr(new_cons) = *arg_;
- value1 = *arg_ = new_cons; mv_count=1;
- }}}
- goto next_byte;
- {var reg2 object symbol;
- CASE cod_symbol_function: # (SYMBOL-FUNCTION)
- symbol = value1;
- if (!symbolp(symbol)) goto csf_kein_symbol;
- if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
- value1 = Symbol_function(symbol); mv_count=1;
- goto next_byte;
- CASE cod_const_symbol_function: # (CONST&SYMBOL-FUNCTION n)
- {var reg4 uintL n;
- U_operand(n);
- symbol = TheCclosure(closure)->clos_consts[n];
- }
- if (!symbolp(symbol)) goto csf_kein_symbol;
- if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
- value1 = Symbol_function(symbol); mv_count=1;
- goto next_byte;
- CASE cod_const_symbol_function_push: # (CONST&SYMBOL-FUNCTION&PUSH n)
- {var reg4 uintL n;
- U_operand(n);
- symbol = TheCclosure(closure)->clos_consts[n];
- }
- if (!symbolp(symbol)) goto csf_kein_symbol;
- if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
- pushSTACK(Symbol_function(symbol));
- goto next_byte;
- CASE cod_const_symbol_function_store: # (CONST&SYMBOL-FUNCTION&STORE n k)
- {var reg4 uintL n;
- U_operand(n);
- symbol = TheCclosure(closure)->clos_consts[n];
- }
- if (!symbolp(symbol)) goto csf_kein_symbol;
- if (eq(Symbol_function(symbol),unbound)) goto csf_unbound;
- {var reg4 uintL k;
- U_operand(k);
- STACK_(k) = value1 = Symbol_function(symbol); mv_count=1;
- }
- goto next_byte;
- csf_kein_symbol:
- fehler_kein_symbol(S(symbol_function),symbol);
- csf_unbound:
- pushSTACK(symbol); # Wert für Slot NAME von CELL-ERROR
- # (Das ist zwar evtl. nicht der eigentliche Funktionsname, denn
- # z.B. (FUNCTION FOO) wird in (SYMBOL-FUNCTION '#:|(SETF FOO)|)
- # umgewandelt, aber für die Fehlermeldung reicht das wohl.)
- pushSTACK(symbol);
- pushSTACK(S(symbol_function));
- //: DEUTSCH "~: ~ hat keine Funktionsdefinition."
- //: ENGLISH "~: the function ~ is undefined"
- //: FRANCAIS "~: la fonction ~ n'est pas définie."
- fehler(undefined_function, GETTEXT("~: the function ~ is undefined"));
- }
- {var reg2 object vec; var reg4 object index;
- CASE cod_svref: # (SVREF)
- # STACK_0 muß ein Simple-Vector sein:
- if (!m_simple_vector_p(STACK_0)) goto svref_kein_svector;
- vec = popSTACK(); # Simple-Vector
- index = value1;
- # und der Index muß ein Fixnum >=0, <Länge(vec) sein:
- {var reg7 uintL i;
- if (!(posfixnump(index) &&
- ((i = posfixnum_to_L(index)) < TheSvector(vec)->length)
- ) )
- goto svref_kein_index;
- value1 = TheSvector(vec)->data[i]; # indiziertes Element als Wert
- mv_count = 1;
- }
- goto next_byte;
- CASE cod_svset: # (SVSET)
- # STACK_0 muß ein Simple-Vector sein:
- if (!m_simple_vector_p(STACK_0)) goto svref_kein_svector;
- vec = popSTACK(); # Simple-Vector
- index = value1;
- # und der Index muß ein Fixnum >=0, <Länge(vec) sein:
- {var reg7 uintL i;
- if (!(posfixnump(index) &&
- ((i = posfixnum_to_L(index)) < TheSvector(vec)->length)
- ) )
- goto svref_kein_index;
- value1 = TheSvector(vec)->data[i] = popSTACK(); # neues Element hineinstecken
- mv_count = 1;
- }
- goto next_byte;
- svref_kein_svector: # Nicht-Simple-Vector in STACK_0
- fehler_kein_svector(S(svref),STACK_0);
- svref_kein_index: # unpassender Index in index, zum Vektor vec
- pushSTACK(vec);
- pushSTACK(index);
- pushSTACK(S(svref));
- //: DEUTSCH "~: ~ ist kein passender Index für ~"
- //: ENGLISH "~: ~ is not a correct index into ~"
- //: FRANCAIS "~: ~ n'est pas un index convenable dans ~."
- fehler(error, GETTEXT("~: ~ is not a correct index into ~"));
- }
- CASE cod_list: # (LIST n)
- { var reg2 uintC n;
- U_operand(n);
- with_saved_context( { value1 = listof(n); mv_count=1; } );
- }
- goto next_byte;
- CASE cod_list_push: # (LIST&PUSH n)
- { var reg2 uintC n;
- U_operand(n);
- with_saved_context( { pushSTACK(listof(n)); } );
- }
- goto next_byte;
- CASE cod_liststern: # (LIST* n)
- { var reg4 uintC n;
- U_operand(n);
- with_saved_context(
- { pushSTACK(value1);
- dotimespC(n,n,
- { var reg2 object new_cons = allocate_cons();
- Cdr(new_cons) = popSTACK();
- Car(new_cons) = STACK_0;
- STACK_0 = new_cons;
- });
- value1 = popSTACK(); mv_count=1;
- });
- }
- goto next_byte;
- CASE cod_liststern_push: # (LIST*&PUSH n)
- { var reg4 uintC n;
- U_operand(n);
- with_saved_context(
- { pushSTACK(value1);
- dotimespC(n,n,
- { var reg2 object new_cons = allocate_cons();
- Cdr(new_cons) = popSTACK();
- Car(new_cons) = STACK_0;
- STACK_0 = new_cons;
- });
- });
- }
- goto next_byte;
- # ------------------- (16) kombinierte Operationen -----------------------
- CASE cod_nil_store: # (NIL&STORE n)
- {var reg1 uintL n;
- U_operand(n);
- STACK_(n) = value1 = NIL; mv_count=1;
- }
- goto next_byte;
- CASE cod_t_store: # (T&STORE n)
- {var reg1 uintL n;
- U_operand(n);
- STACK_(n) = value1 = T; mv_count=1;
- }
- goto next_byte;
- CASE cod_calls1_store: # (CALLS1&STORE n k)
- CALLS1();
- goto store;
- CASE cod_calls2_store: # (CALLS2&STORE n k)
- CALLS2();
- goto store;
- CASE cod_callsr_store: # (CALLSR&STORE m n k)
- CALLSR();
- goto store;
- # Incrementieren. Speziell optimiert für Fixnums >=0.
- #define INC(arg,statement) \
- { if (posfixnump(arg) # Fixnum >= 0 und < most-positive-fixnum ? \
- && !eq(arg,fixnum(bitm(oint_data_len)-1)) \
- ) \
- { arg = fixnum_inc(arg,1); statement; } \
- else \
- { with_saved_context( \
- { pushSTACK(arg); subr_self = L(einsplus); C_einsplus(); } # funcall(L(einsplus),1); \
- ); \
- arg = value1; \
- } }
- # Decrementieren. Speziell optimiert für Fixnums >=0.
- #define DEC(arg,statement) \
- { if (posfixnump(arg) && !eq(arg,Fixnum_0)) # Fixnum > 0 ? \
- { arg = fixnum_inc(arg,-1); statement; } \
- else \
- { with_saved_context( \
- { pushSTACK(arg); subr_self = L(einsminus); C_einsminus(); } # funcall(L(einsminus),1); \
- ); \
- arg = value1; \
- } }
- CASE cod_load_inc_push: # (LOAD&INC&PUSH n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object arg = STACK_(n);
- INC(arg,_EMA_); # incrementieren
- pushSTACK(arg);
- }}
- goto next_byte;
- CASE cod_load_inc_store: # (LOAD&INC&STORE n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg4 object* arg_ = &STACK_(n);
- var reg2 object arg = *arg_;
- INC(arg,mv_count=1); # incrementieren, 1 Wert
- value1 = *arg_ = arg;
- }}
- goto next_byte;
- CASE cod_load_dec_push: # (LOAD&DEC&PUSH n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg2 object arg = STACK_(n);
- DEC(arg,_EMA_); # decrementieren
- pushSTACK(arg);
- }}
- goto next_byte;
- CASE cod_load_dec_store: # (LOAD&DEC&STORE n)
- { var reg4 uintL n;
- U_operand(n);
- {var reg4 object* arg_ = &STACK_(n);
- var reg2 object arg = *arg_;
- DEC(arg,mv_count=1); # decrementieren, 1 Wert
- value1 = *arg_ = arg;
- }}
- goto next_byte;
- CASE cod_call1_jmpif: # (CALL1&JMPIF n label)
- CALL1();
- if (!nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_call1_jmpifnot: # (CALL1&JMPIFNOT n label)
- CALL1();
- if (nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_call2_jmpif: # (CALL2&JMPIF n label)
- CALL2();
- if (!nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_call2_jmpifnot: # (CALL2&JMPIFNOT n label)
- CALL2();
- if (nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_calls1_jmpif: # (CALLS1&JMPIF n label)
- CALLS1();
- if (!nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_calls1_jmpifnot: # (CALLS1&JMPIFNOT n label)
- CALLS1();
- if (nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_calls2_jmpif: # (CALLS2&JMPIF n label)
- CALLS2();
- if (!nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_calls2_jmpifnot: # (CALLS2&JMPIFNOT n label)
- CALLS2();
- if (nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_callsr_jmpif: # (CALLSR&JMPIF m n label)
- CALLSR();
- if (!nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_callsr_jmpifnot: # (CALLSR&JMPIFNOT m n label)
- CALLSR();
- if (nullp(value1)) goto jmp; else goto notjmp;
- CASE cod_load_jmpif: # (LOAD&JMPIF n label)
- {var reg2 uintL n;
- U_operand(n);
- mv_count=1;
- if (!nullp(value1 = STACK_(n))) goto jmp; else goto notjmp;
- }
- CASE cod_load_jmpifnot: # (LOAD&JMPIFNOT n label)
- {var reg2 uintL n;
- U_operand(n);
- mv_count=1;
- if (nullp(value1 = STACK_(n))) goto jmp; else goto notjmp;
- }
- CASE cod_apply_skip_ret: # (APPLY&SKIP&RET n k)
- { var reg2 uintL n;
- var reg5 uintL k;
- U_operand(n);
- U_operand(k);
- {var reg4 object fun = STACK_(n); # Funktion
- with_saved_context(
- { apply(fun,n,value1); # Funktion aufrufen
- skipSTACK(k+1); # Funktion u.a. aus dem Stack streichen
- goto finished; # Rücksprung zum Aufrufer
- }); # der Kontext wird nicht restauriert
- }}
- # ------------------- (17) Kurzcodes -----------------------
- CASE cod_load0: # (LOAD.S 0)
- value1 = STACK_(0); mv_count=1;
- goto next_byte;
- CASE cod_load1: # (LOAD.S 1)
- value1 = STACK_(1); mv_count=1;
- goto next_byte;
- CASE cod_load2: # (LOAD.S 2)
- value1 = STACK_(2); mv_count=1;
- goto next_byte;
- CASE cod_load3: # (LOAD.S 3)
- value1 = STACK_(3); mv_count=1;
- goto next_byte;
- CASE cod_load4: # (LOAD.S 4)
- value1 = STACK_(4); mv_count=1;
- goto next_byte;
- CASE cod_load5: # (LOAD.S 5)
- value1 = STACK_(5); mv_count=1;
- goto next_byte;
- CASE cod_load6: # (LOAD.S 6)
- value1 = STACK_(6); mv_count=1;
- goto next_byte;
- CASE cod_load7: # (LOAD.S 7)
- value1 = STACK_(7); mv_count=1;
- goto next_byte;
- CASE cod_load8: # (LOAD.S 8)
- value1 = STACK_(8); mv_count=1;
- goto next_byte;
- CASE cod_load9: # (LOAD.S 9)
- value1 = STACK_(9); mv_count=1;
- goto next_byte;
- CASE cod_load10: # (LOAD.S 10)
- value1 = STACK_(10); mv_count=1;
- goto next_byte;
- CASE cod_load11: # (LOAD.S 11)
- value1 = STACK_(11); mv_count=1;
- goto next_byte;
- CASE cod_load12: # (LOAD.S 12)
- value1 = STACK_(12); mv_count=1;
- goto next_byte;
- CASE cod_load13: # (LOAD.S 13)
- value1 = STACK_(13); mv_count=1;
- goto next_byte;
- CASE cod_load14: # (LOAD.S 14)
- value1 = STACK_(14); mv_count=1;
- goto next_byte;
- #if 0
- CASE cod_load15: # (LOAD.S 15)
- value1 = STACK_(15); mv_count=1;
- goto next_byte;
- CASE cod_load16: # (LOAD.S 16)
- value1 = STACK_(16); mv_count=1;
- goto next_byte;
- CASE cod_load17: # (LOAD.S 17)
- value1 = STACK_(17); mv_count=1;
- goto next_byte;
- CASE cod_load18: # (LOAD.S 18)
- value1 = STACK_(18); mv_count=1;
- goto next_byte;
- CASE cod_load19: # (LOAD.S 19)
- value1 = STACK_(19); mv_count=1;
- goto next_byte;
- CASE cod_load20: # (LOAD.S 20)
- value1 = STACK_(20); mv_count=1;
- goto next_byte;
- CASE cod_load21: # (LOAD.S 21)
- value1 = STACK_(21); mv_count=1;
- goto next_byte;
- #endif
- CASE cod_load_push0: # (LOAD&PUSH.S 0)
- pushSTACK(STACK_(0));
- goto next_byte;
- CASE cod_load_push1: # (LOAD&PUSH.S 1)
- pushSTACK(STACK_(1));
- goto next_byte;
- CASE cod_load_push2: # (LOAD&PUSH.S 2)
- pushSTACK(STACK_(2));
- goto next_byte;
- CASE cod_load_push3: # (LOAD&PUSH.S 3)
- pushSTACK(STACK_(3));
- goto next_byte;
- CASE cod_load_push4: # (LOAD&PUSH.S 4)
- pushSTACK(STACK_(4));
- goto next_byte;
- CASE cod_load_push5: # (LOAD&PUSH.S 5)
- pushSTACK(STACK_(5));
- goto next_byte;
- CASE cod_load_push6: # (LOAD&PUSH.S 6)
- pushSTACK(STACK_(6));
- goto next_byte;
- CASE cod_load_push7: # (LOAD&PUSH.S 7)
- pushSTACK(STACK_(7));
- goto next_byte;
- CASE cod_load_push8: # (LOAD&PUSH.S 8)
- pushSTACK(STACK_(8));
- goto next_byte;
- CASE cod_load_push9: # (LOAD&PUSH.S 9)
- pushSTACK(STACK_(9));
- goto next_byte;
- CASE cod_load_push10: # (LOAD&PUSH.S 10)
- pushSTACK(STACK_(10));
- goto next_byte;
- CASE cod_load_push11: # (LOAD&PUSH.S 11)
- pushSTACK(STACK_(11));
- goto next_byte;
- CASE cod_load_push12: # (LOAD&PUSH.S 12)
- pushSTACK(STACK_(12));
- goto next_byte;
- CASE cod_load_push13: # (LOAD&PUSH.S 13)
- pushSTACK(STACK_(13));
- goto next_byte;
- CASE cod_load_push14: # (LOAD&PUSH.S 14)
- pushSTACK(STACK_(14));
- goto next_byte;
- CASE cod_load_push15: # (LOAD&PUSH.S 15)
- pushSTACK(STACK_(15));
- goto next_byte;
- CASE cod_load_push16: # (LOAD&PUSH.S 16)
- pushSTACK(STACK_(16));
- goto next_byte;
- CASE cod_load_push17: # (LOAD&PUSH.S 17)
- pushSTACK(STACK_(17));
- goto next_byte;
- CASE cod_load_push18: # (LOAD&PUSH.S 18)
- pushSTACK(STACK_(18));
- goto next_byte;
- CASE cod_load_push19: # (LOAD&PUSH.S 19)
- pushSTACK(STACK_(19));
- goto next_byte;
- CASE cod_load_push20: # (LOAD&PUSH.S 20)
- pushSTACK(STACK_(20));
- goto next_byte;
- CASE cod_load_push21: # (LOAD&PUSH.S 21)
- pushSTACK(STACK_(21));
- goto next_byte;
- CASE cod_load_push22: # (LOAD&PUSH.S 22)
- pushSTACK(STACK_(22));
- goto next_byte;
- CASE cod_load_push23: # (LOAD&PUSH.S 23)
- pushSTACK(STACK_(23));
- goto next_byte;
- CASE cod_load_push24: # (LOAD&PUSH.S 24)
- pushSTACK(STACK_(24));
- goto next_byte;
- CASE cod_const0: # (CONST.S 0)
- value1 = TheCclosure(closure)->clos_consts[0]; mv_count=1;
- goto next_byte;
- CASE cod_const1: # (CONST.S 1)
- value1 = TheCclosure(closure)->clos_consts[1]; mv_count=1;
- goto next_byte;
- CASE cod_const2: # (CONST.S 2)
- value1 = TheCclosure(closure)->clos_consts[2]; mv_count=1;
- goto next_byte;
- CASE cod_const3: # (CONST.S 3)
- value1 = TheCclosure(closure)->clos_consts[3]; mv_count=1;
- goto next_byte;
- CASE cod_const4: # (CONST.S 4)
- value1 = TheCclosure(closure)->clos_consts[4]; mv_count=1;
- goto next_byte;
- CASE cod_const5: # (CONST.S 5)
- value1 = TheCclosure(closure)->clos_consts[5]; mv_count=1;
- goto next_byte;
- CASE cod_const6: # (CONST.S 6)
- value1 = TheCclosure(closure)->clos_consts[6]; mv_count=1;
- goto next_byte;
- CASE cod_const7: # (CONST.S 7)
- value1 = TheCclosure(closure)->clos_consts[7]; mv_count=1;
- goto next_byte;
- CASE cod_const8: # (CONST.S 8)
- value1 = TheCclosure(closure)->clos_consts[8]; mv_count=1;
- goto next_byte;
- CASE cod_const9: # (CONST.S 9)
- value1 = TheCclosure(closure)->clos_consts[9]; mv_count=1;
- goto next_byte;
- CASE cod_const10: # (CONST.S 10)
- value1 = TheCclosure(closure)->clos_consts[10]; mv_count=1;
- goto next_byte;
- CASE cod_const11: # (CONST.S 11)
- value1 = TheCclosure(closure)->clos_consts[11]; mv_count=1;
- goto next_byte;
- CASE cod_const12: # (CONST.S 12)
- value1 = TheCclosure(closure)->clos_consts[12]; mv_count=1;
- goto next_byte;
- CASE cod_const13: # (CONST.S 13)
- value1 = TheCclosure(closure)->clos_consts[13]; mv_count=1;
- goto next_byte;
- CASE cod_const14: # (CONST.S 14)
- value1 = TheCclosure(closure)->clos_consts[14]; mv_count=1;
- goto next_byte;
- CASE cod_const15: # (CONST.S 15)
- value1 = TheCclosure(closure)->clos_consts[15]; mv_count=1;
- goto next_byte;
- CASE cod_const16: # (CONST.S 16)
- value1 = TheCclosure(closure)->clos_consts[16]; mv_count=1;
- goto next_byte;
- CASE cod_const17: # (CONST.S 17)
- value1 = TheCclosure(closure)->clos_consts[17]; mv_count=1;
- goto next_byte;
- CASE cod_const18: # (CONST.S 18)
- value1 = TheCclosure(closure)->clos_consts[18]; mv_count=1;
- goto next_byte;
- CASE cod_const19: # (CONST.S 19)
- value1 = TheCclosure(closure)->clos_consts[19]; mv_count=1;
- goto next_byte;
- CASE cod_const20: # (CONST.S 20)
- value1 = TheCclosure(closure)->clos_consts[20]; mv_count=1;
- goto next_byte;
- #if 0
- CASE cod_const21: # (CONST.S 21)
- value1 = TheCclosure(closure)->clos_consts[21]; mv_count=1;
- goto next_byte;
- CASE cod_const22: # (CONST.S 22)
- value1 = TheCclosure(closure)->clos_consts[22]; mv_count=1;
- goto next_byte;
- CASE cod_const23: # (CONST.S 23)
- value1 = TheCclosure(closure)->clos_consts[23]; mv_count=1;
- goto next_byte;
- CASE cod_const24: # (CONST.S 24)
- value1 = TheCclosure(closure)->clos_consts[24]; mv_count=1;
- goto next_byte;
- #endif
- CASE cod_const_push0: # (CONST&PUSH.S 0)
- pushSTACK(TheCclosure(closure)->clos_consts[0]);
- goto next_byte;
- CASE cod_const_push1: # (CONST&PUSH.S 1)
- pushSTACK(TheCclosure(closure)->clos_consts[1]);
- goto next_byte;
- CASE cod_const_push2: # (CONST&PUSH.S 2)
- pushSTACK(TheCclosure(closure)->clos_consts[2]);
- goto next_byte;
- CASE cod_const_push3: # (CONST&PUSH.S 3)
- pushSTACK(TheCclosure(closure)->clos_consts[3]);
- goto next_byte;
- CASE cod_const_push4: # (CONST&PUSH.S 4)
- pushSTACK(TheCclosure(closure)->clos_consts[4]);
- goto next_byte;
- CASE cod_const_push5: # (CONST&PUSH.S 5)
- pushSTACK(TheCclosure(closure)->clos_consts[5]);
- goto next_byte;
- CASE cod_const_push6: # (CONST&PUSH.S 6)
- pushSTACK(TheCclosure(closure)->clos_consts[6]);
- goto next_byte;
- CASE cod_const_push7: # (CONST&PUSH.S 7)
- pushSTACK(TheCclosure(closure)->clos_consts[7]);
- goto next_byte;
- CASE cod_const_push8: # (CONST&PUSH.S 8)
- pushSTACK(TheCclosure(closure)->clos_consts[8]);
- goto next_byte;
- CASE cod_const_push9: # (CONST&PUSH.S 9)
- pushSTACK(TheCclosure(closure)->clos_consts[9]);
- goto next_byte;
- CASE cod_const_push10: # (CONST&PUSH.S 10)
- pushSTACK(TheCclosure(closure)->clos_consts[10]);
- goto next_byte;
- CASE cod_const_push11: # (CONST&PUSH.S 11)
- pushSTACK(TheCclosure(closure)->clos_consts[11]);
- goto next_byte;
- CASE cod_const_push12: # (CONST&PUSH.S 12)
- pushSTACK(TheCclosure(closure)->clos_consts[12]);
- goto next_byte;
- CASE cod_const_push13: # (CONST&PUSH.S 13)
- pushSTACK(TheCclosure(closure)->clos_consts[13]);
- goto next_byte;
- CASE cod_const_push14: # (CONST&PUSH.S 14)
- pushSTACK(TheCclosure(closure)->clos_consts[14]);
- goto next_byte;
- CASE cod_const_push15: # (CONST&PUSH.S 15)
- pushSTACK(TheCclosure(closure)->clos_consts[15]);
- goto next_byte;
- CASE cod_const_push16: # (CONST&PUSH.S 16)
- pushSTACK(TheCclosure(closure)->clos_consts[16]);
- goto next_byte;
- CASE cod_const_push17: # (CONST&PUSH.S 17)
- pushSTACK(TheCclosure(closure)->clos_consts[17]);
- goto next_byte;
- CASE cod_const_push18: # (CONST&PUSH.S 18)
- pushSTACK(TheCclosure(closure)->clos_consts[18]);
- goto next_byte;
- CASE cod_const_push19: # (CONST&PUSH.S 19)
- pushSTACK(TheCclosure(closure)->clos_consts[19]);
- goto next_byte;
- CASE cod_const_push20: # (CONST&PUSH.S 20)
- pushSTACK(TheCclosure(closure)->clos_consts[20]);
- goto next_byte;
- CASE cod_const_push21: # (CONST&PUSH.S 21)
- pushSTACK(TheCclosure(closure)->clos_consts[21]);
- goto next_byte;
- CASE cod_const_push22: # (CONST&PUSH.S 22)
- pushSTACK(TheCclosure(closure)->clos_consts[22]);
- goto next_byte;
- CASE cod_const_push23: # (CONST&PUSH.S 23)
- pushSTACK(TheCclosure(closure)->clos_consts[23]);
- goto next_byte;
- CASE cod_const_push24: # (CONST&PUSH.S 24)
- pushSTACK(TheCclosure(closure)->clos_consts[24]);
- goto next_byte;
- CASE cod_const_push25: # (CONST&PUSH.S 25)
- pushSTACK(TheCclosure(closure)->clos_consts[25]);
- goto next_byte;
- CASE cod_const_push26: # (CONST&PUSH.S 26)
- pushSTACK(TheCclosure(closure)->clos_consts[26]);
- goto next_byte;
- CASE cod_const_push27: # (CONST&PUSH.S 27)
- pushSTACK(TheCclosure(closure)->clos_consts[27]);
- goto next_byte;
- CASE cod_const_push28: # (CONST&PUSH.S 28)
- pushSTACK(TheCclosure(closure)->clos_consts[28]);
- goto next_byte;
- CASE cod_const_push29: # (CONST&PUSH.S 29)
- pushSTACK(TheCclosure(closure)->clos_consts[29]);
- goto next_byte;
- #if 0
- CASE cod_const_push30: # (CONST&PUSH.S 30)
- pushSTACK(TheCclosure(closure)->clos_consts[30]);
- goto next_byte;
- CASE cod_const_push31: # (CONST&PUSH.S 31)
- pushSTACK(TheCclosure(closure)->clos_consts[31]);
- goto next_byte;
- CASE cod_const_push32: # (CONST&PUSH.S 32)
- pushSTACK(TheCclosure(closure)->clos_consts[32]);
- goto next_byte;
- #endif
- CASE cod_store0: # (STORE.S 0)
- STACK_(0) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store1: # (STORE.S 1)
- STACK_(1) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store2: # (STORE.S 2)
- STACK_(2) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store3: # (STORE.S 3)
- STACK_(3) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store4: # (STORE.S 4)
- STACK_(4) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store5: # (STORE.S 5)
- STACK_(5) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store6: # (STORE.S 6)
- STACK_(6) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store7: # (STORE.S 7)
- STACK_(7) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store8: # (STORE.S 8)
- STACK_(8) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store9: # (STORE.S 9)
- STACK_(9) = value1; mv_count=1;
- goto next_byte;
- #if 0
- CASE cod_store10: # (STORE.S 10)
- STACK_(10) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store11: # (STORE.S 11)
- STACK_(11) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store12: # (STORE.S 12)
- STACK_(12) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store13: # (STORE.S 13)
- STACK_(13) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store14: # (STORE.S 14)
- STACK_(14) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store15: # (STORE.S 15)
- STACK_(15) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store16: # (STORE.S 16)
- STACK_(16) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store17: # (STORE.S 17)
- STACK_(17) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store18: # (STORE.S 18)
- STACK_(18) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store19: # (STORE.S 19)
- STACK_(19) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store20: # (STORE.S 20)
- STACK_(20) = value1; mv_count=1;
- goto next_byte;
- CASE cod_store21: # (STORE.S 21)
- STACK_(21) = value1; mv_count=1;
- goto next_byte;
- #endif
- # ------------------- sonstiges -----------------------
- #ifndef FAST_DISPATCH
- default:
- #endif
- # undefinierter Code
- #if defined(GNU) && defined(FAST_SP)
- # -fomit-frame-pointer zunichte machen, damit
- # %sp bzw. %esp als private_SP verwendbar ist:
- alloca(1);
- #endif
- pushSTACK(fixnum(byteptr-&codeptr->data[0]-1)); # fehlerhafte Bytenummer
- pushSTACK(closure); # Closure
- //: DEUTSCH "Undefinierter Byte-Code in ~ bei Byte ~"
- //: ENGLISH "undefined bytecode in ~ at byte ~"
- //: FRANCAIS "Code octet indéfinissable ~ à l'octet ~"
- fehler(serious_condition, GETTEXT("undefined bytecode in ~ at byte ~"));
- #undef L_operand
- #undef S_operand
- #undef U_operand
- #undef B_operand
- #undef CASE
- }
- fehler_zuviele_werte:
- //: DEUTSCH "Zu viele Werte erzeugt."
- //: ENGLISH "too many return values"
- //: FRANCAIS "Trop de valeurs VALUES."
- fehler(error, GETTEXT("too many return values"));
- #if STACKCHECKC
- fehler_STACK_putt:
- pushSTACK(fixnum(byteptr-&codeptr->data[0])); # PC
- pushSTACK(closure); # FUNC
- //: DEUTSCH "Stack kaputt in ~ bei Byte ~"
- //: ENGLISH "Corrupted STACK in ~ at byte ~"
- //: FRANCAIS "Pile STACK corrompue dans ~ à l'octet ~"
- fehler(serious_condition, GETTEXT("Corrupted STACK in ~ at byte ~"));
- #endif
- finished:
- #undef FREE_JMPBUF_on_SP
- #undef JMPBUF_on_SP
- #ifndef FAST_SP
- FREE_DYNAMIC_ARRAY(private_SP_space);
- #endif
- return;
- }}}
-
-
- # wo ist check_SP() oder check_STACK() einzufügen??
- # soll nest_env sein Ziel-Environment übergeben bekommen??
- # Register-Allozierung in eval_subr und eval_cclosure usw.??
- # subr_self eliminieren??
-
-