tmtt
/
chez-openbsd
Archived
1
0
Fork 0
Code Issues Pull Requests Releases 1 Activity
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
This repo is archived. You can view files and clone it, but cannot push or open issues/pull-requests.
main
v9.5.9
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'main'
${ noResults }
chez-openbsd/c/scheme.c

1274 lines
36 KiB
C
Raw Permalink Blame History

/* scheme.c
* Copyright 1984-2017 Cisco Systems, Inc.
*
* Licensed under the Apache License, Version 2.0 (the "License");
* you may not use this file except in compliance with the License.
* You may obtain a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing, software
* distributed under the License is distributed on an "AS IS" BASIS,
* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
* See the License for the specific language governing permissions and
* limitations under the License.
*/
#include "system.h"
#include "config.h"
#include <setjmp.h>
#include <limits.h>
#ifdef WIN32
#include <io.h>
#else
#include <sys/time.h>
#endif
#include <fcntl.h>
#include <stddef.h>
#ifndef O_BINARY
#define O_BINARY 0
#endif /* O_BINARY */
static INT boot_count;
static IBOOL verbose;
typedef enum { UNINITIALIZED, BOOTING, RUNNING, DEINITIALIZED } heap_state;
static heap_state current_state = UNINITIALIZED;
/***************************************************************************/
/* INITIALIZATION SUPPORT */
/* locally defined functions */
static void main_init(void);
static void idiot_checks(void);
static INT run_script(const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp);
extern void scheme_include(void);
static void main_init(void) {
ptr tc = get_thread_context();
ptr p;
INT i;
/* create dependency for linker */
scheme_statics();
/* force thread inline allocation to go through find_room until ready */
AP(tc) = (ptr)0;
EAP(tc) = (ptr)0;
REAL_EAP(tc) = (ptr)0;
/* set up dummy CP so locking in read/write/Scall won't choke */
CP(tc) = Svoid;
CODERANGESTOFLUSH(tc) = Snil;
if (S_boot_time) S_G.protect_next = 0;
S_segment_init();
S_alloc_init();
S_thread_init();
S_intern_init();
S_gc_init();
S_number_init();
S_schsig_init();
S_new_io_init();
S_print_init();
S_stats_init();
S_foreign_init();
S_prim_init();
S_prim5_init();
S_fasl_init();
S_machine_init();
S_flushcache_init(); /* must come after S_machine_init(); */
#ifdef FEATURE_EXPEDITOR
S_expeditor_init();
#endif /* FEATURE_EXPEDITOR */
if (!S_boot_time) return;
S_protect(&S_G.profile_counters);
S_G.profile_counters = Snil;
FXLENGTHBV(tc) = p = S_bytevector(256);
for (i = 0; i < 256; i += 1) {
BVIT(p, i) =
(iptr)FIX(i & 0x80 ? 8 : i & 0x40 ? 7 : i & 0x20 ? 6 : i & 0x10 ? 5 :
i & 0x08 ? 4 : i & 0x04 ? 3 : i & 0x02 ? 2 : i & 0x01 ? 1 : 0);
}
FXFIRSTBITSETBV(tc) = p = S_bytevector(256);
for (i = 0; i < 256; i += 1) {
BVIT(p, i) =
(iptr)FIX(i & 0x01 ? 0 : i & 0x02 ? 1 : i & 0x04 ? 2 : i & 0x08 ? 3 :
i & 0x10 ? 4 : i & 0x20 ? 5 : i & 0x40 ? 6 : i & 0x80 ? 7 : 0);
}
NULLIMMUTABLEVECTOR(tc) = S_null_immutable_vector();
NULLIMMUTABLEFXVECTOR(tc) = S_null_immutable_fxvector();
NULLIMMUTABLEBYTEVECTOR(tc) = S_null_immutable_bytevector();
NULLIMMUTABLESTRING(tc) = S_null_immutable_string();
PARAMETERS(tc) = S_G.null_vector;
for (i = 0 ; i < virtual_register_count ; i += 1) {
VIRTREG(tc, i) = FIX(0);
}
p = S_code(tc, type_code, size_rp_header);
CODERELOC(p) = S_relocation_table(0);
CODENAME(p) = Sfalse;
CODEARITYMASK(p) = FIX(0);
CODEFREE(p) = 0;
CODEINFO(p) = Sfalse;
CODEPINFOS(p) = Snil;
RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0;
RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0;
RPHEADERTOPLINK(&CODEIT(p, 0)) =
(uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p;
S_protect(&S_G.dummy_code_object);
S_G.dummy_code_object = p;
S_protect(&S_G.error_invoke_code_object);
S_G.error_invoke_code_object = Snil;
S_protect(&S_G.invoke_code_object);
S_G.invoke_code_object = Snil;
S_protect(&S_G.active_threads_id);
S_G.active_threads_id = S_intern((const unsigned char *)"$active-threads");
S_set_symbol_value(S_G.active_threads_id, FIX(0));
S_protect(&S_G.heap_reserve_ratio_id);
S_G.heap_reserve_ratio_id = S_intern((const unsigned char *)"$heap-reserve-ratio");
SETSYMVAL(S_G.heap_reserve_ratio_id, Sflonum(default_heap_reserve_ratio));
S_protect(&S_G.scheme_version_id);
S_G.scheme_version_id = S_intern((const unsigned char *)"$scheme-version");
S_protect(&S_G.make_load_binary_id);
S_G.make_load_binary_id = S_intern((const unsigned char *)"$make-load-binary");
S_protect(&S_G.load_binary);
S_G.load_binary = Sfalse;
}
static ptr fixtest = FIX(-1);
static void idiot_checks(void) {
IBOOL oops = 0;
if (bytes_per_segment < S_pagesize) {
fprintf(stderr, "bytes_per_segment (%x) < S_pagesize (%lx)\n",
bytes_per_segment, (long)S_pagesize);
oops = 1;
}
if (sizeof(iptr) != sizeof(ptr)) {
fprintf(stderr, "sizeof(iptr) [%ld] != sizeof(ptr) [%ld]\n",
(long)sizeof(iptr), (long)sizeof(ptr));
oops = 1;
}
if (sizeof(uptr) != sizeof(ptr)) {
fprintf(stderr, "sizeof(uptr) [%ld] != sizeof(ptr) [%ld]\n",
(long)sizeof(uptr), (long)sizeof(ptr));
oops = 1;
}
if (sizeof(ptr) * 8 != ptr_bits) {
fprintf(stderr, "sizeof(ptr) * 8 [%ld] != ptr_bits [%d]\n",
(long)sizeof(ptr), ptr_bits);
oops = 1;
}
if (sizeof(int) * 8 != int_bits) {
fprintf(stderr, "sizeof(int) * 8 [%ld] != int_bits [%d]\n",
(long)sizeof(int), int_bits);
oops = 1;
}
if (sizeof(short) * 8 != short_bits) {
fprintf(stderr, "sizeof(short) * 8 [%ld] != short_bits [%d]\n",
(long)sizeof(short), short_bits);
oops = 1;
}
if (sizeof(long) * 8 != long_bits) {
fprintf(stderr, "sizeof(long) * 8 [%ld] != long_bits [%d]\n",
(long)sizeof(long), long_bits);
oops = 1;
}
#ifndef WIN32
if (sizeof(long long) * 8 != long_long_bits) {
fprintf(stderr, "sizeof(long long) * 8 [%ld] != long_long_bits [%d]\n",
(long)sizeof(long long), long_long_bits);
oops = 1;
}
#endif
if (sizeof(wchar_t) * 8 != wchar_bits) {
fprintf(stderr, "sizeof(wchar_t) * 8 [%ld] != wchar_bits [%d]\n",
(long)sizeof(wchar_t), wchar_bits);
oops = 1;
}
if (sizeof(size_t) * 8 != size_t_bits) {
fprintf(stderr, "sizeof(size_t) * 8 [%ld] != size_t_bits [%d]\n",
(long)sizeof(size_t), size_t_bits);
oops = 1;
}
#ifndef WIN32
if (sizeof(ssize_t) * 8 != size_t_bits) {
fprintf(stderr, "sizeof(ssize_t) * 8 [%ld] != size_t_bits [%d]\n",
(long)sizeof(ssize_t), size_t_bits);
oops = 1;
}
#endif
if (sizeof(ptrdiff_t) * 8 != ptrdiff_t_bits) {
fprintf(stderr, "sizeof(ptrdiff_t) * 8 [%ld] != ptrdiff_t_bits [%d]\n",
(long)sizeof(ptrdiff_t), ptrdiff_t_bits);
oops = 1;
}
if (sizeof(time_t) * 8 != time_t_bits) {
fprintf(stderr, "sizeof(time_t) * 8 [%ld] != time_t_bits [%d]\n",
(long)sizeof(time_t), time_t_bits);
oops = 1;
}
if (sizeof(bigit) * 8 != bigit_bits) {
fprintf(stderr, "sizeof(bigit) * 8 [%ld] != bigit_bits [%d]\n",
(long)sizeof(bigit), bigit_bits);
oops = 1;
}
if (sizeof(bigitbigit) != 2 * sizeof(bigit)) {
fprintf(stderr, "sizeof(bigitbigit) [%ld] != sizeof(bigit) [%ld] * 2\n",
(long)sizeof(bigitbigit), (long)sizeof(bigit));
oops = 1;
}
if (sizeof(char) != 1) {
fprintf(stderr, "sizeof(char) [%ld] != 1\n", (long)sizeof(char));
oops = 1;
}
if (sizeof(I8) != 1) {
fprintf(stderr, "sizeof(I8) [%ld] != 1\n", (long)sizeof(I8));
oops = 1;
}
if (sizeof(U8) != 1) {
fprintf(stderr, "sizeof(U8) [%ld] != 1\n", (long)sizeof(U8));
oops = 1;
}
if (sizeof(I16) != 2) {
fprintf(stderr, "sizeof(I16) [%ld] != 2\n", (long)sizeof(I16));
oops = 1;
}
if (sizeof(U16) != 2) {
fprintf(stderr, "sizeof(U16) [%ld] != 2\n", (long)sizeof(U16));
oops = 1;
}
if (sizeof(I32) != 4) {
fprintf(stderr, "sizeof(I32) [%ld] != 4\n", (long)sizeof(I32));
oops = 1;
}
if (sizeof(U32) != 4) {
fprintf(stderr, "sizeof(U32) [%ld] != 4\n", (long)sizeof(U32));
oops = 1;
}
if (sizeof(I64) != 8) {
fprintf(stderr, "sizeof(I64) [%ld] != 8\n", (long)sizeof(I64));
oops = 1;
}
if (sizeof(U64) != 8) {
fprintf(stderr, "sizeof(U64) [%ld] != 8\n", (long)sizeof(U64));
oops = 1;
}
if (sizeof(string_char) != string_char_bytes) {
fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes);
oops = 1;
}
if (UNFIX(fixtest) != -1) {
fprintf(stderr, "UNFIX operation failed\n");
oops = 1;
}
if (strlen(VERSION)+1 > HEAP_VERSION_LENGTH) {
fprintf(stderr, "insufficient space for version in heap header\n");
oops = 1;
}
if (strlen(MACHINE_TYPE)+1 > HEAP_MACHID_LENGTH) {
fprintf(stderr, "insufficient space for machine id in heap header\n");
oops = 1;
}
#define big 0
#define little 1
if (native_endianness == big) {
uptr x[1];
*x = 1;
if (*(char *)x != 0) {
fprintf(stderr, "endianness claimed to be big, appears to be little\n");
oops = 1;
}
} else {
uptr x[1];
*x = 1;
if (*(char *)x == 0) {
fprintf(stderr, "endianness claimed to be little, appears to be big\n");
oops = 1;
}
}
if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) {
/* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */
fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n");
oops = 1;
}
if ((cards_per_segment & (sizeof(iptr) - 1)) != 0) {
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
fprintf(stderr, "cards_per_segment is not a multiple of sizeof(iptr)\n");
oops = 1;
}
if (((uptr)(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) {
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n");
oops = 1;
}
if (!Sfixnump(type_vector | ~mask_vector)) {
/* gc counts on vector type/length looking like a fixnum, so it can put vectors in space_impure */
fprintf(stderr, "vector type/length field does not look like a fixnum\n");
oops = 1;
}
if (oops) S_abnormal_exit();
}
/***************************************************************************/
/* SUPPORT FOR CALLING INTO SCHEME */
/* locally defined functions */
static ptr boot_call(ptr tc, ptr p, INT n);
static void check_ap(ptr tc);
/* arguments and ac0 set up */
static ptr boot_call(ptr tc, ptr p, INT n) {
AC1(tc) = p;
CP(tc) = Svoid; /* don't have calling code object */
AC0(tc) = (ptr)(uptr)n;
S_call_help(tc, 0, 0);
check_ap(tc);
CP(tc) = Svoid; /* leave clean so direct Scall won't choke */
switch ((iptr)AC1(tc)) {
case 1:
p = AC0(tc);
break;
case 0:
p = Svoid;
break;
default:
p = S_get_scheme_arg(tc, 1);
break;
}
return p;
}
static void check_ap(ptr tc) {
if ((uptr)AP(tc) & (byte_alignment - 1)) {
(void) fprintf(stderr, "ap is not double word aligned\n");
S_abnormal_exit();
}
if ((ptr *)AP(tc) > (ptr *)EAP(tc)) {
(void) fprintf(stderr, "ap is greater than eap\n");
S_abnormal_exit();
}
}
void S_generic_invoke(ptr tc, ptr code) {
#if defined(PPCAIX)
struct {caddr_t entry, toc, static_link;} hdr;
hdr.entry = (caddr_t)&CODEIT(code,0);
hdr.toc = (caddr_t)0;
hdr.static_link = (caddr_t)0;
(*((void (*)(ptr))(void *)&hdr))(tc);
#elif defined(PPCNT)
/* under NT, function headers contain no static link */
struct {I32 entry, toc;} hdr;
typedef void (*ugly)(ptr);
ugly p;
hdr.entry = (I32)&CODEIT(code,0);
hdr.toc = (I32)0;
/* MSVC++ bombs with internal compiler error if we don't split this up */
p = (ugly)&hdr;
p(tc);
#elif defined(PARISC)
struct {I32 entry, env;} hdr;
typedef void (*ugly)(ptr);
ugly p;
hdr.entry = (I32)&CODEIT(code,0);
hdr.env = (I32)0;
p = (ugly)((I32)&hdr + 2);
p(tc);
#elif defined(WIN32) && !defined(__MINGW32__)
__try {
(*((void (*)(ptr))(void *)&CODEIT(code,0)))(tc);
}
__except(GetExceptionCode() == EXCEPTION_ACCESS_VIOLATION ?
EXCEPTION_EXECUTE_HANDLER : EXCEPTION_CONTINUE_SEARCH)
{
if (S_pants_down)
S_error_abort("nonrecoverable invalid memory reference");
else
S_error_reset("invalid memory reference");
}
#else
(*((void (*)(ptr))(void *)&CODEIT(code,0)))(tc);
#endif
}
/***************************************************************************/
/* MISCELLANEOUS HELPERS */
/* locally defined functions */
static IBOOL next_path(char *path, const char *name, const char *ext, const char **sp, const char **dsp);
static const char *path_last(const char *path);
static char *get_defaultheapdirs(void);
static const char *path_last(p) const char *p; {
const char *s;
#ifdef WIN32
char c;
if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
if (*(p + 1) == ':')
p += 2;
#endif
for (s = p; *s != 0; s += 1)
if (DIRMARKERP(*s)) p = ++s;
return p;
}
#ifdef WIN32
#ifndef DEFAULT_HEAP_PATH
/* by default, look in executable directory or in parallel boot directory */
#define DEFAULT_HEAP_PATH "%x;%x\\..\\..\\boot\\%m"
#endif
#define SEARCHPATHSEP ';'
#define PATHSEP '\\'
static char *get_defaultheapdirs() {
char *result;
wchar_t buf[PATH_MAX];
DWORD len = sizeof(buf);
if (ERROR_SUCCESS != RegGetValueW(HKEY_LOCAL_MACHINE, L"Software\\Chez Scheme\\csv" VERSION, L"HeapSearchPath", RRF_RT_REG_SZ, NULL, buf, &len))
return DEFAULT_HEAP_PATH;
else if ((result = Swide_to_utf8(buf)))
return result;
else
return DEFAULT_HEAP_PATH;
}
#else /* not WIN32: */
#define SEARCHPATHSEP ':'
#define PATHSEP '/'
#ifndef DEFAULT_HEAP_PATH
#define DEFAULT_HEAP_PATH "/usr/lib/csv%v/%m:/usr/local/lib/csv%v/%m"
#endif
static char *get_defaultheapdirs() {
return DEFAULT_HEAP_PATH;
}
#endif /* WIN32 */
/* next_path isolates the next entry in the two-part search path sp/dsp,
* leaving the full path with name affixed in path and *sp / *dsp pointing
* past the current entry. it returns 1 on success and 0 if at the end of
* the search path. path should be a pointer to an unoccupied buffer
* PATH_MAX characters long. either or both of sp/dsp may be empty,
* but neither may be null, i.e., (char *)0. */
static IBOOL next_path(char *path, const char *name, const char *ext,
const char **sp, const char **dsp) {
char *p;
const char *s, *t;
#define setp(c) if (p >= path + PATH_MAX) { fprintf(stderr, "search path entry too long\n"); S_abnormal_exit(); } else *p++ = (c)
for (;;) {
s = *sp;
p = path;
/* copy first searchpath entry into path, substituting MACHINE_TYPE for %m,
* VERSION for %v, % for %%, and : (; windows) for %: (%; windows) */
while (*s != 0 && *s != SEARCHPATHSEP) {
switch (*s) {
case '%':
s += 1;
switch (*s) {
#ifdef WIN32
case 'x': {
wchar_t exepath[PATH_MAX]; DWORD n;
s += 1;
n = GetModuleFileNameW(NULL, exepath, PATH_MAX);
if (n == 0 || (n == PATH_MAX && GetLastError() == ERROR_INSUFFICIENT_BUFFER)) {
fprintf(stderr, "warning: executable path is too long; ignoring %%x\n");
} else {
char *tstart;
const char *tend;
tstart = Swide_to_utf8(exepath);
t = tstart;
tend = path_last(t);
if (tend != t) tend -= 1; /* back up to directory separator */
while (t != tend) setp(*t++);
free(tstart);
}
break;
}
#endif
case 'm':
s += 1;
t = MACHINE_TYPE;
while (*t != 0) setp(*t++);
break;
case 'v':
s += 1;
t = VERSION;
while (*t != 0) setp(*t++);
break;
case '%':
case SEARCHPATHSEP:
setp(*s++);
break;
default:
fprintf(stderr, "warning: ignoring extra %% in search path\n");
break;
}
break;
default:
setp(*s++);
break;
}
}
/* unless entry was null, append name and ext onto path and return true with
* updated path, sp, and possibly dsp */
if (s != *sp) {
if ((p > path) && !DIRMARKERP(*(p - 1))) { setp(PATHSEP); }
t = name;
while (*t != 0) setp(*t++);
t = ext;
while (*t != 0) setp(*t++);
setp(0);
*sp = s;
return 1;
}
/* if current segment is empty, move to next segment. if next segment
* is empty, return false */
if (*s == 0) {
if (*(*sp = *dsp) == 0) return 0;
*dsp = "";
} else {
*sp = s + 1;
}
}
#undef setp
}
/***************************************************************************/
/* BOOT FILES */
typedef struct {
INT fd;
char path[PATH_MAX];
} boot_desc;
#define MAX_BOOT_FILES 10
static boot_desc bd[MAX_BOOT_FILES];
/* locally defined functions */
static char get_u8(INT fd);
static uptr get_uptr(INT fd, uptr *pn);
static INT get_string(INT fd, char *s, iptr max, INT *c);
static IBOOL find_boot(const char *name, const char *ext, int fd, IBOOL errorp);
static void load(ptr tc, iptr n, IBOOL base);
static void check_boot_file_state(const char *who);
static IBOOL find_boot(const char *name, const char *ext, int fd, IBOOL errorp) {
char pathbuf[PATH_MAX], buf[PATH_MAX];
uptr n = 0;
INT c;
const char *path;
char *expandedpath;
if ((fd != -1) || S_fixedpathp(name)) {
if (strlen(name) >= PATH_MAX) {
fprintf(stderr, "boot-file path is too long %s\n", name);
S_abnormal_exit();
}
path = name;
if (fd == -1) {
expandedpath = S_malloc_pathname(path);
fd = OPEN(expandedpath, O_BINARY|O_RDONLY, 0);
free(expandedpath);
}
if (fd == -1) {
if (errorp) {
fprintf(stderr, "cannot open boot file %s\n", path);
S_abnormal_exit();
} else {
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
return 0;
}
}
if (verbose) fprintf(stderr, "trying %s...opened\n", path);
/* check for magic number */
if (get_u8(fd) != fasl_type_header ||
get_u8(fd) != 0 ||
get_u8(fd) != 0 ||
get_u8(fd) != 0 ||
get_u8(fd) != 'c' ||
get_u8(fd) != 'h' ||
get_u8(fd) != 'e' ||
get_u8(fd) != 'z') {
fprintf(stderr, "malformed fasl-object header in %s\n", path);
S_abnormal_exit();
}
/* check version */
if (get_uptr(fd, &n) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path);
CLOSE(fd);
S_abnormal_exit();
}
if (n != scheme_version) {
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
/* use separate fprintf since S_format_scheme_version returns static string */
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
CLOSE(fd);
S_abnormal_exit();
}
/* check machine type */
if (get_uptr(fd, &n) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path);
CLOSE(fd);
S_abnormal_exit();
}
if (n != machine_type) {
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
S_lookup_machine_type(n), S_lookup_machine_type(machine_type));
CLOSE(fd);
S_abnormal_exit();
}
} else {
const char *sp = Sschemeheapdirs;
const char *dsp = Sdefaultheapdirs;
path = pathbuf;
for (;;) {
if (!next_path(pathbuf, name, ext, &sp, &dsp)) {
if (errorp) {
fprintf(stderr, "cannot find compatible boot file %s%s in search path:\n \"%s%s\"\n",
name, ext,
Sschemeheapdirs, Sdefaultheapdirs);
S_abnormal_exit();
} else {
if (verbose) fprintf(stderr, "no compatible %s%s found\n", name, ext);
return 0;
}
}
expandedpath = S_malloc_pathname(path);
fd = OPEN(expandedpath, O_BINARY|O_RDONLY, 0);
free(expandedpath);
if (fd == -1) {
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
continue;
}
if (verbose) fprintf(stderr, "trying %s...opened\n", path);
/* check for magic number */
if (get_u8(fd) != fasl_type_header ||
get_u8(fd) != 0 ||
get_u8(fd) != 0 ||
get_u8(fd) != 0 ||
get_u8(fd) != 'c' ||
get_u8(fd) != 'h' ||
get_u8(fd) != 'e' ||
get_u8(fd) != 'z') {
if (verbose) fprintf(stderr, "malformed fasl-object header in %s\n", path);
CLOSE(fd);
continue;
}
/* check version */
if (get_uptr(fd, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
CLOSE(fd);
continue;
}
if (n != scheme_version) {
if (verbose) {
fprintf(stderr, "%s is for Version %s; ", path, S_format_scheme_version(n));
/* use separate fprintf since S_format_scheme_version returns static string */
fprintf(stderr, "need Version %s\n", S_format_scheme_version(scheme_version));
}
CLOSE(fd);
continue;
}
/* check machine type */
if (get_uptr(fd, &n) != 0) {
if (verbose) fprintf(stderr, "unexpected end of file on %s\n", path);
CLOSE(fd);
continue;
}
if (n != machine_type) {
if (verbose)
fprintf(stderr, "%s is for machine-type %s; need machine-type %s\n", path,
S_lookup_machine_type(n), S_lookup_machine_type(machine_type));
CLOSE(fd);
continue;
}
break;
}
}
if (verbose) fprintf(stderr, "version and machine type check\n");
if (get_u8(fd) != '(') { /* ) */
fprintf(stderr, "malformed boot file %s\n", path);
CLOSE(fd);
S_abnormal_exit();
}
/* ( */
if ((c = get_u8(fd)) == ')') {
if (boot_count != 0) {
fprintf(stderr, "base boot file %s must come before other boot files\n", path);
CLOSE(fd);
S_abnormal_exit();
}
} else {
if (boot_count == 0) {
for (;;) {
/* try to load heap or boot file this boot file requires */
if (get_string(fd, buf, PATH_MAX, &c) != 0) {
fprintf(stderr, "unexpected end of file on %s\n", path);
CLOSE(fd);
S_abnormal_exit();
}
if (find_boot(buf, ".boot", -1, 0)) break;
if (c == ')') {
char *sep; char *wastebuf[8];
fprintf(stderr, "cannot find subordinate boot file");
if (LSEEK(fd, 0, SEEK_SET) != 0 || READ(fd, wastebuf, 8) != 8) { /* attempt to rewind and read magic number */
fprintf(stderr, "---retry with verbose flag for more information\n");
CLOSE(fd);
S_abnormal_exit();
}
(void) get_uptr(fd, &n); /* version */
(void) get_uptr(fd, &n); /* machine type */
(void) get_u8(fd); /* open paren */
c = get_u8(fd);
for (sep = " "; ; sep = "or ") {
if (c == ')') break;
(void) get_string(fd, buf, PATH_MAX, &c);
fprintf(stderr, "%s%s.boot ", sep, buf);
}
fprintf(stderr, "required by %s\n", path);
CLOSE(fd);
S_abnormal_exit();
}
}
}
/* skip to end of header */
while (c != ')') {
if (c < 0) {
fprintf(stderr, "malformed boot file %s\n", path);
CLOSE(fd);
S_abnormal_exit();
}
c = get_u8(fd);
}
}
if (boot_count >= MAX_BOOT_FILES) {
fprintf(stderr, "exceeded maximum number of boot files (%d)\n", MAX_BOOT_FILES);
S_abnormal_exit();
}
bd[boot_count].fd = fd;
strcpy(bd[boot_count].path, path);
boot_count += 1;
return 1;
}
static char get_u8(INT fd) {
char buf[1];
if (READ(fd, &buf, 1) != 1) return -1;
return buf[0];
}
static uptr get_uptr(INT fd, uptr *pn) {
uptr n, m; int c; octet k;
if ((c = get_u8(fd)) < 0) return -1;
k = (octet)c;
n = k >> 1;
while (k & 1) {
if ((c = get_u8(fd)) < 0) return -1;
k = (octet)c;
m = n << 7;
if (m >> 7 != n) return -1;
n = m | (k >> 1);
}
*pn = n;
return 0;
}
static INT get_string(INT fd, char *s, iptr max, INT *c) {
while (max-- > 0) {
if (*c < 0) return -1;
if (*c == ' ' || *c == ')') {
if (*c == ' ') *c = get_u8(fd);
*s = 0;
return 0;
}
*s++ = *c;
*c = get_u8(fd);
}
return -1;
}
static IBOOL loadecho = 0;
#define LOADSKIP 0
static int set_load_binary(iptr n) {
if (!Ssymbolp(SYMVAL(S_G.scheme_version_id))) return 0; // set by back.ss
ptr make_load_binary = SYMVAL(S_G.make_load_binary_id);
if (Sprocedurep(make_load_binary)) {
S_G.load_binary = Scall1(make_load_binary, Sstring_utf8(bd[n].path, -1));
return 1;
}
return 0;
}
static void load(ptr tc, iptr n, IBOOL base) {
ptr x; iptr i;
if (base) {
S_G.error_invoke_code_object = S_boot_read(bd[n].fd, bd[n].path);
if (!Scodep(S_G.error_invoke_code_object)) {
(void) fprintf(stderr, "first object on boot file not code object\n");
S_abnormal_exit();
}
S_G.invoke_code_object = S_boot_read(bd[n].fd, bd[n].path);
if (!Scodep(S_G.invoke_code_object)) {
(void) fprintf(stderr, "second object on boot file not code object\n");
S_abnormal_exit();
}
S_G.base_rtd = S_boot_read(bd[n].fd, bd[n].path);
if (!Srecordp(S_G.base_rtd)) {
S_abnormal_exit();
}
}
i = 0;
while (i++ < LOADSKIP && S_boot_read(bd[n].fd, bd[n].path) != Seof_object);
while ((x = S_boot_read(bd[n].fd, bd[n].path)) != Seof_object) {
if (loadecho) {
printf("%ld: ", (long)i);
fflush(stdout);
}
if (Sprocedurep(x)) {
S_initframe(tc, 0);
x = boot_call(tc, x, 0);
} else if (Sprocedurep(S_G.load_binary) || set_load_binary(n)) {
S_initframe(tc, 1);
S_put_arg(tc, 1, x);
x = boot_call(tc, S_G.load_binary, 1);
}
if (loadecho) {
S_prin1(x);
putchar('\n');
fflush(stdout);
}
i += 1;
}
S_G.load_binary = Sfalse;
CLOSE(bd[n].fd);
}
/***************************************************************************/
/* HEAP FILES */
#ifdef DEBUG
#define debug(x) {x}
#else
#define debug(x)
#endif
#include <fcntl.h>
#include <sys/types.h>
#ifdef WIN32
#include <io.h>
#endif /* WIN32 */
#ifdef MMAP_HEAP
#include <sys/mman.h>
#endif
#ifndef O_BINARY
#define O_BINARY 0
#endif /* O_BINARY */
#define check(expr,path) {if ((INT)(expr) < 0) {perror(path); S_abnormal_exit();}}
/***************************************************************************/
/* EXPORTED ROUTINES */
const char *Skernel_version(void) {
return VERSION;
}
extern void Sset_verbose(INT v) {
verbose = v;
}
extern void Sretain_static_relocation(void) {
S_G.retain_static_relocation = 1;
}
#if defined(CHECK_FOR_ROSETTA)
#include <sys/sysctl.h>
int is_rosetta = 0;
static void init_rosetta_check(void) {
int val = 0;
size_t size = sizeof(val);
if (sysctlbyname("sysctl.proc_translated", &val, &size, NULL, 0) != 0) {
if (errno == ENOENT) {
is_rosetta = 0;
} else {
perror("checking to see if running under Rosetta");
// if for some reason we can't tell whether we are running under Rosetta or not,
// default to the safer choice. It doesn't impact correctness to do the Rosetta
// workarounds when they are not needed.
is_rosetta = 1;
}
}
is_rosetta = val;
}
#endif
#ifdef ITEST
#include "itest.c"
#endif
static void default_abnormal_exit(void) {
exit(1);
}
extern void Sscheme_init(void (*abnormal_exit)(void)) {
S_abnormal_exit_proc = abnormal_exit ? abnormal_exit : default_abnormal_exit;
S_errors_to_console = 1;
/* set before idiot checks */
S_pagesize = GETPAGESIZE();
idiot_checks();
#if defined(CHECK_FOR_ROSETTA)
init_rosetta_check();
#endif
switch (current_state) {
case RUNNING:
fprintf(stderr, "error (Sscheme_init): call Sscheme_deinit first to terminate\n");
S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (Sscheme_init): already initialized\n");
S_abnormal_exit();
case UNINITIALIZED:
case DEINITIALIZED:
break;
}
current_state = BOOTING;
S_G.retain_static_relocation = 0;
S_G.enable_object_counts = 0;
boot_count = 0;
#ifdef WIN32
Sschemeheapdirs = Sgetenv("SCHEMEHEAPDIRS");
#else
Sschemeheapdirs = getenv("SCHEMEHEAPDIRS");
#endif
if (Sschemeheapdirs == (char *)0) {
Sschemeheapdirs = "";
if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
} else if (*Sschemeheapdirs != 0 && Sschemeheapdirs[strlen(Sschemeheapdirs)-1] == SEARCHPATHSEP) {
if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
} else {
Sdefaultheapdirs = "";
}
#ifdef PTHREADS
{
int status;
if ((status = s_thread_key_create(&S_tc_key)) != 0)
S_error_abort(strerror(status));
s_thread_setspecific(S_tc_key, S_G.thread_context);
}
#endif
#ifdef ITEST
S_boot_time = 1;
main_init();
bignum_test();
exit(0);
#endif
}
static void check_boot_file_state(const char *who) {
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (%s): uninitialized; call Sscheme_init first\n", who);
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case RUNNING:
fprintf(stderr, "error (%s): already running\n", who);
S_abnormal_exit();
case BOOTING:
break;
}
}
extern void Sregister_boot_file(const char *name) {
check_boot_file_state("Sregister_boot_file");
find_boot(name, "", -1, 1);
}
extern void Sregister_boot_file_fd(const char *name, int fd) {
check_boot_file_state("Sregister_boot_file_fd");
find_boot(name, "", fd, 1);
}
extern void Sregister_heap_file(UNUSED const char *path) {
fprintf(stderr, "Sregister_heap_file: saved heap files are not presently supported\n");
S_abnormal_exit();
}
extern void Sbuild_heap(const char *kernel, void (*custom_init)(void)) {
ptr tc = Svoid; /* initialize to make gcc happy */
ptr p;
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (Sbuild_heap): uninitialized; call Sscheme_init first\n");
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case RUNNING:
fprintf(stderr, "error (Sbuild_heap): already running\n");
S_abnormal_exit();
case BOOTING:
break;
}
current_state = RUNNING;
S_boot_time = 1;
if (boot_count == 0) {
const char *name;
if (!kernel) {
fprintf(stderr, "no boot file or executable name specified\n");
S_abnormal_exit();
}
name = path_last(kernel);
if (strlen(name) >= PATH_MAX) {
fprintf(stderr, "executable name too long: %s\n", name);
S_abnormal_exit();
}
#ifdef WIN32
{ /* strip off trailing .exe, if any */
static char buf[PATH_MAX];
iptr n;
n = strlen(name) - 4;
if (n >= 0 && (_stricmp(name + n, ".exe") == 0)) {
strcpy(buf, name);
buf[n] = 0;
name = buf;
}
}
#endif
if (!find_boot(name, ".boot", -1, 0)) {
fprintf(stderr, "cannot find compatible %s.boot in search path\n \"%s%s\"\n",
name,
Sschemeheapdirs, Sdefaultheapdirs);
S_abnormal_exit();
}
}
if (boot_count != 0) {
INT i = 0;
main_init();
if (custom_init) custom_init();
S_threads = Snil;
S_nthreads = 0;
S_set_symbol_value(S_G.active_threads_id, FIX(0));
/* pass a parent tc of Svoid, since this call establishes the initial
* thread context and hence there is no parent thread context. */
tc = (ptr)THREADTC(S_create_thread_object("startup", tc));
#ifdef PTHREADS
s_thread_setspecific(S_tc_key, tc);
#endif
/* #scheme-init enables interrupts */
TRAP(tc) = (ptr)most_positive_fixnum;
DISABLECOUNT(tc) = Sfixnum(1);
COMPRESSFORMAT(tc) = FIX(COMPRESS_LZ4);
COMPRESSLEVEL(tc) = FIX(COMPRESS_MEDIUM);
load(tc, i++, 1);
S_boot_time = 0;
while (i < boot_count) load(tc, i++, 0);
}
if (boot_count != 0) Scompact_heap();
/* complete the initialization on the Scheme side */
p = S_symbol_value(S_intern((const unsigned char *)"$scheme-init"));
if (!Sprocedurep(p)) {
(void) fprintf(stderr,"\n$scheme-init is not bound to a procedure\n");
S_abnormal_exit();
}
S_initframe(tc, 0);
(void)boot_call(tc, p, 0);
/* should be okay to invoke Scheme's error handler now */
S_errors_to_console = 0;
}
extern void Senable_expeditor(const char *history_file) {
Scall1(S_symbol_value(Sstring_to_symbol("$enable-expeditor")), Strue);
if (history_file != (const char *)0)
Scall1(S_symbol_value(Sstring_to_symbol("$expeditor-history-file")),
Sstring_utf8(history_file, -1));
}
extern INT Sscheme_start(INT argc, const char *argv[]) {
ptr tc = get_thread_context();
ptr arglist, p; INT i;
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (Sscheme_start): uninitialized; call Sscheme_init and Sbuild_heap first\n");
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (Sscheme_start): no heap built yet; call Sbuild_heap first\n");
S_abnormal_exit();
case RUNNING:
break;
}
arglist = Snil;
for (i = argc - 1; i > 0; i -= 1)
arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
p = S_symbol_value(S_intern((const unsigned char *)"$scheme"));
if (!Sprocedurep(p)) {
(void) fprintf(stderr,"\n$scheme is not bound to a procedure\n");
S_abnormal_exit();
}
S_initframe(tc, 1);
S_put_arg(tc, 1, arglist);
p = boot_call(tc, p, 1);
if (S_integer_valuep(p)) return (INT)Sinteger_value(p);
return p == Svoid ? 0 : 1;
}
static INT run_script(const char *who, const char *scriptfile, INT argc, const char *argv[], IBOOL programp) {
ptr tc = get_thread_context();
ptr arglist, p; INT i;
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (%s): uninitialized; call Sscheme_init and Sbuild_heap first\n", who);
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (%s): no heap built yet; call Sbuild_heap first\n", who);
S_abnormal_exit();
case RUNNING:
break;
}
arglist = Snil;
for (i = argc - 1; i > 0; i -= 1)
arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
p = S_symbol_value(S_intern((const unsigned char *)"$script"));
if (!Sprocedurep(p)) {
(void) fprintf(stderr,"\n$script is not bound to a procedure\n");
S_abnormal_exit();
}
S_initframe(tc, 3);
S_put_arg(tc, 1, Sboolean(programp));
S_put_arg(tc, 2, Sstring_utf8(scriptfile, -1));
S_put_arg(tc, 3, arglist);
p = boot_call(tc, p, 3);
if (S_integer_valuep(p)) return (INT)Sinteger_value(p);
return p == Svoid ? 0 : 1;
}
extern INT Sscheme_script(const char *scriptfile, INT argc, const char *argv[]) {
return run_script("Sscheme_script", scriptfile, argc, argv, 0);
}
extern INT Sscheme_program(const char *programfile, INT argc, const char *argv[]) {
return run_script("Sscheme_program", programfile, argc, argv, 1);
}
extern void Ssave_heap(UNUSED const char *path, UNUSED INT level) {
fprintf(stderr, "Ssave_heap: saved heap files are not presently supported\n");
S_abnormal_exit();
}
extern void Sscheme_deinit(void) {
ptr p, tc = get_thread_context();
switch (current_state) {
case UNINITIALIZED:
case DEINITIALIZED:
fprintf(stderr, "error (Sscheme_deinit): not yet initialized or running\n");
if (current_state == UNINITIALIZED) exit(1); else S_abnormal_exit();
case BOOTING:
fprintf(stderr, "error (Sscheme_deinit): not yet running\n");
S_abnormal_exit();
case RUNNING:
break;
}
p = S_symbol_value(S_intern((const unsigned char *)"$close-files"));
S_initframe(tc, 0);
boot_call(tc, p, 0);
S_errors_to_console = 1;
current_state = DEINITIALIZED;
}
Reference in New Issue View Git Blame Copy Permalink