aboutsummaryrefslogtreecommitdiffstats
path: root/tests/gpgscm/scheme.c
diff options
context:
space:
mode:
Diffstat (limited to 'tests/gpgscm/scheme.c')
-rw-r--r--tests/gpgscm/scheme.c141
1 files changed, 113 insertions, 28 deletions
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 47051f209..26bb5a5c2 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -139,7 +139,8 @@ enum scheme_types {
T_NIL = 17 << 1 | 1,
T_EOF_OBJ = 18 << 1 | 1,
T_SINK = 19 << 1 | 1,
- T_LAST_SYSTEM_TYPE = 19 << 1 | 1
+ T_FRAME = 20 << 1 | 1,
+ T_LAST_SYSTEM_TYPE = 20 << 1 | 1
};
static const char *
@@ -166,6 +167,7 @@ type_to_string (enum scheme_types typ)
case T_NIL: return "nil";
case T_EOF_OBJ: return "eof object";
case T_SINK: return "sink";
+ case T_FRAME: return "frame";
}
assert (! "not reached");
}
@@ -174,6 +176,7 @@ type_to_string (enum scheme_types typ)
#define TYPE_BITS 6
#define ADJ (1 << TYPE_BITS)
#define T_MASKTYPE (ADJ - 1)
+ /* 0000000000111111 */
#define T_TAGGED 1024 /* 0000010000000000 */
#define T_FINALIZE 2048 /* 0000100000000000 */
#define T_SYNTAX 4096 /* 0001000000000000 */
@@ -211,6 +214,7 @@ static const struct num num_one = { 1, {1} };
/* macros for cell operations */
#define typeflag(p) ((p)->_flag)
#define type(p) (typeflag(p)&T_MASKTYPE)
+#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ))
INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
#define strvalue(p) ((p)->_object._string._svalue)
@@ -299,6 +303,9 @@ INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
#define setenvironment(p) typeflag(p) = T_ENVIRONMENT
+INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); }
+#define setframe(p) settype(p, T_FRAME)
+
#define is_atom(p) (typeflag(p)&T_ATOM)
#define setatom(p) typeflag(p) |= T_ATOM
#define clratom(p) typeflag(p) &= CLRATOM
@@ -436,6 +443,7 @@ static pointer mk_continuation(scheme *sc, pointer d);
static pointer reverse(scheme *sc, pointer term, pointer list);
static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
static pointer revappend(scheme *sc, pointer a, pointer b);
+static void dump_stack_preallocate_frame(scheme *sc);
static void dump_stack_mark(scheme *);
struct op_code_info {
char name[31]; /* strlen ("call-with-current-continuation") + 1 */
@@ -867,7 +875,8 @@ gc_reservation_failure(struct scheme *sc)
"insufficient reservation\n")
#else
fprintf(stderr,
- "insufficient reservation in line %d\n",
+ "insufficient %s reservation in line %d\n",
+ sc->frame_freelist == sc->NIL ? "frame" : "cell",
sc->reserved_lineno);
#endif
abort();
@@ -893,7 +902,15 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno)
sc->inhibit_gc += 1;
}
#define gc_disable(sc, reserve) \
- _gc_disable (sc, reserve, __LINE__)
+ do { \
+ if (sc->frame_freelist == sc->NIL) { \
+ if (gc_enabled(sc)) \
+ dump_stack_preallocate_frame(sc); \
+ else \
+ gc_reservation_failure(sc); \
+ } \
+ _gc_disable (sc, reserve, __LINE__); \
+ } while (0)
/* Enable the garbage collector. */
#define gc_enable(sc) \
@@ -917,7 +934,12 @@ _gc_disable(struct scheme *sc, size_t reserve, int lineno)
#else /* USE_GC_LOCKING */
-#define gc_disable(sc, reserve) (void) 0
+#define gc_reservation_failure(sc) (void) 0
+#define gc_disable(sc, reserve) \
+ do { \
+ if (sc->frame_freelist == sc->NIL) \
+ dump_stack_preallocate_frame(sc); \
+ } while (0)
#define gc_enable(sc) (void) 0
#define gc_enabled(sc) 1
#define gc_consume(sc) (void) 0
@@ -1284,8 +1306,6 @@ INTERFACE pointer mk_character(scheme *sc, int c) {
#if USE_SMALL_INTEGERS
-/* s_save assumes that all opcodes can be expressed as a small
- * integer. */
static const struct cell small_integers[] = {
#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}},
#include "small-integers.h"
@@ -1599,6 +1619,9 @@ static pointer mk_sharp_const(scheme *sc, char *name) {
/* ========== garbage collector ========== */
+const int frame_length;
+static void dump_stack_deallocate_frame(scheme *sc, pointer frame);
+
/*--
* We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
* sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
@@ -1611,9 +1634,10 @@ static void mark(pointer a) {
p = a;
E2: if (! is_mark(p))
setmark(p);
- if(is_vector(p)) {
+ if (is_vector(p) || is_frame(p)) {
int i;
- for (i = 0; i < vector_length(p); i++) {
+ int len = is_vector(p) ? vector_length(p) : frame_length;
+ for (i = 0; i < len; i++) {
mark(p->_object._vector._elements[i]);
}
}
@@ -1783,8 +1807,12 @@ finalize_cell(scheme *sc, pointer a)
sc->free_cell = p;
sc->fcells += 1;
}
- break;
} while (0);
+ break;
+
+ case T_FRAME:
+ dump_stack_deallocate_frame(sc, a);
+ return 0; /* Do not free cell. */
}
return 1; /* Free cell. */
@@ -2985,17 +3013,73 @@ static INLINE void dump_stack_reset(scheme *sc)
static INLINE void dump_stack_initialize(scheme *sc)
{
dump_stack_reset(sc);
+ sc->frame_freelist = sc->NIL;
}
static void dump_stack_free(scheme *sc)
{
- sc->dump = sc->NIL;
+ dump_stack_initialize(sc);
+}
+
+const int frame_length = 4;
+
+static pointer
+dump_stack_make_frame(scheme *sc)
+{
+ pointer frame;
+
+ frame = mk_vector(sc, frame_length);
+ if (! sc->no_memory)
+ setframe(frame);
+
+ return frame;
+}
+
+static INLINE pointer *
+frame_slots(pointer frame)
+{
+ return &frame->_object._vector._elements[0];
+}
+
+#define frame_payload vector_length
+
+static pointer
+dump_stack_allocate_frame(scheme *sc)
+{
+ pointer frame = sc->frame_freelist;
+ if (frame == sc->NIL) {
+ if (gc_enabled(sc))
+ frame = dump_stack_make_frame(sc);
+ else
+ gc_reservation_failure(sc);
+ } else
+ sc->frame_freelist = *frame_slots(frame);
+ return frame;
+}
+
+static void
+dump_stack_deallocate_frame(scheme *sc, pointer frame)
+{
+ pointer *p = frame_slots(frame);
+ *p++ = sc->frame_freelist;
+ *p++ = sc->NIL;
+ *p++ = sc->NIL;
+ *p++ = sc->NIL;
+ sc->frame_freelist = frame;
+}
+
+static void
+dump_stack_preallocate_frame(scheme *sc)
+{
+ pointer frame = dump_stack_make_frame(sc);
+ if (! sc->no_memory)
+ dump_stack_deallocate_frame(sc, frame);
}
static enum scheme_opcodes
_s_return(scheme *sc, pointer a, int enable_gc) {
pointer dump = sc->dump;
- pointer op;
+ pointer *p;
unsigned long v;
enum scheme_opcodes next_op;
sc->value = (a);
@@ -3003,37 +3087,38 @@ _s_return(scheme *sc, pointer a, int enable_gc) {
gc_enable(sc);
if (dump == sc->NIL)
return OP_QUIT;
- free_cons(sc, dump, &op, &dump);
- v = (unsigned long) ivalue_unchecked(op);
+ v = frame_payload(dump);
next_op = (int) (v & S_OP_MASK);
sc->flags = v & S_FLAG_MASK;
-#ifdef USE_SMALL_INTEGERS
- if (v < MAX_SMALL_INTEGER) {
- /* This is a small integer, we must not free it. */
- } else
- /* Normal integer. Recover the cell. */
-#endif
- free_cell(sc, op);
- free_cons(sc, dump, &sc->args, &dump);
- free_cons(sc, dump, &sc->envir, &dump);
- free_cons(sc, dump, &sc->code, &sc->dump);
+ p = frame_slots(dump);
+ sc->args = *p++;
+ sc->envir = *p++;
+ sc->code = *p++;
+ sc->dump = *p++;
+ dump_stack_deallocate_frame(sc, dump);
return next_op;
}
static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-#define s_save_allocates 5
+#define s_save_allocates 0
pointer dump;
- unsigned long v = sc->flags | ((unsigned long) op);
+ pointer *p;
gc_disable(sc, gc_reservations (s_save));
- dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
- dump = cons(sc, (args), dump);
- sc->dump = cons(sc, mk_integer(sc, (long) v), dump);
+ dump = dump_stack_allocate_frame(sc);
+ frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op);
+ p = frame_slots(dump);
+ *p++ = args;
+ *p++ = sc->envir;
+ *p++ = code;
+ *p++ = sc->dump;
+ sc->dump = dump;
gc_enable(sc);
}
static INLINE void dump_stack_mark(scheme *sc)
{
mark(sc->dump);
+ mark(sc->frame_freelist);
}
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-27 22:25:18 +0000