/* -*-C-*-
-$Id: cmpint.c,v 1.100 2003/02/14 18:28:18 cph Exp $
+$Id: cmpint.c,v 1.101 2003/05/17 20:55:31 cph Exp $
-Copyright (c) 1989-2002 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
+Copyright 1995,1996,2000,2001,2002,2003 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
#ifdef HAS_COMPILER_SUPPORT
\f
-/* ASM_ENTRY_POINT, EXFNX, and DEFNX are for OS/2. The IBM C Set++/2
+/* ASM_ENTRY_POINT and EXFNX are for OS/2. The IBM C Set++/2
compiler has several different external calling conventions. The
default calling convention is called _Optlink, uses a combination
of registers and the stack, and is complicated. The calling
# define ASM_ENTRY_POINT(name) name
#endif
-#ifdef STDC_HEADERS
-#define EXFNX(name, proto) ASM_ENTRY_POINT (name) proto
-#define DEFNX(name, arglist, args) ASM_ENTRY_POINT (name) (args)
-#define DEFNX_VOID(name) ASM_ENTRY_POINT (name) (void)
-#else
-#define EXFNX(name, proto) ASM_ENTRY_POINT (name) ()
-#define DEFNX(name, arglist, args) ASM_ENTRY_POINT (name) arglist args;
-#define DEFNX_VOID(name) ASM_ENTRY_POINT (name) ()
-#endif
+#define EXFNX(name, proto) EXFUN (ASM_ENTRY_POINT (name), proto)
/* Make noise words invisible to the C compiler. */
#define C_UTILITY
#define C_TO_SCHEME
-#define SCHEME_UTILITY
+
+#define DEFINE_SCHEME_UTILITY_0(pname) \
+void \
+DEFUN (ASM_ENTRY_POINT (pname), \
+ (DSU_result, ignore1, ignore2, ignore3, ignore4), \
+ utility_result * DSU_result \
+ AND long ignore1 \
+ AND long ignore2 \
+ AND long ignore3 \
+ AND long ignore4)
+
+#define DEFINE_SCHEME_UTILITY_1(pname, av1) \
+void \
+DEFUN (ASM_ENTRY_POINT (pname), \
+ (DSU_result, av1, ignore2, ignore3, ignore4), \
+ utility_result * DSU_result \
+ AND long av1 \
+ AND long ignore2 \
+ AND long ignore3 \
+ AND long ignore4)
+
+#define DEFINE_SCHEME_UTILITY_2(pname, av1, av2) \
+void \
+DEFUN (ASM_ENTRY_POINT (pname), \
+ (DSU_result, av1, av2, ignore3, ignore4), \
+ utility_result * DSU_result \
+ AND long av1 \
+ AND long av2 \
+ AND long ignore3 \
+ AND long ignore4)
+
+#define DEFINE_SCHEME_UTILITY_3(pname, av1, av2, av3) \
+void \
+DEFUN (ASM_ENTRY_POINT (pname), \
+ (DSU_result, av1, av2, av3, ignore4), \
+ utility_result * DSU_result \
+ AND long av1 \
+ AND long av2 \
+ AND long av3 \
+ AND long ignore4)
+
+#define DEFINE_SCHEME_UTILITY_4(pname, av1, av2, av3, av4) \
+void \
+DEFUN (ASM_ENTRY_POINT (pname), \
+ (DSU_result, av1, av2, av3, av4), \
+ utility_result * DSU_result \
+ AND long av1 \
+ AND long av2 \
+ AND long av3 \
+ AND long av4)
/* For clarity */
typedef char instruction;
+\f
+#ifdef CMPINT_USE_STRUCS
+
+#ifdef C_FUNC_PTR_IS_CLOSURE
+# define REFENTRY(name) (name)
+# define VARENTRY(name) instruction * name
+# define EXTENTRY(name) extern instruction * name
+#else
+# define REFENTRY(name) ((void EXFUN ((*), (void))) name)
+# define VARENTRY(name) void EXFUN ((*name), (void))
+# define EXTENTRY(name) extern void EXFNX (name, (void))
+#endif
-#ifndef CMPINT_USE_STRUCS
+/* Structure returned by SCHEME_UTILITYs */
-typedef instruction * utility_result;
+typedef struct
+{
+ VARENTRY (interface_dispatch);
+ union additional_info
+ {
+ long code_to_interpreter;
+ instruction * entry_point;
+ } extra;
+} utility_result;
/* Imports from assembly language */
-extern void EXFNX (C_to_interface, (void *));
-extern utility_result interface_to_C_hook;
+extern long EXFNX (C_to_interface, (PTR));
-extern long C_return_value;
-long C_return_value;
+EXTENTRY (interface_to_C);
+EXTENTRY (interface_to_scheme);
/* Convenience macros */
#define RETURN_TO_C(code) do \
{ \
- C_return_value = (code); \
- return (interface_to_C_hook); \
-} while (false)
-
-#define RETURN_TO_SCHEME(ep) return ((utility_result) (ep))
+ (DSU_result -> interface_dispatch) = (REFENTRY (interface_to_C)); \
+ ((DSU_result -> extra) . code_to_interpreter) = (code); \
+ return; \
+} while (0)
-#define ENTER_SCHEME(ep) do \
+#define RETURN_TO_SCHEME(ep) do \
{ \
- C_to_interface ((void *) (ep)); \
- return (C_return_value); \
-} while (false)
-
-#else /* CMPINT_USE_STRUCS */
-\f
-#ifdef C_FUNC_PTR_IS_CLOSURE
-# define REFENTRY(name) (name)
-# define VARENTRY(name) instruction *name
-# define EXTENTRY(name) extern instruction *name
-#else
-# define REFENTRY(name) ((void (*)()) name)
-# define VARENTRY(name) void (*name)()
-# define EXTENTRY(name) extern void EXFNX (name, (void))
-#endif
+ (DSU_result -> interface_dispatch) \
+ = (REFENTRY (interface_to_scheme)); \
+ ((DSU_result -> extra) . entry_point) \
+ = ((instruction *) (ep)); \
+ return; \
+} while (0)
-/* Structure returned by SCHEME_UTILITYs */
+#define ENTER_SCHEME(ep) return (C_to_interface ((PTR) (ep)))
-struct utility_result_s
-{
- VARENTRY (interface_dispatch);
- union additional_info
- {
- long code_to_interpreter;
- instruction *entry_point;
- } extra;
-};
+#else /* CMPINT_USE_STRUCS */
-typedef struct utility_result_s utility_result;
+typedef instruction * utility_result;
/* Imports from assembly language */
-extern long EXFNX (C_to_interface, (void *));
+extern void EXFNX (C_to_interface, (PTR));
+extern utility_result interface_to_C_hook;
-EXTENTRY (interface_to_C);
-EXTENTRY (interface_to_scheme);
+extern long C_return_value;
+long C_return_value;
/* Convenience macros */
#define RETURN_TO_C(code) do \
{ \
- struct utility_result_s temp; \
- \
- temp.interface_dispatch = (REFENTRY (interface_to_C)); \
- temp.extra.code_to_interpreter = (code); \
- \
- return (temp); \
-} while (false)
+ (*DSU_result) = interface_to_C_hook; \
+ C_return_value = (code); \
+ return; \
+} while (0)
#define RETURN_TO_SCHEME(ep) do \
{ \
- struct utility_result_s temp; \
- \
- temp.interface_dispatch = (REFENTRY (interface_to_scheme)); \
- temp.extra.entry_point = ((instruction *) (ep)); \
- \
- return (temp); \
-} while (false)
+ (*DSU_result) = (ep); \
+ return; \
+} while (0)
-#define ENTER_SCHEME(ep) return (C_to_interface ((void *) (ep)))
+#define ENTER_SCHEME(ep) do \
+{ \
+ C_to_interface ((PTR) (ep)); \
+ return (C_return_value); \
+} while (0)
-#endif /* CMPINT_USE_STRUCS */
+#endif /* not CMPINT_USE_STRUCS */
\f
/* utility table entries. */
-typedef utility_result EXFUN
- ((*ASM_ENTRY_POINT(utility_table_entry)), (long, long, long, long));
+typedef void EXFUN
+ ((* (ASM_ENTRY_POINT (utility_table_entry))),
+ (utility_result *, long, long, long, long));
-#define RETURN_UNLESS_EXCEPTION(code, entry_point) \
-{ \
- int return_code; \
- \
- return_code = (code); \
- if (return_code == PRIM_DONE) \
- { \
- RETURN_TO_SCHEME (entry_point); \
- } \
- else \
- { \
- RETURN_TO_C (return_code); \
- } \
-}
+#define RETURN_UNLESS_EXCEPTION(code, entry_point) do \
+{ \
+ int return_code = (code); \
+ if (return_code == PRIM_DONE) \
+ { \
+ RETURN_TO_SCHEME (entry_point); \
+ } \
+ else \
+ { \
+ RETURN_TO_C (return_code); \
+ } \
+} while (0)
+
+#define TAIL_CALL_1(pname, a1) do \
+{ \
+ pname (DSU_result, (a1), 0, 0, 0); \
+ return; \
+} while (0)
+
+#define TAIL_CALL_2(pname, a1, a2) do \
+{ \
+ pname (DSU_result, (a1), (a2), 0, 0); \
+ return; \
+} while (0)
#define MAKE_CC_BLOCK(block_addr) \
(MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_addr))
trampoline storage block (empty) to it.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_return_to_interpreter,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_return_to_interpreter, tramp_data_raw)
{
RETURN_TO_C (PRIM_DONE);
}
#else /* COMPILER_IA32_TYPE */
-static utility_result
- EXFUN (compiler_interrupt_common, (SCHEME_ADDR, SCHEME_OBJECT));
+static void EXFUN
+ (compiler_interrupt_common, (utility_result *, SCHEME_ADDR, SCHEME_OBJECT));
+
+#define COMPILER_INTERRUPT_COMMON(a1, a2) do \
+{ \
+ compiler_interrupt_common (DSU_result, (a1), (a2)); \
+ return; \
+} while (0)
#define INVOKE_RETURN_ADDRESS() do \
{ \
if (((long) (ADDR_TO_SCHEME_ADDR (Free))) \
>= ((long) (Registers[REGBLOCK_MEMTOP]))) \
- return (compiler_interrupt_common (0, val_register)); \
+ COMPILER_INTERRUPT_COMMON (0, val_register); \
else \
RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ())); \
} while (0)
of the stack.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_primitive_apply,
- (primitive, ignore_2, ignore_3, ignore_4),
- SCHEME_OBJECT primitive
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_primitive_apply, primitive)
{
PRIMITIVE_APPLY (val_register, primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
of the register block.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_primitive_lexpr_apply,
- (primitive, ignore_2, ignore_3, ignore_4),
- SCHEME_OBJECT primitive
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_primitive_lexpr_apply, primitive)
{
PRIMITIVE_APPLY (val_register, primitive);
POP_PRIMITIVE_FRAME (((long) (Registers[REGBLOCK_LEXPR_ACTUALS])));
expects the procedure to invoke, and the number of arguments (+ 1).
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_apply,
- (procedure, nactuals, ignore_3, ignore_4),
- SCHEME_OBJECT procedure
- AND unsigned long nactuals
- AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_2 (comutil_apply, procedure, nactuals)
{
SCHEME_OBJECT orig_proc = procedure;
arity = (PRIMITIVE_ARITY (procedure));
if (arity == ((long) (nactuals - 1)))
- return (comutil_primitive_apply (procedure, 0, 0, 0));
+ TAIL_CALL_1 (comutil_primitive_apply, procedure);
if (arity != LEXPR)
{
/* "Lexpr" primitive. */
(Registers[REGBLOCK_LEXPR_ACTUALS]) = ((SCHEME_OBJECT) (nactuals - 1));
- return (comutil_primitive_lexpr_apply (procedure, 0, 0, 0));
+ TAIL_CALL_1 (comutil_primitive_lexpr_apply, procedure);
}
callee_is_interpreted:
stack, and is passed the number of arguments (+ 1).
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_error,
- (nactuals, ignore_2, ignore_3, ignore_4),
- long nactuals AND
- long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_error, nactuals)
{
- SCHEME_OBJECT error_procedure;
-
- error_procedure = (Get_Fixed_Obj_Slot (Compiler_Err_Procedure));
- return (comutil_apply (error_procedure, nactuals, 0, 0));
+ TAIL_CALL_2
+ (comutil_apply, (Get_Fixed_Obj_Slot (Compiler_Err_Procedure)), nactuals);
}
/*
number of arguments (the compiler checked it), and will not check.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_lexpr_apply,
- (entry_address_raw, nactuals, ignore_3, ignore_4),
- SCHEME_ADDR entry_address_raw AND long nactuals
- AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_2 (comutil_lexpr_apply, entry_address_raw, nactuals)
{
instruction * entry_address
= ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_address_raw)));
processing is done.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_link,
- (ret_add_raw, block_address_raw, constant_address_raw, sections),
- SCHEME_ADDR ret_add_raw
- AND SCHEME_ADDR block_address_raw
- AND SCHEME_ADDR constant_address_raw
- AND long sections)
+DEFINE_SCHEME_UTILITY_4 (comutil_link, ret_add_raw, block_address_raw,
+ constant_address_raw, sections)
{
instruction * ret_add
= ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));
with.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_apply_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_apply_trap, tramp_data_raw)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
/* Used by coerce_to_compiled. TRAMPOLINE_K_APPLY */
-
- return (comutil_apply ((tramp_data[0]),
- (OBJECT_DATUM (tramp_data[1])),
- 0, 0));
+ SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+ TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_arity_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_arity_trap, tramp_data_raw)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
/* Linker saw an argument count mismatch. TRAMPOLINE_K_ARITY */
-
- return (comutil_apply ((tramp_data[0]),
- (OBJECT_DATUM (tramp_data[1])),
- 0, 0));
+ SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+ TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_entity_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_entity_trap, tramp_data_raw)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
/* Linker saw an entity to be applied. TRAMPOLINE_K_ENTITY */
-
- return (comutil_apply ((tramp_data[0]),
- (OBJECT_DATUM (tramp_data[1])),
- 0, 0));
+ SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+ TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
}
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_interpreted_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_interpreted_trap, tramp_data_raw)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
/* Linker saw an interpreted procedure or a procedure that it cannot
- link directly. TRAMPOLINE_K_INTERPRETED
- */
-
- return (comutil_apply ((tramp_data[0]),
- (OBJECT_DATUM (tramp_data[1])),
- 0, 0));
+ link directly. TRAMPOLINE_K_INTERPRETED */
+ SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+ TAIL_CALL_2 (comutil_apply, (tramp_data[0]), (OBJECT_DATUM (tramp_data[1])));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_lexpr_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_lexpr_trap, tramp_data_raw)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
/* Linker saw a primitive of arbitrary number of arguments.
- TRAMPOLINE_K_LEXPR_PRIMITIVE
- */
-
+ TRAMPOLINE_K_LEXPR_PRIMITIVE */
+ SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
(Registers[REGBLOCK_LEXPR_ACTUALS]) =
((SCHEME_OBJECT) ((OBJECT_DATUM (tramp_data[1])) - 1));
- return (comutil_primitive_lexpr_apply ((tramp_data[0]), 0, 0, 0));
+ TAIL_CALL_1 (comutil_primitive_lexpr_apply, (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_primitive_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_primitive_trap, tramp_data_raw)
{
- SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
/* Linker saw a primitive of fixed matching arity. TRAMPOLINE_K_PRIMITIVE */
-
- return (comutil_primitive_apply ((tramp_data[0]), 0, 0, 0));
+ SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
+ TAIL_CALL_1 (comutil_primitive_apply, (tramp_data[0]));
}
\f
/* The linker either couldn't find a binding or the binding was
tramp_data contains extension, code_block, offset. TRAMPOLINE_K_LOOKUP
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_lookup_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw AND
- long ignore_2 AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_lookup_trap, tramp_data_raw)
{
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
SCHEME_OBJECT cache = (tramp_data[0]);
EXTRACT_EXECUTE_CACHE_ARITY (nargs, cache_cell);
if (code == PRIM_DONE)
- return (comutil_apply (true_operator, nargs, 0, 0));
+ TAIL_CALL_2 (comutil_apply, true_operator, nargs);
/* Error or interrupt */
{
SCHEME_OBJECT trampoline;
Scheme stack.
*/
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_1_0_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_1_0_trap, tramp_data_raw)
{
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_2_1_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_2_1_trap, tramp_data_raw)
{
SCHEME_OBJECT Top;
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_2_0_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_2_0_trap, tramp_data_raw)
{
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_3_2_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_2_trap, tramp_data_raw)
{
SCHEME_OBJECT Top, Next;
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_3_1_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_1_trap, tramp_data_raw)
{
SCHEME_OBJECT Top;
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_3_0_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_3_0_trap, tramp_data_raw)
{
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_4_3_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_3_trap, tramp_data_raw)
{
SCHEME_OBJECT Top, Middle, Bottom;
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_4_2_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_2_trap, tramp_data_raw)
{
SCHEME_OBJECT Top, Next;
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_4_1_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_1_trap, tramp_data_raw)
{
SCHEME_OBJECT Top;
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
RETURN_TO_SCHEME (OBJECT_ADDRESS (tramp_data[0]));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_operator_4_0_trap,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_operator_4_0_trap, tramp_data_raw)
{
SCHEME_OBJECT * tramp_data = (SCHEME_ADDR_TO_ADDR (tramp_data_raw));
-
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
STACK_PUSH (UNASSIGNED_OBJECT);
REQUEST_INTERRUPT (INT_Stack_Overflow); \
}
-static utility_result
-DEFUN (compiler_interrupt_common, (entry_point_raw, state),
- SCHEME_ADDR entry_point_raw AND
- SCHEME_OBJECT state)
+static void
+DEFUN (compiler_interrupt_common, (DSU_result, entry_point_raw, state),
+ utility_result * DSU_result
+ AND SCHEME_ADDR entry_point_raw
+ AND SCHEME_OBJECT state)
{
MAYBE_REQUEST_INTERRUPTS ();
if (entry_point_raw != ((SCHEME_ADDR) 0))
- {
- instruction * entry_point
- = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
- STACK_PUSH (ENTRY_TO_OBJECT (entry_point));
- }
+ {
+ instruction * entry_point
+ = ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
+ STACK_PUSH (ENTRY_TO_OBJECT (entry_point));
+ }
STACK_PUSH (state);
exp_register = SHARP_F;
Store_Return (RC_COMP_INTERRUPT_RESTART);
RETURN_TO_C (PRIM_INTERRUPT);
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_interrupt_closure, (ignore_1, ignore_2, ignore_3, ignore_4),
- long ignore_1 AND
- long ignore_2 AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_closure)
{
- return (compiler_interrupt_common (0, SHARP_F));
+ COMPILER_INTERRUPT_COMMON (0, SHARP_F);
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_interrupt_dlink,
- (entry_point_raw, dlink_raw, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw AND
- SCHEME_ADDR dlink_raw AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_2 (comutil_interrupt_dlink, entry_point_raw, dlink_raw)
{
SCHEME_OBJECT * dlink = (SCHEME_ADDR_TO_ADDR (dlink_raw));
- return
- (compiler_interrupt_common
- (entry_point_raw, (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, dlink))));
+ COMPILER_INTERRUPT_COMMON
+ (((PTR) entry_point_raw),
+ (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, dlink)));
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_interrupt_procedure,
- (entry_point_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw AND
- long ignore_2 AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_procedure, entry_point_raw)
{
- return (compiler_interrupt_common (entry_point_raw, SHARP_F));
+ COMPILER_INTERRUPT_COMMON (((PTR) entry_point_raw), SHARP_F);
}
/* val_register has live data, and there is no entry address on the stack */
-SCHEME_UTILITY utility_result
-DEFNX (comutil_interrupt_continuation,
- (return_address_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR return_address_raw AND
- long ignore_2 AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_continuation, return_address_raw)
{
- return (compiler_interrupt_common (return_address_raw, val_register));
+ COMPILER_INTERRUPT_COMMON (((PTR) return_address_raw), val_register);
}
/* env_register has live data; no entry point on the stack */
-SCHEME_UTILITY utility_result
-DEFNX (comutil_interrupt_ic_procedure,
- (entry_point_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw AND
- long ignore_2 AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_interrupt_ic_procedure, entry_point_raw)
{
- return (compiler_interrupt_common (entry_point_raw, env_register));
+ COMPILER_INTERRUPT_COMMON (((PTR) entry_point_raw), env_register);
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_interrupt_continuation_2,
- (ignore_1, ignore_2, ignore_3, ignore_4),
- long ignore_1 AND
- long ignore_2 AND
- long ignore_3 AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_0 (comutil_interrupt_continuation_2)
{
- return (compiler_interrupt_common (0, val_register));
+ COMPILER_INTERRUPT_COMMON (0, val_register);
}
C_TO_SCHEME long
/* Assigning a variable that has a trap in it (except unassigned) */
-SCHEME_UTILITY utility_result
-DEFNX (comutil_assignment_trap,
- (return_address_raw, cache_addr_raw, value, ignore_4),
- SCHEME_ADDR return_address_raw AND
- SCHEME_ADDR cache_addr_raw AND
- SCHEME_OBJECT value AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_3 (comutil_assignment_trap,
+ return_address_raw, cache_addr_raw, value)
{
instruction * return_address
= ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw)));
}
}
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_cache_lookup_apply,
- (cache_addr_raw, block_address_raw, nactuals, ignore_4),
- SCHEME_ADDR cache_addr_raw AND
- SCHEME_ADDR block_address_raw AND
- long nactuals AND
- long ignore_4)
+DEFINE_SCHEME_UTILITY_3 (comutil_cache_lookup_apply,
+ cache_addr_raw, block_address_raw, nactuals)
{
SCHEME_OBJECT cache
= (MAKE_POINTER_OBJECT
SCHEME_OBJECT value;
long code = (compiler_lookup_trap (cache, (&value)));
if (code == PRIM_DONE)
- return (comutil_apply (value, nactuals, 0, 0));
+ TAIL_CALL_2 (comutil_apply, value, nactuals);
{
SCHEME_OBJECT block
= (MAKE_CC_BLOCK (SCHEME_ADDR_TO_ADDR (block_address_raw)));
fluid or an error (unassigned / unbound). */
#define CMPLR_REF_TRAP(name, c_trap, ret_code, restart, c_lookup) \
-SCHEME_UTILITY utility_result \
-DEFNX (name, \
- (return_address_raw, cache_addr_raw, ignore_3, ignore_4), \
- SCHEME_ADDR return_address_raw AND \
- SCHEME_ADDR cache_addr_raw AND \
- long ignore_3 AND \
- long ignore_4) \
+DEFINE_SCHEME_UTILITY_2 (name, return_address_raw, cache_addr_raw) \
{ \
instruction * return_address \
= ((instruction *) (SCHEME_ADDR_TO_ADDR (return_address_raw))); \
*/
#define COMPILER_ARITH_PRIM(name, fobj_index, arity) \
-SCHEME_UTILITY utility_result \
-DEFNX (name, \
- (ignore_1, ignore_2, ignore_3, ignore_4), \
- long ignore_1 AND long ignore_2 \
- AND long ignore_3 AND long ignore_4) \
+DEFINE_SCHEME_UTILITY_0 (name) \
{ \
- SCHEME_OBJECT handler; \
- \
- handler = (Get_Fixed_Obj_Slot (fobj_index)); \
- return (comutil_apply (handler, (arity), 0, 0)); \
+ TAIL_CALL_2 \
+ (comutil_apply, (Get_Fixed_Obj_Slot (fobj_index)), (arity)); \
}
COMPILER_ARITH_PRIM (comutil_decrement, GENERIC_TRAMPOLINE_PREDECESSOR, 2)
*/
#define CMPLR_REFERENCE(util_name, c_proc, ret_code, restart_name) \
-SCHEME_UTILITY utility_result \
-DEFNX (util_name, \
- (ret_add_raw, environment, variable, ignore_4), \
- SCHEME_ADDR ret_add_raw \
- AND SCHEME_OBJECT environment AND SCHEME_OBJECT variable \
- AND long ignore_4) \
+DEFINE_SCHEME_UTILITY_3 (util_name, ret_add_raw, environment, variable) \
{ \
instruction * ret_add \
= ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \
- long code; \
- \
- code = (c_proc (environment, variable, (&val_register))); \
+ long code = (c_proc (environment, variable, (&val_register))); \
if (code == PRIM_DONE) \
- { \
- RETURN_TO_SCHEME (ret_add); \
- } \
+ { \
+ RETURN_TO_SCHEME (ret_add); \
+ } \
else \
- { \
- STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \
- STACK_PUSH (variable); \
- STACK_PUSH (environment); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- RETURN_TO_C (code); \
- } \
+ { \
+ STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \
+ STACK_PUSH (variable); \
+ STACK_PUSH (environment); \
+ exp_register = SHARP_F; \
+ Store_Return (ret_code); \
+ Save_Cont (); \
+ RETURN_TO_C (code); \
+ } \
} \
\
C_TO_SCHEME long \
}
\f
#define CMPLR_ASSIGNMENT(util_name, c_proc, ret_code, restart_name) \
-SCHEME_UTILITY utility_result \
-DEFNX (util_name, \
- (ret_add_raw, environment, variable, value), \
- SCHEME_ADDR ret_add_raw \
- AND SCHEME_OBJECT environment \
- AND SCHEME_OBJECT variable \
- AND SCHEME_OBJECT value) \
+DEFINE_SCHEME_UTILITY_4 (util_name, \
+ ret_add_raw, environment, variable, value) \
{ \
instruction * ret_add \
= ((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw))); \
- long code; \
- \
- code = (c_proc (environment, variable, value)); \
+ long code = (c_proc (environment, variable, value)); \
if (code == PRIM_DONE) \
RETURN_TO_SCHEME (ret_add); \
else \
- { \
- STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \
- STACK_PUSH (value); \
- STACK_PUSH (variable); \
- STACK_PUSH (environment); \
- exp_register = SHARP_F; \
- Store_Return (ret_code); \
- Save_Cont (); \
- RETURN_TO_C (code); \
- } \
+ { \
+ STACK_PUSH (ENTRY_TO_OBJECT (ret_add)); \
+ STACK_PUSH (value); \
+ STACK_PUSH (variable); \
+ STACK_PUSH (environment); \
+ exp_register = SHARP_F; \
+ Store_Return (ret_code); \
+ Save_Cont (); \
+ RETURN_TO_C (code); \
+ } \
} \
\
C_TO_SCHEME long \
RC_COMP_DEFINITION_RESTART,
comp_definition_restart)
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_lookup_apply,
- (environment, variable, nactuals, ignore_4),
- SCHEME_OBJECT environment AND SCHEME_OBJECT variable
- AND long nactuals AND long ignore_4)
+DEFINE_SCHEME_UTILITY_3 (comutil_lookup_apply, environment, variable, nactuals)
{
long code = (lookup_variable (environment, variable, (&val_register)));
if (code == PRIM_DONE)
- return (comutil_apply (val_register, nactuals, 0, 0));
+ TAIL_CALL_2 (comutil_apply, val_register, nactuals);
{
STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals));
STACK_PUSH (variable);
}
}
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_primitive_error,
- (ret_add_raw, primitive, ignore_3, ignore_4),
- SCHEME_ADDR ret_add_raw
- AND SCHEME_OBJECT primitive
- AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_2 (comutil_primitive_error, ret_add_raw, primitive)
{
instruction * ret_add =
((instruction *) (SCHEME_ADDR_TO_ADDR (ret_add_raw)));
}
#endif /* HAVE_BKPT_SUPPORT */
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_compiled_code_bkpt,
- (entry_point_raw, state_raw, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw AND SCHEME_ADDR state_raw
- AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_2 (comutil_compiled_code_bkpt,
+ entry_point_raw, state_raw)
{
long type_info[3];
instruction * entry_point_a
compiled_entry_type (entry_point, &type_info[0]);
if ((type_info[0] == KIND_OTHER) && (type_info[1] == OTHER_CLOSURE))
- {
- entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw)));
- state = (ENTRY_TO_OBJECT (entry_point_a));
- }
+ {
+ entry_point_a = ((instruction *) (SCHEME_ADDR_TO_ADDR (state_raw)));
+ state = (ENTRY_TO_OBJECT (entry_point_a));
+ }
else if (type_info[0] != KIND_CONTINUATION)
state = SHARP_F;
else if (type_info[1] == CONTINUATION_DYNAMIC_LINK)
STACK_PUSH (state); /* state to preserve */
STACK_PUSH (stack_ptr); /* "Environment" pointer */
STACK_PUSH (entry_point); /* argument to handler */
- return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
- 4, ignore_3, ignore_4));
+ TAIL_CALL_2
+ (comutil_apply, (Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)), 4);
}
-SCHEME_UTILITY utility_result
-DEFNX (comutil_compiled_closure_bkpt,
- (entry_point_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR entry_point_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_compiled_closure_bkpt, entry_point_raw)
{
instruction * entry_point_a
= ((instruction *) (SCHEME_ADDR_TO_ADDR (entry_point_raw)));
STACK_PUSH (SHARP_F); /* state to preserve */
STACK_PUSH (stack_ptr); /* "Environment" pointer */
STACK_PUSH (entry_point); /* argument to handler */
- return (comutil_apply ((Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)),
- 4, ignore_3, ignore_4));
+ TAIL_CALL_2
+ (comutil_apply, (Get_Fixed_Obj_Slot (COMPILED_CODE_BKPT_HANDLER)), 4);
}
\f
-SCHEME_UTILITY utility_result
-DEFNX (comutil_reflect_to_interface,
- (tramp_data_raw, ignore_2, ignore_3, ignore_4),
- SCHEME_ADDR tramp_data_raw
- AND long ignore_2 AND long ignore_3 AND long ignore_4)
+DEFINE_SCHEME_UTILITY_1 (comutil_reflect_to_interface, tramp_data_raw)
{
SCHEME_OBJECT code = (STACK_POP ());
{
long frame_size = (OBJECT_DATUM (STACK_POP ()));
SCHEME_OBJECT procedure = (STACK_POP ());
-
- return (comutil_apply (procedure, frame_size, ignore_3, ignore_4));
+ TAIL_CALL_2 (comutil_apply, procedure, frame_size);
}
case REFLECT_CODE_RESTORE_INTERRUPT_MASK:
{
STACK_PUSH (FIXNUM_ZERO + REFLECT_CODE_CC_BKPT);
STACK_PUSH (reflect_to_interface);
- return (compiler_interrupt_common (0, SHARP_F));
+ COMPILER_INTERRUPT_COMMON (0, SHARP_F);
}
if (do_bkpt_proceed (& value))
projects / mit-scheme.git / commitdiff