1 /* weak.c -- weak pointers and ephemerons */
2 /* Copyright (c) 2010-2013 Alex Shinn. All rights reserved. */
3 /* BSD-style license: http://synthcode.com/license.txt */
4
5 #include <chibi/eval.h>
6
sexp_ephemeron_brokenp_op(sexp ctx,sexp self,sexp_sint_t n,sexp eph)7 sexp sexp_ephemeron_brokenp_op (sexp ctx, sexp self, sexp_sint_t n, sexp eph) {
8 if (! (sexp_pointerp(eph) && (sexp_pointer_tag(eph) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
9 return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), eph);
10 return sexp_make_boolean(sexp_brokenp(eph));
11 }
12
13 #if 0
14 #define sexp_weak_vector_p(x) sexp_check_tag(x, sexp_weak_vector_id)
15
16 sexp sexp_make_weak_vector (sexp ctx, sexp self, sexp_sint_t n, sexp len) {
17 sexp vec, *x;
18 int i, clen = sexp_unbox_fixnum(len);
19 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, len);
20 vec = sexp_alloc_tagged(ctx, sexp_sizeof(vector) + clen*sizeof(sexp),
21 sexp_unbox_fixnum(sexp_opcode_return_type(self)));
22 if (sexp_exceptionp(vec)) return vec;
23 x = sexp_vector_data(vec);
24 for (i=0; i<clen; i++)
25 x[i] = SEXP_VOID;
26 sexp_vector_length(vec) = clen;
27 return vec;
28 }
29
30 sexp sexp_weak_vector_length (sexp ctx, sexp self, sexp_sint_t n, sexp v) {
31 if (! (sexp_pointerp(v) && (sexp_pointer_tag(v) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
32 return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), v);
33 return sexp_make_fixnum(sexp_vector_length(v));
34 }
35
36 sexp sexp_weak_vector_ref (sexp ctx, sexp self, sexp_sint_t n, sexp v, sexp k) {
37 if (! (sexp_pointerp(v) && (sexp_pointer_tag(v) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
38 return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), v);
39 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, k);
40 return sexp_vector_ref(v, k);
41 }
42
43 sexp sexp_weak_vector_set (sexp ctx, sexp self, sexp_sint_t n, sexp v, sexp k, sexp x) {
44 if (! (sexp_pointerp(v) && (sexp_pointer_tag(v) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
45 return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), v);
46 sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, k);
47 sexp_vector_set(v, k, x);
48 return SEXP_VOID;
49 }
50 #endif
51
sexp_init_library(sexp ctx,sexp self,sexp_sint_t n,sexp env,const char * version,const sexp_abi_identifier_t abi)52 sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
53 #if 0
54 sexp v;
55 int sexp_weak_vector_id;
56 #endif
57 sexp_gc_var3(name, t, op);
58 if (!(sexp_version_compatible(ctx, version, sexp_version)
59 && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
60 return SEXP_ABI_ERROR;
61 sexp_gc_preserve3(ctx, name, t, op);
62
63 #if SEXP_USE_WEAK_REFERENCES
64 t = sexp_make_fixnum(SEXP_EPHEMERON);
65 op = sexp_make_type_predicate(ctx, name=sexp_c_string(ctx,"ephemeron?",-1), t);
66 sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron?", -1), op);
67 op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-key", -1), t, SEXP_ZERO);
68 sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-key", -1), op);
69 op = sexp_make_getter(ctx, name=sexp_c_string(ctx, "ephemeron-value", -1), t, SEXP_ONE);
70 sexp_env_define(ctx, env, name=sexp_intern(ctx, "ephemeron-value", -1), op);
71 op = sexp_define_foreign(ctx, env, "make-ephemeron", 2, sexp_make_ephemeron_op);
72 if (sexp_opcodep(op)) {
73 sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_EPHEMERON);
74 }
75 op = sexp_define_foreign(ctx, env, "ephemeron-broken?", 1, sexp_ephemeron_brokenp_op);
76 if (sexp_opcodep(op)) {
77 sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
78 sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_EPHEMERON);
79 }
80 #endif
81
82 #if 0
83 name = sexp_c_string(ctx, "Weak-Vector", -1);
84 t = sexp_register_simple_type(ctx, name, SEXP_FALSE, SEXP_ZERO);
85 v = sexp_type_by_index(ctx, SEXP_VECTOR);
86 sexp_weak_vector_id = sexp_type_tag(t);
87 sexp_type_weak_base(t) = sexp_type_field_base(v);
88 sexp_type_weak_len_off(t) = sexp_type_field_len_off(v);
89 sexp_type_weak_len_scale(t) = sexp_type_field_len_scale(v);
90
91 op = sexp_make_type_predicate(ctx, name=sexp_c_string(ctx,"weak-vector?",-1), t);
92 sexp_env_define(ctx, env, name=sexp_intern(ctx, "weak-vector?", -1), op);
93 op = sexp_define_foreign(ctx, env, "make-weak-vector", 1, sexp_make_weak_vector);
94 if (sexp_opcodep(op)) {
95 sexp_opcode_return_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
96 sexp_opcode_arg1_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
97 }
98 op = sexp_define_foreign(ctx, env, "weak-vector-length", 2, sexp_weak_vector_length);
99 if (sexp_opcodep(op)) {
100 sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
101 sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
102 }
103 op = sexp_define_foreign(ctx, env, "weak-vector-ref", 2, sexp_weak_vector_ref);
104 if (sexp_opcodep(op)) {
105 sexp_opcode_return_type(op) = sexp_make_fixnum(SEXP_OBJECT);
106 sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
107 sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
108 }
109 op = sexp_define_foreign(ctx, env, "weak-vector-set!", 3, sexp_weak_vector_set);
110 if (sexp_opcodep(op)) {
111 sexp_opcode_return_type(op) = SEXP_VOID;
112 sexp_opcode_arg1_type(op) = sexp_make_fixnum(sexp_weak_vector_id);
113 sexp_opcode_arg2_type(op) = sexp_make_fixnum(SEXP_FIXNUM);
114 }
115 #endif
116
117 sexp_gc_release3(ctx);
118 return SEXP_VOID;
119 }
120
121