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));
73     */
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);
213     */
215 /* </Built-in procedures> */