fixed bug in prepareStackForAbsOpt (rtemgr.c).
[bugg-scheme-compiler.git] / src / c / builtins.c
blob8a7e5cd440fdb31a28f0aafd958c12e9243e6d37
1 /* <Built-in procedures> */
3 /* Creates a closure and adds it to the top-level
4 @param name (string) the name of the built-in procedure
5 @param code (void*) the address of the built-in procedure (label address)
6 */
7 #define CREATE_BUILTIN_CLOS(name,code) \
8 r_res = (int)getSymbol((name),topLevel); /* create a hash bucket */ \
9 ((SymbolEntry*)r_res)->sob = makeSchemeClosure(NULL,(code)); \
10 ASSERT_ALWAYS( ((SymbolEntry*)r_res)->sob!=NULL,"" ); \
11 ((SymbolEntry*)r_res)->isDefined = 1;
13 /* The stack when in a built-in precedure (there is no fp):
14 sp -> | |
15 | ret | - return address
16 | env | - points to the enviroment vector
17 | n | - number of arguments
18 | A0 | - argument 0
19 | A1 | - argument 1
20 | ... | - ...
21 | An-1 | - argument n-1
23 Macros for built-in procedures:
25 #define BI_ST_ARG(n) (stack[sp-4-(n)])
26 #define BI_ST_ARG_COUNT() (stack[sp-3])
27 #define BI_RETURN() goto *pop()
29 goto Lstart; /* skip all definitions */
31 Lcar:
32 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("car",1) );
33 r[0] = BI_ST_ARG(0);
34 ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
35 r_res = (int)SOB_PAIR_CAR(r[0]);
36 BI_RETURN();
38 Lcdr:
39 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("cdr",1) );
40 r[0] = BI_ST_ARG(0);
41 ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
42 r_res = (int)SOB_PAIR_CDR(r[0]);
43 BI_RETURN();
45 Lsymbol:
46 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("symbol?",1) );
47 r[0] = BI_ST_ARG(0);
48 if ( IS_SOB_SYMBOL(r[0]) ) goto Lsymbol_true;
49 r_res = (int)&sc_false;
50 BI_RETURN();
51 Lsymbol_true:
52 r_res = (int)&sc_true;
53 BI_RETURN();
55 Lset_car:
56 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("set-car!",2) );
57 r[0] = BI_ST_ARG(0);
58 r[1] = BI_ST_ARG(1);
59 ASSERT_ALWAYS( IS_SOB_PAIR(r[0]), MSG_ERR_NOTPAIR );
60 SOB_PAIR_CAR(r[0]) = (SchemeObject*)r[1];
61 r_res = r[1];
62 BI_RETURN();
64 Lmake_vector:
65 ASSERT_ALWAYS( BI_ST_ARG_COUNT()>=1,MSG_ERR_ARGCOUNT("make-vector",1) );
66 r[0] = BI_ST_ARG(0);
67 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
68 r[0] = SOB_INT_VALUE(r[0]);
69 r_res = (int)makeSchemeVectorInit(r[0],&sc_void);
70 /* initialize vector elements
71 for (int i=1; i<BI_ST_ARG_COUNT(); ++i)
72 SOB_VECTOR_SET(r_res,i,BI_ST_ARG(i));
74 BI_RETURN();
76 Lvector_set:
77 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==3,MSG_ERR_ARGCOUNT("vector-set!",3) );
78 r[0] = BI_ST_ARG(0);
79 ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), "");
80 r[1] = BI_ST_ARG(1);
81 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
82 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
83 r[2] = BI_ST_ARG(2);
84 SOB_VECTOR_SET((SchemeObject*)r[0],r[1],(SchemeObject*)r[2]);
85 r_res = (int)&sc_void;
86 BI_RETURN();
88 Lvector_ref:
89 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("vector-ref",2) );
90 r[0] = BI_ST_ARG(0);
91 ASSERT_ALWAYS(IS_SOB_VECTOR((SchemeObject*)r[0]), "");
92 r[1] = BI_ST_ARG(1);
93 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
94 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
95 r_res = (int)SOB_VECTOR_REF((SchemeObject*)r[0],r[1]);
96 BI_RETURN();
98 LbinaryEQ:
99 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary=?",2) );
100 r[0] = BI_ST_ARG(0);
101 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
102 r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
103 r[1] = BI_ST_ARG(1);
104 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
105 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
106 if (r[0] != r[1]) goto LbinaryEQ_false;
107 r_res = (int)&sc_true;
108 BI_RETURN();
109 LbinaryEQ_false:
110 r_res = (int)&sc_false;
111 BI_RETURN();
113 LbinaryADD:
114 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-add",2) );
115 r[0] = BI_ST_ARG(0);
116 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
117 r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
118 r[1] = BI_ST_ARG(1);
119 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
120 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
121 r_res = r[0] + r[1];
122 r_res = (int)makeSchemeInt( r_res );
123 BI_RETURN();
125 LbinarySUB:
126 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-sub",2) );
127 r[0] = BI_ST_ARG(0);
128 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
129 r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
130 r[1] = BI_ST_ARG(1);
131 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
132 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
133 r_res = r[0] - r[1];
134 r_res = (int)makeSchemeInt( r_res );
135 BI_RETURN();
137 LbinaryMUL:
138 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-mul",2) );
139 r[0] = BI_ST_ARG(0);
140 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
141 r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
142 r[1] = BI_ST_ARG(1);
143 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
144 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
145 r_res = (int)r[0] * (int)r[1]; /* multiply as signed integers */
146 r_res = (int)makeSchemeInt( r_res );
147 BI_RETURN();
149 LbinaryDIV:
150 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary-div",2) );
151 r[0] = BI_ST_ARG(0);
152 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
153 r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
154 r[1] = BI_ST_ARG(1);
155 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
156 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
157 r_res = (int)r[0] / (int)r[1]; /* divide as signed integers */
158 r_res = (int)makeSchemeInt( r_res );
159 BI_RETURN();
161 LbinaryLT:
162 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==2,MSG_ERR_ARGCOUNT("binary<?",2) );
163 r[0] = BI_ST_ARG(0);
164 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[0]), "");
165 r[0] = SOB_INT_VALUE((SchemeObject*)r[0]);
166 r[1] = BI_ST_ARG(1);
167 ASSERT_ALWAYS(IS_SOB_INT((SchemeObject*)r[1]), "");
168 r[1] = SOB_INT_VALUE((SchemeObject*)r[1]);
169 r_res = ((int)r[0] < (int)r[1]); /* compare as signed integers */
170 r_res = (int)makeSchemeBool( r_res );
171 BI_RETURN();
173 Lbox:
174 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("box",1) );
175 r[0] = BI_ST_ARG(0);
176 r_res = (int)makeSchemeVectorInit( 1,(SchemeObject*)(r[0]) );
177 BI_RETURN();
179 Lnull:
180 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("null?",1) );
181 r[0] = BI_ST_ARG(0);
182 r_res = (int)makeSchemeBool( IS_SOB_NIL(r[0]) );
183 BI_RETURN();
185 Lchar_to_integer:
186 ASSERT_ALWAYS( BI_ST_ARG_COUNT()==1,MSG_ERR_ARGCOUNT("char->integer",1) );
187 r[0] = BI_ST_ARG(0);
188 ASSERT_ALWAYS( IS_SOB_CHAR(r[0]), "" );
189 r[0] = SOB_CHAR_VALUE(r[0]);
190 r_res = (int)makeSchemeInt( (int)r[0] );
191 BI_RETURN();
193 Lstart:
194 /* create closures for the free variables of the built-in procedures */
195 CREATE_BUILTIN_CLOS("car" ,&&Lcar);
196 CREATE_BUILTIN_CLOS("cdr" ,&&Lcdr);
197 CREATE_BUILTIN_CLOS("symbol?" ,&&Lsymbol);
198 CREATE_BUILTIN_CLOS("set-car!" ,&&Lset_car);
199 CREATE_BUILTIN_CLOS("make-vector" ,&&Lmake_vector);
200 CREATE_BUILTIN_CLOS("vector-set!" ,&&Lvector_set);
201 CREATE_BUILTIN_CLOS("vector-ref" ,&&Lvector_ref);
202 CREATE_BUILTIN_CLOS("binary=?" ,&&LbinaryEQ);
203 CREATE_BUILTIN_CLOS("binary-add" ,&&LbinaryADD);
204 CREATE_BUILTIN_CLOS("binary-sub" ,&&LbinarySUB);
205 CREATE_BUILTIN_CLOS("binary-mul" ,&&LbinaryMUL);
206 CREATE_BUILTIN_CLOS("binary-div" ,&&LbinaryDIV);
207 CREATE_BUILTIN_CLOS("binary<?" ,&&LbinaryLT);
208 CREATE_BUILTIN_CLOS("box" ,&&Lbox);
209 CREATE_BUILTIN_CLOS("null?" ,&&Lnull);
210 CREATE_BUILTIN_CLOS("char->integer" ,&&Lchar_to_integer);
212 CREATE_BUILTIN_CLOS("",&&L);
215 /* </Built-in procedures> */