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
);
85 if ((ret
< 0) || (st
.st_size
<= strlen (OBJCODE_COOKIE
)))
88 addr
= mmap (0, st
.st_size
, PROT_READ
, MAP_SHARED
, fd
, 0);
89 if (addr
== MAP_FAILED
)
92 if (memcmp (addr
, OBJCODE_COOKIE
, strlen (OBJCODE_COOKIE
)))
95 p
= scm_gc_malloc (sizeof (struct scm_objcode
), "objcode");
99 SCM_RETURN_NEWSMOB (scm_tc16_objcode
, p
);
104 objcode_free (SCM obj
)
105 #define FUNC_NAME "objcode_free"
107 size_t size
= sizeof (struct scm_objcode
);
108 struct scm_objcode
*p
= SCM_OBJCODE_DATA (obj
);
113 rv
= munmap (p
->base
, p
->size
);
114 if (rv
< 0) SCM_SYSERROR
;
116 if (rv
< 0) SCM_SYSERROR
;
119 scm_gc_free (p
->base
, p
->size
, "objcode-base");
121 scm_gc_free (p
, size
, "objcode");
133 SCM_DEFINE (scm_do_pair
, "do-pair", 2, 0, 0,
135 "This is a stupid test to see how cells work. (Ludo)")
137 static SCM room
[512];
138 static SCM
*where
= &room
[0];
142 if ((scm_t_bits
)where
& 6)
144 /* Align the cell pointer so that Guile considers it as a
145 non-immediate object (see tags.h). */
146 incr
= (scm_t_bits
)where
& 6;
151 printf ("do-pair: pool @ %p, pair @ %p\n", &room
[0], where
);
155 the_pair
= PTR2SCM (where
);
156 /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
157 "mark bitmap" at the end of a supposed cell segment which doesn't
164 SCM_DEFINE (scm_objcode_p
, "objcode?", 1, 0, 0,
167 #define FUNC_NAME s_scm_objcode_p
169 return SCM_BOOL (SCM_OBJCODE_P (obj
));
173 SCM_DEFINE (scm_bytecode_to_objcode
, "bytecode->objcode", 3, 0, 0,
174 (SCM bytecode
, SCM nlocs
, SCM nexts
),
176 #define FUNC_NAME s_scm_bytecode_to_objcode
180 scm_t_array_handle handle
;
182 const char *c_bytecode
;
185 if (scm_u8vector_p (bytecode
) != SCM_BOOL_T
)
186 scm_wrong_type_arg (FUNC_NAME
, 1, bytecode
);
187 SCM_VALIDATE_NUMBER (2, nlocs
);
188 SCM_VALIDATE_NUMBER (3, nexts
);
190 c_bytecode
= scm_u8vector_elements (bytecode
, &handle
, &size
, &increment
);
191 assert (increment
== 1);
193 /* Account for the 10 byte-long header. */
195 objcode
= make_objcode (size
);
196 base
= SCM_OBJCODE_BASE (objcode
);
198 memcpy (base
, OBJCODE_COOKIE
, 8);
199 base
[8] = scm_to_uint8 (nlocs
);
200 base
[9] = scm_to_uint8 (nexts
);
202 memcpy (base
+ 10, c_bytecode
, size
- 10);
204 scm_array_handle_release (&handle
);
210 SCM_DEFINE (scm_load_objcode
, "load-objcode", 1, 0, 0,
213 #define FUNC_NAME s_scm_load_objcode
218 SCM_VALIDATE_STRING (1, file
);
220 c_file
= scm_to_locale_string (file
);
221 fd
= open (c_file
, O_RDONLY
);
223 if (fd
< 0) SCM_SYSERROR
;
225 return make_objcode_by_mmap (fd
);
229 SCM_DEFINE (scm_objcode_to_u8vector
, "objcode->u8vector", 1, 0, 0,
232 #define FUNC_NAME s_scm_objcode_to_u8vector
237 SCM_VALIDATE_OBJCODE (1, objcode
);
239 size
= SCM_OBJCODE_SIZE (objcode
);
240 /* FIXME: Is `gc_malloc' ok here? */
241 u8vector
= scm_gc_malloc (size
, "objcode-u8vector");
242 memcpy (u8vector
, SCM_OBJCODE_BASE (objcode
), size
);
244 return scm_take_u8vector (u8vector
, size
);
248 SCM_DEFINE (scm_objcode_to_program
, "objcode->program", 1, 0, 0,
251 #define FUNC_NAME s_scm_objcode_to_program
256 struct scm_program
*p
;
258 SCM_VALIDATE_OBJCODE (1, objcode
);
260 base
= SCM_OBJCODE_BASE (objcode
);
261 size
= SCM_OBJCODE_SIZE (objcode
);
262 prog
= scm_c_make_program (base
+ 10, size
- 10, objcode
);
263 p
= SCM_PROGRAM_DATA (prog
);
272 scm_init_objcodes (void)
274 scm_tc16_objcode
= scm_make_smob_type ("objcode", 0);
275 scm_set_smob_free (scm_tc16_objcode
, objcode_free
);
277 #ifndef SCM_MAGIC_SNARFER
278 #include "objcodes.x"