1 /* Copyright (C) 2001 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
51 #include <sys/types.h>
54 #include "vm-bootstrap.h"
58 #define OBJCODE_COOKIE "GOOF-0.5"
65 scm_t_bits scm_tc16_objcode
;
68 make_objcode (size_t size
)
69 #define FUNC_NAME "make_objcode"
71 struct scm_objcode
*p
= scm_gc_malloc (sizeof (struct scm_objcode
),
74 p
->base
= scm_gc_malloc (size
, "objcode-base");
76 SCM_RETURN_NEWSMOB (scm_tc16_objcode
, p
);
81 make_objcode_by_mmap (int fd
)
82 #define FUNC_NAME "make_objcode_by_mmap"
87 struct scm_objcode
*p
;
89 ret
= fstat (fd
, &st
);
93 if (st
.st_size
<= strlen (OBJCODE_COOKIE
))
94 scm_misc_error (FUNC_NAME
, "object file too small (~a bytes)",
95 SCM_LIST1 (SCM_I_MAKINUM (st
.st_size
)));
97 addr
= mmap (0, st
.st_size
, PROT_READ
, MAP_SHARED
, fd
, 0);
98 if (addr
== MAP_FAILED
)
101 if (memcmp (addr
, OBJCODE_COOKIE
, strlen (OBJCODE_COOKIE
)))
104 p
= scm_gc_malloc (sizeof (struct scm_objcode
), "objcode");
105 p
->size
= st
.st_size
;
108 SCM_RETURN_NEWSMOB (scm_tc16_objcode
, p
);
113 objcode_free (SCM obj
)
114 #define FUNC_NAME "objcode_free"
116 size_t size
= sizeof (struct scm_objcode
);
117 struct scm_objcode
*p
= SCM_OBJCODE_DATA (obj
);
122 rv
= munmap (p
->base
, p
->size
);
123 if (rv
< 0) SCM_SYSERROR
;
125 if (rv
< 0) SCM_SYSERROR
;
128 scm_gc_free (p
->base
, p
->size
, "objcode-base");
130 scm_gc_free (p
, size
, "objcode");
142 SCM_DEFINE (scm_do_pair
, "do-pair", 2, 0, 0,
144 "This is a stupid test to see how cells work. (Ludo)")
146 static SCM room
[512];
147 static SCM
*where
= &room
[0];
151 if ((scm_t_bits
)where
& 6)
153 /* Align the cell pointer so that Guile considers it as a
154 non-immediate object (see tags.h). */
155 incr
= (scm_t_bits
)where
& 6;
160 printf ("do-pair: pool @ %p, pair @ %p\n", &room
[0], where
);
164 the_pair
= PTR2SCM (where
);
165 /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
166 "mark bitmap" at the end of a supposed cell segment which doesn't
173 SCM_DEFINE (scm_objcode_p
, "objcode?", 1, 0, 0,
176 #define FUNC_NAME s_scm_objcode_p
178 return SCM_BOOL (SCM_OBJCODE_P (obj
));
182 SCM_DEFINE (scm_bytecode_to_objcode
, "bytecode->objcode", 3, 0, 0,
183 (SCM bytecode
, SCM nlocs
, SCM nexts
),
185 #define FUNC_NAME s_scm_bytecode_to_objcode
189 scm_t_array_handle handle
;
191 const scm_t_uint8
*c_bytecode
;
194 if (scm_u8vector_p (bytecode
) != SCM_BOOL_T
)
195 scm_wrong_type_arg (FUNC_NAME
, 1, bytecode
);
196 SCM_VALIDATE_NUMBER (2, nlocs
);
197 SCM_VALIDATE_NUMBER (3, nexts
);
199 c_bytecode
= scm_u8vector_elements (bytecode
, &handle
, &size
, &increment
);
200 assert (increment
== 1);
202 /* Account for the 10 byte-long header. */
204 objcode
= make_objcode (size
);
205 base
= SCM_OBJCODE_BASE (objcode
);
207 memcpy (base
, OBJCODE_COOKIE
, 8);
208 base
[8] = scm_to_uint8 (nlocs
);
209 base
[9] = scm_to_uint8 (nexts
);
211 memcpy (base
+ 10, c_bytecode
, size
- 10);
213 scm_array_handle_release (&handle
);
219 SCM_DEFINE (scm_load_objcode
, "load-objcode", 1, 0, 0,
222 #define FUNC_NAME s_scm_load_objcode
227 SCM_VALIDATE_STRING (1, file
);
229 c_file
= scm_to_locale_string (file
);
230 fd
= open (c_file
, O_RDONLY
);
232 if (fd
< 0) SCM_SYSERROR
;
234 return make_objcode_by_mmap (fd
);
238 SCM_DEFINE (scm_objcode_to_u8vector
, "objcode->u8vector", 1, 0, 0,
241 #define FUNC_NAME s_scm_objcode_to_u8vector
243 scm_t_uint8
*u8vector
;
246 SCM_VALIDATE_OBJCODE (1, objcode
);
248 size
= SCM_OBJCODE_SIZE (objcode
);
249 /* FIXME: Is `gc_malloc' ok here? */
250 u8vector
= scm_gc_malloc (size
, "objcode-u8vector");
251 memcpy (u8vector
, SCM_OBJCODE_BASE (objcode
), size
);
253 return scm_take_u8vector (u8vector
, size
);
257 SCM_DEFINE (scm_objcode_to_program
, "objcode->program", 1, 0, 0,
260 #define FUNC_NAME s_scm_objcode_to_program
265 struct scm_program
*p
;
267 SCM_VALIDATE_OBJCODE (1, objcode
);
269 base
= SCM_OBJCODE_BASE (objcode
);
270 size
= SCM_OBJCODE_SIZE (objcode
);
271 prog
= scm_c_make_program (base
+ 10, size
- 10, objcode
);
272 p
= SCM_PROGRAM_DATA (prog
);
281 scm_bootstrap_objcodes (void)
283 scm_tc16_objcode
= scm_make_smob_type ("objcode", 0);
284 scm_set_smob_free (scm_tc16_objcode
, objcode_free
);
288 scm_init_objcodes (void)
292 #ifndef SCM_MAGIC_SNARFER
293 #include "objcodes.x"