1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
/*-----------------------------------------------------------------*-C-*---
* File: handc/runtime/interim.ci
*
* Copyright (C)1997 Donovan Kolbly <d.kolbly@rscheme.org>
* as part of the RScheme project, licensed for free use.
* See <http://www.rscheme.org/> for the latest information.
*
* File version: 1.13
* File mod date: 1997.11.29 23:10:52
* System build: v0.7.2, 97.12.21
*
*------------------------------------------------------------------------*/
#ifndef _CI_INTERIM
#define _CI_INTERIM
#include <rscheme/scheme.h>
#include <rscheme/smemory.h>
#include <rscheme/allocns.h>
#define PTR_ISA(a_thing,a_class) OBJ_ISA_PTR_OF_CLASS(a_thing,a_class)
#define CLASS_CATEGORY_SLOT SLOT(4)
CI_DECL rs_bool NULL_P( obj thing )
{
return EQ(thing,NIL_OBJ) ? YES : NO;
}
/***************** top-level environments & vars *****************/
CI_DECL rs_bool TLV_P( obj thing )
{
return PTR_ISA(thing,tlv_class);
}
void signal_tlv_unbound( obj tlv );
CI_DECL obj tlv_value( obj tlv )
{
obj v;
assert( TLV_P(tlv) );
v = gvec_read( tlv, SLOT(1) );
if (EQ(v,UNBOUND_OBJ))
{
signal_tlv_unbound( tlv );
}
return v;
}
CI_DECL void tlv_set_value( obj tlv, obj value )
{
assert( TLV_P(tlv) );
gvec_write( tlv, SLOT(1), value );
}
/***************** pairs *****************/
CI_DECL rs_bool PAIR_P( obj thing )
{
return PTR_ISA( thing, pair_class );
}
CI_DECL obj cons( obj car, obj cdr )
{
return make2( pair_class, car, cdr );
}
CI_DECL obj pair_car( obj pair )
{
assert( PAIR_P(pair) );
return gvec_read( pair, SLOT(0) );
}
CI_DECL obj pair_cdr( obj pair )
{
assert( PAIR_P(pair) );
return gvec_read( pair, SLOT(1) );
}
/************************** common type predicates ***********************/
CI_DECL rs_bool CLASS_P( obj thing )
{
/* can't use PTR_IN_CATEGORY_P(), because it uses in_category_p,
* which has an assert(CLASS_P()), which results in an infinite loop.
* also have to expand by hand the other stuff
*/
return (OBJ_ISA_PTR(thing)
&& EQ(gvec_ref(CLASSOF_PTR(thing),CLASS_CATEGORY_SLOT),
CLASS_CATEGORY))
? YES
: NO;
}
CI_DECL rs_bool LONGFLOAT_P( obj thing )
{
return PTR_ISA(thing,double_float_class);
}
CI_DECL rs_bool STRING_P( obj thing )
{
return PTR_ISA(thing,string_class);
}
CI_DECL char *string_text( obj str )
{
assert( STRING_P(str) );
return (char *)PTR_TO_DATAPTR(str);
}
CI_DECL UINT_32 string_length( obj str )
{
assert( STRING_P(str) );
return SIZEOF_PTR(str) - 1;
}
/* helper function for object_class to handle non-PTR's */
obj immob_class( obj thing );
CI_DECL obj object_class( obj thing )
{
if (OBJ_ISA_PTR(thing))
return CLASSOF_PTR( thing );
else
return immob_class( thing );
}
/* helper function for indirect subclasses */
rs_bool indirect_subclass_p( obj class1, obj class2 );
CI_DECL rs_bool subclass_p( obj class_1, obj class_2 )
{
if (EQ(class_1,class_2))
return YES;
else
return indirect_subclass_p( class_1, class_2 );
}
CI_DECL obj class_supers( obj a_class )
{
assert( CLASS_P(a_class) );
return gvec_read( a_class, SLOT(3) );
}
CI_DECL obj class_category( obj a_class )
{
assert( CLASS_P(a_class) );
return gvec_ref( a_class, CLASS_CATEGORY_SLOT );
}
CI_DECL rs_bool instance_p( obj thing, obj a_class )
{
return subclass_p( object_class(thing), a_class );
}
CIH_DECL rs_bool in_category_p( obj a_class, obj a_category )
{
return EQ(class_category(a_class),a_category);
}
CIH_DECL rs_bool instance_cat_p( obj thing, obj a_category )
{
return in_category_p(object_class(thing),a_category);
}
/***************** functions & closures *****************/
CI_DECL obj make_closure( obj envt, obj tmpl )
{
return make2( closure_class, tmpl, envt );
}
CI_DECL rs_bool FUNCTION_P( obj thing )
{
return PTR_IN_CATEGORY_P( thing, FUNCTION_CATEGORY );
}
#ifdef INLINES
#include <rscheme/chektype.ci>
#endif
#endif /* _CI_INTERIM */
|
