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 /* nb, the length of the header should be a multiple of 8 bytes */
59 #define OBJCODE_COOKIE "GOOF-0.5"
66 scm_t_bits scm_tc16_objcode
;
69 make_objcode_by_mmap (int fd
)
70 #define FUNC_NAME "make_objcode_by_mmap"
75 SCM sret
= SCM_BOOL_F
;
76 struct scm_objcode
*data
;
78 ret
= fstat (fd
, &st
);
82 if (st
.st_size
<= sizeof (struct scm_objcode
) + strlen (OBJCODE_COOKIE
))
83 scm_misc_error (FUNC_NAME
, "object file too small (~a bytes)",
84 SCM_LIST1 (SCM_I_MAKINUM (st
.st_size
)));
86 addr
= mmap (0, st
.st_size
, PROT_READ
, MAP_SHARED
, fd
, 0);
87 if (addr
== MAP_FAILED
)
90 if (memcmp (addr
, OBJCODE_COOKIE
, strlen (OBJCODE_COOKIE
)))
93 data
= (struct scm_objcode
*)(addr
+ strlen (OBJCODE_COOKIE
));
95 if (data
->len
+ data
->metalen
!= (st
.st_size
- sizeof (*data
) - strlen (OBJCODE_COOKIE
)))
96 scm_misc_error (FUNC_NAME
, "bad length header (~a, ~a)",
97 SCM_LIST2 (scm_from_size_t (st
.st_size
),
98 scm_from_uint32 (sizeof (*data
) + data
->len
+ data
->metalen
)));
100 SCM_NEWSMOB3 (sret
, scm_tc16_objcode
, addr
+ strlen (OBJCODE_COOKIE
),
101 SCM_PACK (SCM_BOOL_F
), fd
);
102 SCM_SET_SMOB_FLAGS (sret
, SCM_F_OBJCODE_IS_MMAP
);
104 /* FIXME: we leak ourselves and the file descriptor. but then again so does
106 return scm_permanent_object (sret
);
111 scm_c_make_objcode_slice (SCM parent
, scm_t_uint8
*ptr
)
112 #define FUNC_NAME "make-objcode-slice"
114 struct scm_objcode
*data
, *parent_data
;
117 SCM_VALIDATE_OBJCODE (1, parent
);
118 parent_data
= SCM_OBJCODE_DATA (parent
);
120 if (ptr
< parent_data
->base
121 || ptr
>= (parent_data
->base
+ parent_data
->len
+ parent_data
->metalen
122 - sizeof (struct scm_objcode
)))
123 scm_misc_error (FUNC_NAME
, "offset out of bounds (~a vs ~a + ~a + ~a)",
124 SCM_LIST4 (scm_from_ulong ((ulong
)ptr
),
125 scm_from_ulong ((ulong
)parent_data
->base
),
126 scm_from_uint32 (parent_data
->len
),
127 scm_from_uint32 (parent_data
->metalen
)));
129 data
= (struct scm_objcode
*)ptr
;
130 if (data
->base
+ data
->len
+ data
->metalen
> parent_data
->base
+ parent_data
->len
+ parent_data
->metalen
)
133 SCM_NEWSMOB2 (ret
, scm_tc16_objcode
, data
, parent
);
134 SCM_SET_SMOB_FLAGS (ret
, SCM_F_OBJCODE_IS_SLICE
);
140 objcode_mark (SCM obj
)
142 return SCM_SMOB_OBJECT_2 (obj
);
150 SCM_DEFINE (scm_objcode_p
, "objcode?", 1, 0, 0,
153 #define FUNC_NAME s_scm_objcode_p
155 return SCM_BOOL (SCM_OBJCODE_P (obj
));
159 SCM_DEFINE (scm_objcode_meta
, "objcode-meta", 1, 0, 0,
162 #define FUNC_NAME s_scm_objcode_meta
164 SCM_VALIDATE_OBJCODE (1, objcode
);
166 if (SCM_OBJCODE_META_LEN (objcode
) == 0)
169 return scm_c_make_objcode_slice (objcode
, (SCM_OBJCODE_BASE (objcode
)
170 + SCM_OBJCODE_LEN (objcode
)));
174 SCM_DEFINE (scm_bytecode_to_objcode
, "bytecode->objcode", 1, 0, 0,
177 #define FUNC_NAME s_scm_bytecode_to_objcode
181 scm_t_array_handle handle
;
182 const scm_t_uint8
*c_bytecode
;
183 struct scm_objcode
*data
;
186 if (scm_is_false (scm_u8vector_p (bytecode
)))
187 scm_wrong_type_arg (FUNC_NAME
, 1, bytecode
);
189 c_bytecode
= scm_u8vector_elements (bytecode
, &handle
, &size
, &increment
);
190 data
= (struct scm_objcode
*)c_bytecode
;
191 SCM_NEWSMOB2 (objcode
, scm_tc16_objcode
, data
, bytecode
);
192 scm_array_handle_release (&handle
);
194 SCM_ASSERT_RANGE (0, bytecode
, size
>= sizeof(struct scm_objcode
));
195 if (data
->len
+ data
->metalen
!= (size
- sizeof (*data
)))
196 scm_misc_error (FUNC_NAME
, "bad u8vector size (~a != ~a)",
197 SCM_LIST2 (scm_from_size_t (size
),
198 scm_from_uint32 (sizeof (*data
) + data
->len
+ data
->metalen
)));
199 assert (increment
== 1);
200 SCM_SET_SMOB_FLAGS (objcode
, SCM_F_OBJCODE_IS_U8VECTOR
);
202 /* foolishly, we assume that as long as bytecode is around, that c_bytecode
203 will be of the same length; perhaps a bad assumption? */
209 SCM_DEFINE (scm_load_objcode
, "load-objcode", 1, 0, 0,
212 #define FUNC_NAME s_scm_load_objcode
217 SCM_VALIDATE_STRING (1, file
);
219 c_file
= scm_to_locale_string (file
);
220 fd
= open (c_file
, O_RDONLY
);
222 if (fd
< 0) SCM_SYSERROR
;
224 return make_objcode_by_mmap (fd
);
228 SCM_DEFINE (scm_objcode_to_bytecode
, "objcode->bytecode", 1, 0, 0,
231 #define FUNC_NAME s_scm_objcode_to_bytecode
233 scm_t_uint8
*u8vector
;
236 SCM_VALIDATE_OBJCODE (1, objcode
);
238 len
= sizeof(struct scm_objcode
) + SCM_OBJCODE_TOTAL_LEN (objcode
);
239 /* FIXME: Is `gc_malloc' ok here? */
240 u8vector
= scm_gc_malloc (len
, "objcode-u8vector");
241 memcpy (u8vector
, SCM_OBJCODE_DATA (objcode
), len
);
243 return scm_take_u8vector (u8vector
, len
);
247 SCM_DEFINE (scm_write_objcode
, "write-objcode", 2, 0, 0,
248 (SCM objcode
, SCM port
),
250 #define FUNC_NAME s_scm_write_objcode
252 SCM_VALIDATE_OBJCODE (1, objcode
);
253 SCM_VALIDATE_OUTPUT_PORT (2, port
);
255 scm_c_write (port
, OBJCODE_COOKIE
, strlen (OBJCODE_COOKIE
));
256 scm_c_write (port
, SCM_OBJCODE_DATA (objcode
),
257 sizeof (struct scm_objcode
) + SCM_OBJCODE_TOTAL_LEN (objcode
));
259 return SCM_UNSPECIFIED
;
265 scm_bootstrap_objcodes (void)
267 scm_tc16_objcode
= scm_make_smob_type ("objcode", 0);
268 scm_set_smob_mark (scm_tc16_objcode
, objcode_mark
);
271 /* Before, we used __BYTE_ORDER, but that is not defined on all
272 systems. So punt and use automake, PDP endianness be damned. */
273 #ifdef WORDS_BIGENDIAN
274 #define SCM_BYTE_ORDER 4321
276 #define SCM_BYTE_ORDER 1234
280 scm_init_objcodes (void)
284 #ifndef SCM_MAGIC_SNARFER
285 #include "libguile/objcodes.x"
288 scm_c_define ("word-size", scm_from_size_t (sizeof(SCM
)));
289 scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER
));