#include <string.h>
#include <fcntl.h>
#include <unistd.h>
+
+#ifdef HAVE_SYS_MMAN_H
#include <sys/mman.h>
+#endif
+
#include <sys/stat.h>
#include <sys/types.h>
#include <assert.h>
#include <alignof.h>
+#include <full-read.h>
+
#include "_scm.h"
#include "programs.h"
#include "objcodes.h"
* Objcode type
*/
+static void
+verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
+#define FUNC_NAME "make_objcode_from_file"
+{
+ /* The cookie ends with a version of the form M.N, where M is the
+ major version and N is the minor version. For this Guile to be
+ able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N
+ must be less than or equal to SCM_OBJCODE_MINOR_VERSION. Since N
+ is the last character, we do a strict comparison on all but the
+ last, then a <= on the last one. */
+ if (memcmp (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1))
+ {
+ SCM args = scm_list_1 (scm_from_latin1_stringn
+ (cookie, strlen (SCM_OBJCODE_COOKIE)));
+ if (map_fd >= 0)
+ {
+ (void) close (map_fd);
+#ifdef HAVE_SYS_MMAN_H
+ (void) munmap (map_addr, st->st_size);
+#endif
+ }
+ scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
+ }
+
+ {
+ char minor_version = cookie[strlen (SCM_OBJCODE_COOKIE) - 1];
+
+ if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0])
+ {
+ if (map_fd >= 0)
+ {
+ (void) close (map_fd);
+#ifdef HAVE_SYS_MMAN_H
+ (void) munmap (map_addr, st->st_size);
+#endif
+ }
+
+ scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
+ scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
+ scm_from_latin1_string
+ (SCM_OBJCODE_MINOR_VERSION_STRING)));
+ }
+ }
+}
+#undef FUNC_NAME
+
/* The words in an objcode SCM object are as follows:
- scm_tc7_objcode | type | flags
- the struct scm_objcode C object
*/
static SCM
-make_objcode_by_mmap (int fd)
-#define FUNC_NAME "make_objcode_by_mmap"
+make_objcode_from_file (int fd)
+#define FUNC_NAME "make_objcode_from_file"
{
int ret;
- char *addr;
+ /* The SCM_OBJCODE_COOKIE is a string literal, and thus has an extra
+ trailing NUL, hence the - 1. */
+ char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
struct stat st;
- SCM sret = SCM_BOOL_F;
- struct scm_objcode *data;
ret = fstat (fd, &st);
if (ret < 0)
SCM_SYSERROR;
- if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
+ if (st.st_size <= sizeof (struct scm_objcode) + sizeof cookie)
scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
scm_list_1 (SCM_I_MAKINUM (st.st_size)));
- addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
- if (addr == MAP_FAILED)
- {
- (void) close (fd);
- SCM_SYSERROR;
- }
-
- /* The cookie ends with a version of the form M.N, where M is the
- major version and N is the minor version. For this Guile to be
- able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N
- must be less than or equal to SCM_OBJCODE_MINOR_VERSION. Since N
- is the last character, we do a strict comparison on all but the
- last, then a <= on the last one. */
- if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1))
- {
- SCM args = scm_list_1 (scm_from_latin1_stringn
- (addr, strlen (SCM_OBJCODE_COOKIE)));
- (void) close (fd);
- (void) munmap (addr, st.st_size);
- scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
- }
-
+#ifdef HAVE_SYS_MMAN_H
{
- char minor_version = addr[strlen (SCM_OBJCODE_COOKIE) - 1];
-
- if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0])
- scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
- scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
- scm_from_latin1_string
- (SCM_OBJCODE_MINOR_VERSION_STRING)));
+ char *addr;
+ struct scm_objcode *data;
+
+ addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
+
+ if (addr == MAP_FAILED)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+ else
+ {
+ memcpy (cookie, addr, sizeof cookie);
+ data = (struct scm_objcode *) (addr + sizeof cookie);
+ }
+
+ verify_cookie (cookie, &st, fd, addr);
+
+
+ if (data->len + data->metalen
+ != (st.st_size - sizeof (*data) - sizeof cookie))
+ {
+ size_t total_len = sizeof (*data) + data->len + data->metalen;
+
+ (void) close (fd);
+ (void) munmap (addr, st.st_size);
+
+ scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+ scm_list_2 (scm_from_size_t (st.st_size),
+ scm_from_size_t (total_len)));
+ }
+
+ /* FIXME: we leak ourselves and the file descriptor. but then again so does
+ dlopen(). */
+ return scm_permanent_object
+ (scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
+ (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
+ SCM_UNPACK (scm_from_int (fd)), 0));
}
+#else
+ {
+ SCM bv = scm_c_make_bytevector (st.st_size - sizeof cookie);
- data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
+ if (full_read (fd, cookie, sizeof cookie) != sizeof cookie
+ || full_read (fd, SCM_BYTEVECTOR_CONTENTS (bv),
+ SCM_BYTEVECTOR_LENGTH (bv)) != SCM_BYTEVECTOR_LENGTH (bv))
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
- if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
- {
- (void) close (fd);
- (void) munmap (addr, st.st_size);
- scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
- scm_list_2 (scm_from_size_t (st.st_size),
- scm_from_uint32 (sizeof (*data) + data->len
- + data->metalen)));
- }
+ (void) close (fd);
- sret = scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
- (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
- SCM_UNPACK (scm_from_int (fd)), 0);
+ verify_cookie (cookie, &st, -1, NULL);
- /* FIXME: we leak ourselves and the file descriptor. but then again so does
- dlopen(). */
- return scm_permanent_object (sret);
+ return scm_bytecode_to_objcode (bv);
+ }
+#endif
}
#undef FUNC_NAME
+
SCM
scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
#define FUNC_NAME "make-objcode-slice"
free (c_file);
if (fd < 0) SCM_SYSERROR;
- return make_objcode_by_mmap (fd);
+ return make_objcode_from_file (fd);
}
#undef FUNC_NAME
projects / platform / upstream / guile.git / commitdiff