all noncommented rtl ops are now encoded
[aschm:aschm.git] / guile / c-stubs.c
1 #include "control.h"
2
3 SCM g_make_vector(int len, SCM *sp)
4 {
5   SCM vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
6   int i,j;
7   SCM *pt  = SCM_I_VECTOR_WELTS(vect);
8   for(i=0,j=len-1;i<len;i++,j--)
9     {
10       pt[i]=sp[j];
11     }
12   return vect;
13 }
14
15 void g_wrong_argument(long rax)
16 {
17   scm_misc_error("vm-native-error","wrong number of arguments! got ~a",scm_list_1(SCM_PACK(rax/2+2)));
18 }
19
20 void g_car_error()
21 {
22   scm_misc_error("vm-native-error","taking car of non pair!",SCM_EOL);
23 }
24
25 void g_cdr_error()
26 {
27   scm_misc_error("vm-native-error","taking cdr of non pair!",SCM_EOL);
28 }
29
30 void g_setcar_error()
31 {
32   scm_misc_error("vm-native-error","taking set-car! of non pair!",SCM_EOL);
33 }
34
35 void g_setcdr_error()
36 {
37   scm_misc_error("vm-native-error","taking set-cdr! of non pair!",SCM_EOL);
38 }
39
40 void g_not_a_var(SCM scm)
41 {
42   scm_misc_error("vm-native-error","(variable-ref) ~a is not a variable",scm_list_1(scm));
43 }
44
45 void g_not_a_var_b(SCM scm)
46 {
47   scm_misc_error("vm-native-error","(variable-bound?) ~a is not a variable",scm_list_1(scm));
48 }
49
50 void g_not_a_var_s(SCM scm)
51 {
52   scm_misc_error("vm-native-error","(variable-set!) ~a is not a variable",scm_list_1(scm));
53 }
54
55 void g_var_not_bound(SCM scm)
56 {
57   scm_misc_error("vm-native-error","variable ~a is not bounded",scm_list_1(scm));
58 }
59
60 //Copied from vm-i-system.c
61 #define VARIABLE_BOUNDP(v)      (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
62 #define VARIABLE_REF(v)         SCM_VARIABLE_REF (v)
63
64 //Copied from vm.c
65 static SCM
66 resolve_variable (SCM what, SCM program_module)
67 {
68   if (SCM_LIKELY (scm_is_symbol (what)))
69     {
70       if (SCM_LIKELY (scm_module_system_booted_p
71                       && scm_is_true (program_module)))
72         /* might longjmp */
73         return scm_module_lookup (program_module, what);
74       else
75         {
76           SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
77           if (scm_is_false (v))
78             scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
79           else
80             return v;
81         }
82     }
83   else
84     {
85       SCM mod;
86       /* compilation of @ or @@
87          `what' is a three-element list: (MODNAME SYM INTERFACE?)
88          INTERFACE? is #t if we compiled @ or #f if we compiled @@
89       */
90       mod = scm_resolve_module (SCM_CAR (what));
91       if (scm_is_true (SCM_CADDR (what)))
92         mod = scm_module_public_interface (mod);
93       if (scm_is_false (mod))
94         scm_misc_error (NULL, "no such module: ~S",
95                         scm_list_1 (SCM_CAR (what)));
96       /* might longjmp */
97       return scm_module_lookup (mod, SCM_CADR (what));
98     }
99 }
100
101
102 SCM g_toplevel_lookup(SCM what, SCM program, int i)
103 {
104   SCM resolved;
105
106   resolved = resolve_variable (what, scm_program_module (program));
107   if (!VARIABLE_BOUNDP (resolved))
108     {
109       scm_misc_error("vm-native-error","(toplevel-ref) toplevel refed variable ~a is not bounded",scm_list_1(what));     
110     }
111
112   SCM o = SCM_PROGRAM_OBJTABLE(program);
113   SCM_I_VECTOR_WELTS(o)[i] = resolved;
114   return resolved;
115 }
116
117
118 SCM g_prompt(SCM k, scm_t_uint8 escape_only_p)
119 {
120   SCM prompt;
121
122   /* Push the prompt onto the dynamic stack. */
123   prompt = scm_c_make_prompt (k, 
124                               (SCM*)0, 
125                               (SCM*)0, 
126                               (scm_t_uint8 *) 0, 
127                               escape_only_p, 
128                               SCM_BOOL_F,
129                               scm_i_dynwinds ());
130   
131   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
132
133   return prompt;
134 }
135
136
137 SCM g_get_program(SCM program)
138 {
139    if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
140      {
141        return SCM_STRUCT_PROCEDURE (program);
142      }
143    else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
144             && SCM_SMOB_APPLICABLE_P (program))
145      {
146        scm_misc_error("vm-native-error","~a smob applicable is not natively supported",scm_list_1(program));
147      
148        /*
149          PUSH (program);
150          prepare_smob_call (sp, ++nargs, program);
151        */
152      }
153    
154    scm_misc_error("vm-native-error","~a is not a program", scm_list_1(program));
155    
156    return SCM_BOOL_F;
157 }
158
159 void g_no_jitted_code(SCM p)
160 {
161   scm_misc_error("vm-native-error","~a is a non native program excuted from native VM", scm_list_1(p));
162 }
163
164 void g_truncate_err()
165 {
166   scm_misc_error("vm-native-error","wrong number of values to truncate errors", SCM_EOL);
167 }
168
169 SCM scm_call_back_to_vm(SCM *program_p, SCM *sp)
170 {
171   int n       = program_p - sp;
172   SCM args    = SCM_EOL;
173   SCM program = *program_p;
174
175   if(!SCM_PROGRAM_P(program))
176     program = g_get_program(program);
177
178   while(sp != program_p)
179     {
180       args = scm_cons(*sp,args);
181       sp++;
182     }
183   
184   return scm_apply_0(program,args);
185 }
186
187 SCM scm_mvcall_back_to_vm(SCM *program_p, SCM *sp, SCM wrapper)
188 {
189   int n       = program_p - sp;
190   SCM args    = SCM_EOL;
191   SCM program = *program_p;
192
193   if(!SCM_PROGRAM_P(program))
194     program = g_get_program(program);
195
196   while(sp != program_p)
197     {
198       args = scm_cons(*sp,args);
199       sp++;
200     }
201
202   return scm_apply_1(wrapper,program,args);
203 }
204
205 void g_zero_in_values()
206 {
207   scm_misc_error("vm-native-error","return/values return zero values", SCM_EOL);
208 }
209
210 void g_vm_error_stack_overflow ()
211 {
212   scm_misc_error("vm-native-error","vm stack overflow", SCM_EOL);
213 }
214 void g_box_not_bounded(SCM x, SCM program)
215 {
216   scm_misc_error("vm-native-error","box value not bounded", SCM_EOL);
217 }
218
219 void g_abort()
220 {
221   abort();
222 }
223
224 void g_non_not_nonimmediate()
225 {
226   scm_misc_error("vm-native-error","not a non immediate constant", SCM_EOL);
227 }
228
229 void g_not_scm_aligned()
230 {
231   scm_misc_error("vm-native-error","a static ref that's not aligned", SCM_EOL);
232 }
233
234 SCM g_toplevel_resolve(SCM v, SCM mod, SCM sym)
235 {
236   SCM var;
237   if(15 & SCM_UNPACK(mod) || 15 & SCM_UNPACK(sym))
238     g_not_scm_aligned();
239
240   var = scm_module_lookup(mod,sym);
241   
242   if(!VARIABLE_BOUNDP(var))
243     scm_misc_error("vm-native-error","(toplevel-ref) toplevel refed variable ~a is not bounded",scm_list_1(var));
244   
245   return var;
246 }
247
248 SCM g_moduleref_resolve(SCM v, SCM mod, SCM sym)
249 {
250   SCM var;
251   if(15 & SCM_UNPACK(mod) || 15 & SCM_UNPACK(sym))
252     g_not_scm_aligned();
253   
254    if (scm_is_true (SCM_CAR (mod)))
255      var = scm_public_lookup (SCM_CDR (mod), sym);
256    else
257      var = scm_private_lookup (SCM_CDR (mod), sym);
258
259    if(!VARIABLE_BOUNDP(var))
260      scm_misc_error("vm-native-error","(toplevel-ref) toplevel refed variable ~a is not bounded",scm_list_1(var));
261   
262    return var;
263 }
264
265 SCM g_fluid_ref(SCM fluid, scm_i_thread *th)
266 {
267   SCM fluids;
268
269   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
270   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
271       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
272     {
273       return scm_fluid_ref (fluid);
274     }
275   else
276     {
277       SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
278       if (scm_is_eq (val, SCM_UNDEFINED))
279         val = SCM_I_FLUID_DEFAULT (fluid);
280       if(scm_is_eq (val, SCM_UNDEFINED))
281         {
282           scm_misc_error("vm-native-error","vm_error_unbound_fluid", SCM_EOL);
283         }
284       return val;
285     }
286 }
287
288 void g_fluid_set(SCM fluid, SCM b, scm_i_thread *th)
289 {
290   SCM fluids;
291   fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
292
293   if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
294       || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
295     {
296       scm_fluid_set_x (fluid, b);
297     }
298   else
299     SCM_SIMPLE_VECTOR_SET (fluids, num, b);
300 }
301
302 SCM g_string_length(SCM str)
303 {
304   if (SCM_LIKELY (scm_is_string (str)))
305     return SCM_I_MAKINUM (scm_i_string_length (str));
306   else
307     {
308       return scm_string_length (str);
309     }
310 }
311
312 SCM g_string_ref(SCM str, SCM idx)
313 {
314   if (SCM_LIKELY (scm_is_string (str)
315                   && SCM_I_INUMP (idx)
316                   && ((i = SCM_I_INUM (idx)) >= 0)
317                   && i < scm_i_string_length (str)))
318     return SCM_MAKE_CHAR (scm_i_string_ref (str, i));
319   else
320     {
321       return scm_string_ref (str, idx);
322     }
323 }
324
325 void g_struct_error()
326 {
327   scm_misc_error("vm-native-error","not a struct in struct op", SCM_EOL);
328 }
329
330 SCM g_make_struct(SCM vtable, SCM *args, int n_init)
331 {
332   int n;
333   SCM ret;
334   if (SCM_LIKELY (SCM_STRUCTP (vtable)
335                   && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
336                   && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)
337                       == n_init)
338                   && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
339         {
340           /* Verily, we are making a simple struct with the right number of
341              initializers, and no finalizer. */
342
343           ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) 
344                            | scm_tc3_struct, n_init + 2);
345           SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
346
347           for (n = 0; n < n_init; n++)
348             SCM_STRUCT_DATA (ret)[n] = SCM_UNPACK(args[n + 1]);
349         }
350       else
351         ret = scm_c_make_structv (vtable, 0, n_init, args);  
352
353   return ret;
354 }