sync registers before calling c functions, really
[bpt/guile.git] / src / programs.c
CommitLineData
8f5cfc81 1/* Copyright (C) 2001 Free Software Foundation, Inc.
17e90c5e
KN
2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
41
13c47753
AW
42#if HAVE_CONFIG_H
43# include <config.h>
44#endif
45
17e90c5e
KN
46#include <string.h>
47#include "instructions.h"
48#include "programs.h"
49#include "vm.h"
50
51\f
f9e8c09d 52scm_t_bits scm_tc16_program;
17e90c5e
KN
53
54static SCM zero_vector;
55
56SCM
57scm_c_make_program (void *addr, size_t size, SCM holder)
58#define FUNC_NAME "scm_c_make_program"
59{
d8eeb67c
LC
60 struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
61 "program");
17e90c5e
KN
62 p->size = size;
63 p->nargs = 0;
64 p->nrest = 0;
65 p->nlocs = 0;
3d5ee0cd 66 p->nexts = 0;
ac99cb0c 67 p->meta = SCM_BOOL_F;
17e90c5e
KN
68 p->objs = zero_vector;
69 p->external = SCM_EOL;
70 p->holder = holder;
71
72 /* If nobody holds bytecode's address, then allocate a new memory */
3d5ee0cd 73 if (SCM_FALSEP (holder))
d8eeb67c 74 p->base = scm_gc_malloc (size, "program-base");
17e90c5e
KN
75 else
76 p->base = addr;
77
78 SCM_RETURN_NEWSMOB (scm_tc16_program, p);
79}
80#undef FUNC_NAME
81
82SCM
3d5ee0cd 83scm_c_make_closure (SCM program, SCM external)
17e90c5e 84{
ac02b386
KN
85 SCM prog = scm_c_make_program (0, 0, program);
86 *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program);
ac99cb0c 87 SCM_PROGRAM_DATA (prog)->external = external;
17e90c5e
KN
88 return prog;
89}
90
91static SCM
92program_mark (SCM obj)
93{
94 struct scm_program *p = SCM_PROGRAM_DATA (obj);
ac99cb0c 95 scm_gc_mark (p->meta);
17e90c5e
KN
96 scm_gc_mark (p->objs);
97 scm_gc_mark (p->external);
98 return p->holder;
99}
100
101static scm_sizet
102program_free (SCM obj)
103{
104 struct scm_program *p = SCM_PROGRAM_DATA (obj);
105 scm_sizet size = (sizeof (struct scm_program));
d8eeb67c 106
17e90c5e 107 if (SCM_FALSEP (p->holder))
d8eeb67c
LC
108 scm_gc_free (p->base, p->size, "program-base");
109
110 scm_gc_free (p, size, "program");
111
112 return 0;
17e90c5e
KN
113}
114
17e90c5e
KN
115static SCM
116program_apply (SCM program, SCM args)
117{
499a4c07 118 return scm_vm_apply (scm_the_vm (), program, args);
17e90c5e
KN
119}
120
121\f
122/*
123 * Scheme interface
124 */
125
126SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
127 (SCM obj),
128 "")
129#define FUNC_NAME s_scm_program_p
130{
131 return SCM_BOOL (SCM_PROGRAM_P (obj));
132}
133#undef FUNC_NAME
134
ac99cb0c
KN
135SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
136 (SCM program),
137 "")
138#define FUNC_NAME s_scm_program_base
139{
140 SCM_VALIDATE_PROGRAM (1, program);
141
f41cb00c 142 return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
ac99cb0c
KN
143}
144#undef FUNC_NAME
145
17e90c5e
KN
146SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
147 (SCM program),
148 "")
149#define FUNC_NAME s_scm_program_arity
ac99cb0c
KN
150{
151 struct scm_program *p;
152
153 SCM_VALIDATE_PROGRAM (1, program);
154
155 p = SCM_PROGRAM_DATA (program);
2d80426a
LC
156 return SCM_LIST4 (SCM_I_MAKINUM (p->nargs),
157 SCM_I_MAKINUM (p->nrest),
158 SCM_I_MAKINUM (p->nlocs),
159 SCM_I_MAKINUM (p->nexts));
ac99cb0c
KN
160}
161#undef FUNC_NAME
162
163SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
164 (SCM program),
165 "")
166#define FUNC_NAME s_scm_program_meta
17e90c5e
KN
167{
168 SCM_VALIDATE_PROGRAM (1, program);
ac99cb0c 169 return SCM_PROGRAM_DATA (program)->meta;
17e90c5e
KN
170}
171#undef FUNC_NAME
172
173SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
174 (SCM program),
175 "")
176#define FUNC_NAME s_scm_program_objects
177{
178 SCM_VALIDATE_PROGRAM (1, program);
ac99cb0c 179 return SCM_PROGRAM_DATA (program)->objs;
17e90c5e
KN
180}
181#undef FUNC_NAME
182
183SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
184 (SCM program),
185 "")
186#define FUNC_NAME s_scm_program_external
187{
188 SCM_VALIDATE_PROGRAM (1, program);
ac99cb0c 189 return SCM_PROGRAM_DATA (program)->external;
17e90c5e
KN
190}
191#undef FUNC_NAME
192
62082959
LC
193SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
194 (SCM program, SCM external),
195 "Modify the list of closure variables of @var{program} (for "
196 "debugging purposes).")
197#define FUNC_NAME s_scm_program_external_set_x
198{
199 SCM_VALIDATE_PROGRAM (1, program);
200 SCM_VALIDATE_LIST (2, external);
201 SCM_PROGRAM_DATA (program)->external = external;
202 return SCM_UNSPECIFIED;
203}
204#undef FUNC_NAME
205
17e90c5e
KN
206SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
207 (SCM program),
fa19602c 208 "Return a u8vector containing @var{program}'s bytecode.")
17e90c5e
KN
209#define FUNC_NAME s_scm_program_bytecode
210{
fa19602c 211 size_t size;
b6368dbb 212 scm_t_uint8 *c_bytecode;
fa19602c 213
17e90c5e 214 SCM_VALIDATE_PROGRAM (1, program);
fa19602c
LC
215
216 size = SCM_PROGRAM_DATA (program)->size;
217 c_bytecode = malloc (size);
218 if (!c_bytecode)
219 return SCM_BOOL_F;
220
221 memcpy (c_bytecode, SCM_PROGRAM_DATA (program)->base, size);
222
223 return scm_take_u8vector (c_bytecode, size);
17e90c5e
KN
224}
225#undef FUNC_NAME
226
fa19602c 227
17e90c5e
KN
228\f
229void
230scm_init_programs (void)
231{
232 zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
233
234 scm_tc16_program = scm_make_smob_type ("program", 0);
235 scm_set_smob_mark (scm_tc16_program, program_mark);
236 scm_set_smob_free (scm_tc16_program, program_free);
17e90c5e
KN
237 scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
238
239#ifndef SCM_MAGIC_SNARFER
240#include "programs.x"
241#endif
242}
243
244/*
245 Local Variables:
246 c-file-style: "gnu"
247 End:
248*/