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. */
47 #include <sys/types.h>
53 #define OBJCODE_COOKIE "GOOF-0.5"
60 scm_t_bits scm_tc16_objcode
;
63 make_objcode (size_t size
)
64 #define FUNC_NAME "make_objcode"
66 struct scm_objcode
*p
= scm_gc_malloc (sizeof (struct scm_objcode
),
69 p
->base
= scm_gc_malloc (size
, "objcode-base");
71 SCM_RETURN_NEWSMOB (scm_tc16_objcode
, p
);
76 make_objcode_by_mmap (int fd
)
77 #define FUNC_NAME "make_objcode_by_mmap"
82 struct scm_objcode
*p
;
84 ret
= fstat (fd
, &st
);
88 if (st
.st_size
<= strlen (OBJCODE_COOKIE
))
89 scm_misc_error (FUNC_NAME
, "object file too small (~a bytes)",
90 SCM_LIST1 (SCM_I_MAKINUM (st
.st_size
)));
92 addr
= mmap (0, st
.st_size
, PROT_READ
, MAP_SHARED
, fd
, 0);
93 if (addr
== MAP_FAILED
)
96 if (memcmp (addr
, OBJCODE_COOKIE
, strlen (OBJCODE_COOKIE
)))
99 p
= scm_gc_malloc (sizeof (struct scm_objcode
), "objcode");
100 p
->size
= st
.st_size
;
103 SCM_RETURN_NEWSMOB (scm_tc16_objcode
, p
);
108 objcode_free (SCM obj
)
109 #define FUNC_NAME "objcode_free"
111 size_t size
= sizeof (struct scm_objcode
);
112 struct scm_objcode
*p
= SCM_OBJCODE_DATA (obj
);
117 rv
= munmap (p
->base
, p
->size
);
118 if (rv
< 0) SCM_SYSERROR
;
120 if (rv
< 0) SCM_SYSERROR
;
123 scm_gc_free (p
->base
, p
->size
, "objcode-base");
125 scm_gc_free (p
, size
, "objcode");
137 SCM_DEFINE (scm_do_pair
, "do-pair", 2, 0, 0,
139 "This is a stupid test to see how cells work. (Ludo)")
141 static SCM room
[512];
142 static SCM
*where
= &room
[0];
146 if ((scm_t_bits
)where
& 6)
148 /* Align the cell pointer so that Guile considers it as a
149 non-immediate object (see tags.h). */
150 incr
= (scm_t_bits
)where
& 6;
155 printf ("do-pair: pool @ %p, pair @ %p\n", &room
[0], where
);
159 the_pair
= PTR2SCM (where
);
160 /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
161 "mark bitmap" at the end of a supposed cell segment which doesn't
168 SCM_DEFINE (scm_objcode_p
, "objcode?", 1, 0, 0,
171 #define FUNC_NAME s_scm_objcode_p
173 return SCM_BOOL (SCM_OBJCODE_P (obj
));
177 SCM_DEFINE (scm_bytecode_to_objcode
, "bytecode->objcode", 3, 0, 0,
178 (SCM bytecode
, SCM nlocs
, SCM nexts
),
180 #define FUNC_NAME s_scm_bytecode_to_objcode
184 scm_t_array_handle handle
;
186 const scm_t_uint8
*c_bytecode
;
189 if (scm_u8vector_p (bytecode
) != SCM_BOOL_T
)
190 scm_wrong_type_arg (FUNC_NAME
, 1, bytecode
);
191 SCM_VALIDATE_NUMBER (2, nlocs
);
192 SCM_VALIDATE_NUMBER (3, nexts
);
194 c_bytecode
= scm_u8vector_elements (bytecode
, &handle
, &size
, &increment
);
195 assert (increment
== 1);
197 /* Account for the 10 byte-long header. */
199 objcode
= make_objcode (size
);
200 base
= SCM_OBJCODE_BASE (objcode
);
202 memcpy (base
, OBJCODE_COOKIE
, 8);
203 base
[8] = scm_to_uint8 (nlocs
);
204 base
[9] = scm_to_uint8 (nexts
);
206 memcpy (base
+ 10, c_bytecode
, size
- 10);
208 scm_array_handle_release (&handle
);
214 SCM_DEFINE (scm_load_objcode
, "load-objcode", 1, 0, 0,
217 #define FUNC_NAME s_scm_load_objcode
222 SCM_VALIDATE_STRING (1, file
);
224 c_file
= scm_to_locale_string (file
);
225 fd
= open (c_file
, O_RDONLY
);
227 if (fd
< 0) SCM_SYSERROR
;
229 return make_objcode_by_mmap (fd
);
233 SCM_DEFINE (scm_objcode_to_u8vector
, "objcode->u8vector", 1, 0, 0,
236 #define FUNC_NAME s_scm_objcode_to_u8vector
238 scm_t_uint8
*u8vector
;
241 SCM_VALIDATE_OBJCODE (1, objcode
);
243 size
= SCM_OBJCODE_SIZE (objcode
);
244 /* FIXME: Is `gc_malloc' ok here? */
245 u8vector
= scm_gc_malloc (size
, "objcode-u8vector");
246 memcpy (u8vector
, SCM_OBJCODE_BASE (objcode
), size
);
248 return scm_take_u8vector (u8vector
, size
);
252 SCM_DEFINE (scm_objcode_to_program
, "objcode->program", 1, 0, 0,
255 #define FUNC_NAME s_scm_objcode_to_program
260 struct scm_program
*p
;
262 SCM_VALIDATE_OBJCODE (1, objcode
);
264 base
= SCM_OBJCODE_BASE (objcode
);
265 size
= SCM_OBJCODE_SIZE (objcode
);
266 prog
= scm_c_make_program (base
+ 10, size
- 10, objcode
);
267 p
= SCM_PROGRAM_DATA (prog
);
276 scm_init_objcodes (void)
278 scm_tc16_objcode
= scm_make_smob_type ("objcode", 0);
279 scm_set_smob_free (scm_tc16_objcode
, objcode_free
);
281 #ifndef SCM_MAGIC_SNARFER
282 #include "objcodes.x"