From 09876a167242ecdaf9fcdb0b9a85ba50e27ee275 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 14 May 2025 12:57:34 +0200 Subject: [PATCH] nucleus: move function calling from apply.d and eval.d to call.d The file apply.d is effectively removed. --- src/c/Makefile.in | 4 +- src/c/{apply.d => call.d} | 94 ++++++++++++++++++++++++++--- src/c/eval.d | 121 -------------------------------------- 3 files changed, 87 insertions(+), 132 deletions(-) rename src/c/{apply.d => call.d} (95%) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 0b3688502..555b85e11 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h -NUCL_OBJS = +NUCL_OBJS = call.o CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o @@ -74,7 +74,7 @@ READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o -OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o \ +OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o \ compiler.o disassembler.o reference.o character.o file.o error.o \ string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o \ vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o \ diff --git a/src/c/apply.d b/src/c/call.d similarity index 95% rename from src/c/apply.d rename to src/c/call.d index 12a27e74e..de0f5c545 100644 --- a/src/c/apply.d +++ b/src/c/call.d @@ -1,18 +1,93 @@ /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ -/* - * apply.c - interface to C call mechanism - * - * Copyright (c) 1993 Giuseppe Attardi - * Copyright (c) 2001 Juan Jose Garcia Ripoll - * - * See file 'LICENSE' for the copyright details. - * - */ +/* dispatch.c - function application */ #include +#include #include +#include +#include + +cl_objectfn +ecl_function_dispatch(cl_env_ptr env, cl_object x) +{ + cl_object fun = x; + if (ecl_unlikely(fun == ECL_NIL)) + FEundefined_function(x); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; + case t_instance: + env->function = fun; + return fun->instance.entry; + case t_symbol: + fun = ECL_SYM_FUN(fun); + env->function = fun; + return fun->cfun.entry; + case t_bytecodes: + env->function = fun; + return fun->bytecodes.entry; + case t_bclosure: + env->function = fun; + return fun->bclosure.entry; + default: + FEinvalid_function(x); + } + _ecl_unexpected_return(); +} + +/* Calling conventions: + * Compiled C code calls lisp function supplying #args, and args. + * + * Linking function performs check_args, gets jmp_buf with _setjmp, then + * + * if cfun then stores C code address into function link location and transfers + * to jmp_buf at cf_self + + * if cclosure then replaces #args with cc_env and calls cc_self otherwise, it + * emulates funcall. + */ + +cl_object +ecl_apply_from_stack_frame(cl_object frame, cl_object x) +{ + cl_object *sp = ECL_STACK_FRAME_PTR(frame); + cl_index narg = frame->frame.size; + cl_env_ptr env = frame->frame.env; + cl_objectfn entry = ecl_function_dispatch(env, x); + cl_object ret; + env->stack_frame = frame; + ret = APPLY(narg, entry, sp); + env->stack_frame = NULL; + return ret; +} + +cl_object +cl_funcall(cl_narg narg, cl_object function, ...) +{ + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; +} + +cl_object * +_ecl_va_sp(cl_narg narg) +{ + return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; +} #if !(ECL_C_ARGUMENTS_LIMIT == 63) #error "Please adjust code to the constant!" @@ -658,4 +733,5 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) default: FEprogram_error("Too many arguments", 0); } + _ecl_unexpected_return(); } diff --git a/src/c/eval.d b/src/c/eval.d index 237f54660..b7d34a6a1 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -16,127 +16,6 @@ #include #include -cl_object * -_ecl_va_sp(cl_narg narg) -{ - return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; -} - -/* Calling conventions: - * Compiled C code calls lisp function supplying #args, and args. - * Linking function performs check_args, gets jmp_buf with _setjmp, then - * if cfun then stores C code address into function link location - * and transfers to jmp_buf at cf_self - * if cclosure then replaces #args with cc_env and calls cc_self - * otherwise, it emulates funcall. - */ - -cl_object -ecl_apply_from_stack_frame(cl_object frame, cl_object x) -{ - cl_object *sp = ECL_STACK_FRAME_PTR(frame); - cl_index narg = frame->frame.size; - cl_object fun = x; - cl_object ret; - frame->frame.env->stack_frame = frame; - AGAIN: - frame->frame.env->function = fun; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - break; - case t_cfun: - ret = APPLY(narg, fun->cfun.entry, sp); - break; - case t_cclosure: - ret = APPLY(narg, fun->cclosure.entry, sp); - break; - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - ret = _ecl_standard_dispatch(frame, fun); - break; - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - ret = APPLY(narg, fun->instance.entry, sp); - break; - default: - FEinvalid_function(fun); - } - break; - case t_symbol: - if (ecl_unlikely(!ECL_FBOUNDP(fun))) - FEundefined_function(fun); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - ret = ecl_interpret(frame, ECL_NIL, fun); - break; - case t_bclosure: - ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - break; - default: - FEinvalid_function(x); - } - frame->frame.env->stack_frame = NULL; /* for gc's sake */ - return ret; -} - -cl_objectfn -ecl_function_dispatch(cl_env_ptr env, cl_object x) -{ - cl_object fun = x; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; - case t_instance: - env->function = fun; - return fun->instance.entry; - case t_symbol: - fun = ECL_SYM_FUN(fun); - env->function = fun; - return fun->cfun.entry; - case t_bytecodes: - env->function = fun; - return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; - return fun->bclosure.entry; - default: - FEinvalid_function(x); - } -} - -cl_object -cl_funcall(cl_narg narg, cl_object function, ...) -{ - cl_object output; - --narg; - { - ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); - output = ecl_apply_from_stack_frame(frame, function); - ECL_STACK_FRAME_VARARGS_END(frame); - } - return output; -} - @(defun apply (fun lastarg &rest args) @ { if (narg == 2 && ecl_t_of(lastarg) == t_frame) {