fix a number of assuptions that a long could hold an inum
[bpt/guile.git] / libguile / instructions.c
1 /* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
17 */
18
19 #if HAVE_CONFIG_H
20 # include <config.h>
21 #endif
22
23 #include <string.h>
24
25 #include "_scm.h"
26 #include "instructions.h"
27
28 struct scm_instruction {
29 enum scm_opcode opcode; /* opcode */
30 const char *name; /* instruction name */
31 signed char len; /* Instruction length. This may be -1 for
32 the loader (see the `VM_LOADER'
33 macro). */
34 signed char npop; /* The number of values popped. This may be
35 -1 for insns like `call' which can take
36 any number of arguments. */
37 char npush; /* the number of values pushed */
38 SCM symname; /* filled in later */
39 };
40
41 #define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar) \
42 do { \
43 cvar = scm_lookup_instruction_by_name (var); \
44 SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P"); \
45 } while (0)
46
47
48 static struct scm_instruction*
49 fetch_instruction_table ()
50 {
51 static struct scm_instruction *table = NULL;
52
53 if (SCM_UNLIKELY (!table))
54 {
55 size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
56 int i;
57 table = malloc (bytes);
58 memset (table, 0, bytes);
59 #define VM_INSTRUCTION_TO_TABLE 1
60 #include <libguile/vm-expand.h>
61 #include <libguile/vm-i-system.i>
62 #include <libguile/vm-i-scheme.i>
63 #include <libguile/vm-i-loader.i>
64 #undef VM_INSTRUCTION_TO_TABLE
65 for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
66 {
67 table[i].opcode = i;
68 if (table[i].name)
69 table[i].symname = scm_from_locale_symbol (table[i].name);
70 else
71 table[i].symname = SCM_BOOL_F;
72 }
73 }
74 return table;
75 }
76
77 static struct scm_instruction *
78 scm_lookup_instruction_by_name (SCM name)
79 {
80 static SCM instructions_by_name = SCM_BOOL_F;
81 struct scm_instruction *table = fetch_instruction_table ();
82 SCM op;
83
84 if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
85 {
86 unsigned int i;
87
88 instructions_by_name =
89 scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
90
91 for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
92 if (scm_is_true (table[i].symname))
93 scm_hashq_set_x (instructions_by_name, table[i].symname,
94 SCM_I_MAKINUM (i));
95 }
96
97 op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
98 if (SCM_I_INUMP (op))
99 return &table[SCM_I_INUM (op)];
100
101 return NULL;
102 }
103
104
105 /* Scheme interface */
106
107 SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
108 (void),
109 "")
110 #define FUNC_NAME s_scm_instruction_list
111 {
112 SCM list = SCM_EOL;
113 int i;
114 struct scm_instruction *ip = fetch_instruction_table ();
115 for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
116 if (ip[i].name)
117 list = scm_cons (ip[i].symname, list);
118 return scm_reverse_x (list, SCM_EOL);
119 }
120 #undef FUNC_NAME
121
122 SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
123 (SCM obj),
124 "")
125 #define FUNC_NAME s_scm_instruction_p
126 {
127 return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL);
128 }
129 #undef FUNC_NAME
130
131 SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
132 (SCM inst),
133 "")
134 #define FUNC_NAME s_scm_instruction_length
135 {
136 struct scm_instruction *ip;
137 SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
138 return SCM_I_MAKINUM (ip->len);
139 }
140 #undef FUNC_NAME
141
142 SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
143 (SCM inst),
144 "")
145 #define FUNC_NAME s_scm_instruction_pops
146 {
147 struct scm_instruction *ip;
148 SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
149 return SCM_I_MAKINUM (ip->npop);
150 }
151 #undef FUNC_NAME
152
153 SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
154 (SCM inst),
155 "")
156 #define FUNC_NAME s_scm_instruction_pushes
157 {
158 struct scm_instruction *ip;
159 SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
160 return SCM_I_MAKINUM (ip->npush);
161 }
162 #undef FUNC_NAME
163
164 SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
165 (SCM inst),
166 "")
167 #define FUNC_NAME s_scm_instruction_to_opcode
168 {
169 struct scm_instruction *ip;
170 SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
171 return SCM_I_MAKINUM (ip->opcode);
172 }
173 #undef FUNC_NAME
174
175 SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
176 (SCM op),
177 "")
178 #define FUNC_NAME s_scm_opcode_to_instruction
179 {
180 scm_t_signed_bits opcode;
181 SCM ret = SCM_BOOL_F;
182
183 SCM_MAKE_VALIDATE (1, op, I_INUMP);
184 opcode = SCM_I_INUM (op);
185
186 if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS)
187 ret = fetch_instruction_table ()[opcode].symname;
188
189 if (scm_is_false (ret))
190 scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
191
192 return ret;
193 }
194 #undef FUNC_NAME
195
196 void
197 scm_bootstrap_instructions (void)
198 {
199 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
200 "scm_init_instructions",
201 (scm_t_extension_init_func)scm_init_instructions,
202 NULL);
203 }
204
205 void
206 scm_init_instructions (void)
207 {
208 #ifndef SCM_MAGIC_SNARFER
209 #include "libguile/instructions.x"
210 #endif
211 }
212
213 /*
214 Local Variables:
215 c-file-style: "gnu"
216 End:
217 */