static void maybe_write(struct thread *thread)
{
obj_t *fp = thread->fp;
int fd = fixnum_value(fp[-9]);
int nfound, res;
obj_t *old_sp;
nfound = output_writable(fd);
if (nfound < 0) {
if (errno != EINTR) {
old_sp = pop_linkage(thread);
thread->sp = old_sp + 2;
old_sp[0] = obj_False;
old_sp[1] = make_fixnum(errno);
do_return(thread, old_sp, old_sp);
} else {
wait_for_output(thread, fd, maybe_write);
}
} else if (nfound == 0)
wait_for_output(thread, fd, maybe_write);
else {
res = write(fd,
buffer_data(fp[-8]) + fixnum_value(fp[-7]),
fixnum_value(fp[-6]));
results(thread, pop_linkage(thread), res, make_fixnum(res));
}
}
static void maybe_read(struct thread *thread)
{
obj_t *fp = thread->fp;
int fd = fixnum_value(fp[-9]);
int nfound, res;
obj_t *old_sp;
nfound = input_available(fd);
if (nfound < 0) {
old_sp = pop_linkage(thread);
thread->sp = old_sp + 2;
old_sp[0] = obj_False;
old_sp[1] = make_fixnum(errno);
do_return(thread, old_sp, old_sp);
}
else if (nfound == 0)
wait_for_input(thread, fd, maybe_read);
else {
res = mindy_read(fd,
(char *)(buffer_data(fp[-8]) + fixnum_value(fp[-7])),
fixnum_value(fp[-6]));
results(thread, pop_linkage(thread), res, make_fixnum(res));
}
}
// ### make-primitive name code minargs maxargs => primitive
Value SYS_make_primitive(Value arg1, Value arg2, Value arg3, Value arg4)
{
// Symbol * sym = check_symbol(arg1);
SimpleArray_UB8_1 * vector = check_simple_array_ub8_1(arg2);
long minargs = fixnum_value(arg3);
long maxargs = fixnum_value(arg4);
return make_value(new Primitive(arg1, vector->data(), minargs, maxargs, false));
}
static void fd_seek(obj_t self, struct thread *thread, obj_t *args)
{
obj_t fd = args[0];
obj_t offset = args[1];
obj_t whence = args[2];
off_t res;
res = lseek(fixnum_value(fd), fixnum_value(offset), fixnum_value(whence));
results(thread, args-1, res, make_fixnum(res));
}
static void
print_context_cmd(char **ptr)
{
int free_ici;
struct thread *thread=arch_os_get_current_thread();
free_ici = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,thread));
if (more_p(ptr)) {
int index;
index = parse_number(ptr);
if ((index >= 0) && (index < free_ici)) {
printf("There are %d interrupt contexts.\n", free_ici);
printf("printing context %d\n", index);
print_context(thread->interrupt_contexts[index]);
} else {
printf("There aren't that many/few contexts.\n");
printf("There are %d interrupt contexts.\n", free_ici);
}
} else {
if (free_ici == 0)
printf("There are no interrupt contexts!\n");
else {
printf("There are %d interrupt contexts.\n", free_ici);
printf("printing context %d\n", free_ici - 1);
print_context(thread->interrupt_contexts[free_ici - 1]);
}
}
}
static long compute_offset(os_context_t *context, lispobj code)
{
if (code == NIL)
return 0;
else {
uword_t code_start;
struct code *codeptr = (struct code *)native_pointer(code);
#ifdef LISP_FEATURE_HPPA
uword_t pc = *os_context_pc_addr(context) & ~3;
#else
uword_t pc = *os_context_pc_addr(context);
#endif
code_start = (uword_t)codeptr
+ HeaderValue(codeptr->header)*sizeof(lispobj);
if (pc < code_start)
return 0;
else {
uword_t offset = pc - code_start;
if (offset >= (uword_t)fixnum_value(codeptr->code_size))
return 0;
else
return make_fixnum(offset);
}
}
}
static void fd_input_available(obj_t self, struct thread *thread, obj_t *args)
{
int fd = fixnum_value(args[0]);
int res = input_available(fd);
results(thread, args-1, res, res ? obj_True : obj_False);
}
static void op_minus(int byte, struct thread *thread)
{
obj_t *sp = thread->sp;
obj_t x = sp[-2];
obj_t y = sp[-1];
if (obj_is_fixnum(x) && obj_is_fixnum(y)) {
sp[-2] = make_fixnum(fixnum_value(x) - fixnum_value(y));
thread->sp = sp-1;
}
else {
thread->sp = sp+1;
sp[-2] = minus_var->value;
sp[-1] = x;
sp[0] = y;
invoke(thread, 2);
}
}
static void fd_open(obj_t self, struct thread *thread, obj_t *args)
{
obj_t path = args[0];
obj_t flags = args[1];
int res;
res = mindy_open(string_chars(path), fixnum_value(flags), 0666);
results(thread, args-1, res, make_fixnum(res));
}
static void fd_sync_output(obj_t self, struct thread *thread, obj_t *args)
{
HANDLE fHandle = _get_osfhandle(fixnum_value(args[0]));
int res = FlushFileBuffers(fHandle);
if (res == 0 && GetLastError() == ERROR_INVALID_HANDLE) // File descriptor is for console, ignore error
results(thread, args - 1, 0, obj_True);
else
results(thread, args - 1, res != 0, obj_True);
}
// ### code-char code => char-p
Value CL_code_char(Value code)
{
// "Returns a character with the code attribute given by CODE. If no such
// character exists and one cannot be created, NIL is returned."
long n = fixnum_value(code);
if (n >= 0 && n < 256)
return make_character(n);
else
return NIL;
}
static obj_t dylan_sovec_element_setter(obj_t value, obj_t sovec, obj_t index)
{
int i = fixnum_value(index);
if (0 <= i && i < SOVEC(sovec)->length)
SOVEC(sovec)->contents[i] = value;
else
error("No element %= in %=", index, sovec);
return value;
}
void SimpleArray_UB16_1::fill(Value value)
{
long n = fixnum_value(value);
if (n >= 0 && n < 65536)
{
for (INDEX i = 0; i < _capacity; i++)
_data[i] = n;
}
else
signal_type_error(value, UB16_TYPE);
}
struct compiled_debug_fun *
debug_function_from_pc (struct code* code, void *pc)
{
uword_t code_header_len = sizeof(lispobj) * HeaderValue(code->header);
uword_t offset
= (uword_t) pc - (uword_t) code - code_header_len;
struct compiled_debug_fun *df;
struct compiled_debug_info *di;
struct vector *v;
int i, len;
if (lowtag_of(code->debug_info) != INSTANCE_POINTER_LOWTAG)
return 0;
di = (struct compiled_debug_info *) native_pointer(code->debug_info);
v = (struct vector *) native_pointer(di->fun_map);
len = fixnum_value(v->length);
df = (struct compiled_debug_fun *) native_pointer(v->data[0]);
if (len == 1)
return df;
for (i = 1;; i += 2) {
unsigned next_pc;
if (i == len)
return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
if (offset >= (uword_t)fixnum_value(df->elsewhere_pc)) {
struct compiled_debug_fun *p
= ((struct compiled_debug_fun *) native_pointer(v->data[i + 1]));
next_pc = fixnum_value(p->elsewhere_pc);
} else
next_pc = fixnum_value(v->data[i]);
if (offset < next_pc)
return ((struct compiled_debug_fun *) native_pointer(v->data[i - 1]));
}
return NULL;
}
/*
* Parse the input stream and return an action stack.
* See Wikipedia again.
*/
static obj_t *parse(instream_t *in)
{
AUTO_ROOT(actions, NIL);
AUTO_ROOT(yylval, NIL);
AUTO_ROOT(tmp, make_fixnum(TOK_EOF));
AUTO_ROOT(stack, NIL);
stack_push(&stack, tmp);
tmp = make_fixnum(sym_index(start_symbol));
stack_push(&stack, tmp);
int tok = yylex(&yylval, in);
while (true) {
int sym = fixnum_value(stack_pop(&stack));
assert(0 <= sym && sym < symbols_size);
uint_fast8_t rule = get_rule(symbols[sym], tok);
if (rule != NO_RULE) {
const production_t *pp = &grammar[rule];
int j;
for (j = strlen(pp->p_rhs); --j >= 0; ) {
tmp = make_fixnum(sym_index(pp->p_rhs[j]));
stack_push(&stack, tmp);
}
if (pp->p_action)
stack_push(&actions, *pp->p_action);
} else {
if (sym == TOK_EOF)
break;
/* XXX raise an exception here. */
assert(sym == tok && "syntax error");
if (!is_null(yylval))
stack_push(&actions, yylval);
if (!stack_is_empty(actions) &&
fixnum_value(stack_top(stack)) == TOK_EOF)
break;
yylval = NIL;
tok = yylex(&yylval, in);
}
}
POP_FUNCTION_ROOTS();
return actions;
}
static obj_t dylan_sovec_element(obj_t sovec, obj_t index, obj_t def)
{
int i = fixnum_value(index);
if (0 <= i && i < SOVEC(sovec)->length)
return SOVEC(sovec)->contents[i];
else if (def != obj_Unbound)
return def;
else {
error("No element %= in %=", index, sovec);
return NULL;
}
}
static void fd_sync_output(obj_t self, struct thread *thread, obj_t *args)
{
int res = fsync(fixnum_value(args[0]));
// Various platforms may fail on this depending on what fd is.
// EINVAL means that fd is a socket and we don't care that you can't
// fsync sockets.
// ENOTSUP happens on Mac OS X, like when communicating with the Tk code.
if ((res < 0 && errno == EINVAL)
#ifdef __APPLE__
|| (res < 0 && errno == ENOTSUP)
#endif
)
results(thread, args - 1, 0, obj_True);
else
results(thread, args - 1, res, obj_True);
}
void *handle_fun_end_breakpoint(os_context_t *context)
{
lispobj code, lra;
struct code *codeptr;
DX_ALLOC_SAP(context_sap, context);
fake_foreign_function_call(context);
#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
#endif
code = find_code(context);
codeptr = (struct code *)native_pointer(code);
#ifndef LISP_FEATURE_WIN32
/* Don't disallow recursive breakpoint traps. Otherwise, we can't
* use debugger breakpoints anywhere in here. */
thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
#endif
funcall3(StaticSymbolFunction(HANDLE_BREAKPOINT),
compute_offset(context, code),
code,
context_sap);
lra = codeptr->constants[REAL_LRA_SLOT];
#ifdef LISP_FEATURE_PPC
/* PPC now passes LRA objects in reg_LRA during return. Other
* platforms should as well, but haven't been fixed yet. */
*os_context_register_addr(context, reg_LRA) = lra;
#else
#ifdef reg_CODE
*os_context_register_addr(context, reg_CODE) = lra;
#endif
#endif
undo_fake_foreign_function_call(context);
#ifdef reg_LRA
return (void *)(lra-OTHER_POINTER_LOWTAG+sizeof(lispobj));
#else
return compute_pc(lra, fixnum_value(codeptr->constants[REAL_LRA_SLOT+1]));
#endif
}
/* Build a vector from a list. XXX move this to obj_bytevec.c. */
static obj_t *build_bytevec(obj_t *list)
{
PUSH_ROOT(list);
obj_t *p = list;
size_t i, size = 0;
while (!is_null(p)) {
size++;
p = pair_cdr(p);
}
AUTO_ROOT(bvec, make_bytevector(size, 0));
for (i = 0, p = list; i < size; i++) {
bytevector_set(bvec, i, fixnum_value(pair_car(p)));
p = pair_cdr(p);
}
POP_FUNCTION_ROOTS();
return bvec;
}
static void fd_sync_output(obj_t self, struct thread *thread, obj_t *args)
{
int res = fsync(fixnum_value(args[0]));
if ((res < 0 && errno == EINVAL)
/* EINVAL means the fd is a socket, not a file descriptor. We don't */
/* care that you can't fsync sockets. */
#ifdef WIN32
|| (res < 0 && errno == EBADF)
/* In Windows, EBADF means that the fd is a descriptor for
the console. */
#endif
)
results(thread, args-1, 0, obj_True);
else
results(thread, args-1, res, obj_True);
}
void os_link_runtime()
{
#ifdef LISP_FEATURE_SB_DYNAMIC_CORE
char *link_target = (char*)(intptr_t)LINKAGE_TABLE_SPACE_START;
void *validated_end = link_target;
lispobj symbol_name;
char *namechars;
boolean datap;
void* result;
int j;
if (lisp_linkage_table_n_prelinked)
return; // Linkage was already performed by coreparse
struct vector* symbols = VECTOR(SymbolValue(REQUIRED_FOREIGN_SYMBOLS,0));
lisp_linkage_table_n_prelinked = fixnum_value(symbols->length);
for (j = 0 ; j < lisp_linkage_table_n_prelinked ; ++j)
{
lispobj item = symbols->data[j];
datap = listp(item);
symbol_name = datap ? CONS(item)->car : item;
namechars = (void*)(intptr_t)(VECTOR(symbol_name)->data);
result = os_dlsym_default(namechars);
if (link_target == validated_end) {
validated_end = (char*)validated_end + os_vm_page_size;
#ifdef LISP_FEATURE_WIN32
os_validate_recommit(link_target,os_vm_page_size);
#endif
}
if (result) {
arch_write_linkage_table_entry(link_target, result, datap);
} else { // startup might or might not work. ymmv
printf("Missing required foreign symbol '%s'\n", namechars);
}
link_target += LINKAGE_TABLE_ENTRY_SIZE;
}
#endif /* LISP_FEATURE_SB_DYNAMIC_CORE */
#ifdef LISP_FEATURE_X86_64
SetSymbolValue(CPUID_FN1_ECX, (lispobj)make_fixnum(cpuid_fn1_ecx), 0);
#endif
}
AbstractString * Bignum::write_to_string()
{
Thread * const thread = current_thread();
const long base = fixnum_value(current_thread()->symbol_value(S_print_base));
char * buf = (char *) GC_malloc_atomic(mpz_sizeinbase(_z, base) + 2);
if (!buf)
out_of_memory();
mpz_get_str(buf, base, _z);
SimpleString * s = new_simple_string(buf);
if (base > 10)
s->nupcase();
if (thread->symbol_value(S_print_radix) == NIL)
return s;
String * s2 = new String();
switch (base)
{
case 2:
s2->append("#b");
s2->append(s);
break;
case 8:
s2->append("#o");
s2->append(s);
break;
case 10:
s2->append(s);
s2->append_char('.');
break;
case 16:
s2->append("#x");
s2->append(s);
break;
default:
s2->append_char('#');
s2->append_long(base);
s2->append_char('r');
s2->append(s);
break;
}
return s2;
}
return value;
}
static obj_t dylan_sovec_size(obj_t sovec)
{
return make_fixnum(SOVEC(sovec)->length);
}
static obj_t dylan_vec_make(obj_t class, obj_t size, obj_t fill)
{
obj_t res;
int len;
obj_t *ptr;
len = fixnum_value(check_type(size, obj_FixnumClass));
if (len < 0)
error("Bogus size: for make %=: %=", class, size);
res = make_vector(len, NULL);
ptr = SOVEC(res)->contents;
while (len-- > 0)
*ptr++ = fill;
return res;
}
static obj_t dylan_sovec_fill(obj_t /* <simple-object-vector> */ vector,
obj_t value, obj_t first, obj_t last)
#include "vec.h"
#include "str.h"
#include "buf.h"
#ifndef max
# define max(a,b) ((a)>(b) ? (a) : (b))
#endif
obj_t obj_BufferClass = NULL;
static obj_t dylan_buffer_make(obj_t class, obj_t size, obj_t next, obj_t end)
{
int len, start, stop;
obj_t res;
len = fixnum_value(check_type(size, obj_FixnumClass));
start = fixnum_value(next);
stop = fixnum_value(end);
if (len < 0)
error("Bogus size: for make %=: %d", class, size);
if (start < 0 || start > len)
error("Bogus buffer-next: for make %=: %d", class, next);
if (stop < 0 || stop > len)
error("Bogus buffer-end: for make %=: %d", class, end);
res = alloc(obj_BufferClass, sizeof(struct buffer)
+ max(len - sizeof(((struct buffer *)res)->data),
sizeof(((struct buffer *)res)->data)));
BUF(res)->length = len;
static void fd_close(obj_t self, struct thread *thread, obj_t *args)
{
obj_t fd = args[0];
results(thread, args-1, mindy_close(fixnum_value(fd)), obj_True);
}
void lisp_print(object exp, FILE *out)
{
unsigned long i, len;
char c;
char *str;
object *vptr;
switch (type_of(exp)) {
case T_NIL:
fprintf(out, "()");
break;
case T_FIXNUM:
fprintf(out, "%ld", fixnum_value(exp));
break;
case T_CHARACTER:
c = character_value(exp);
fprintf(out, "#\\");
switch (c) {
case '\n':
fprintf(out, "newline");
break;
case ' ':
fprintf(out, "space");
break;
default:
fprintf(out, "%c", c);
}
break;
case T_PAIR:
if (is_finite_list(exp, NULL)) {
fprintf(out, "(");
write_pair(exp, out);
fprintf(out, ")");
} else {
fprintf(out, "#<unprintable-structure>");
}
break;
case T_BOOLEAN:
fprintf(out, is_false(exp) ? "#f" : "#t");
break;
case T_STRING:
fprintf(out, "\"");
str = string_value(exp);
len = string_length(exp);
for (i = 0; i < len; i++) {
switch (str[i]) {
case '\n':
fprintf(out, "\\n");
break;
case '"':
fprintf(out, "\\\"");
break;
case '\\':
fprintf(out, "\\\\");
break;
default:
fprintf(out, "%c", str[i]);
}
}
fprintf(out, "\"");
break;
case T_VECTOR:
fprintf(out, "#(");
len = vector_length(exp);
vptr = vector_ptr(exp);
for (i = 0; i < len; i++) {
if (i)
fputc(' ', out);
lisp_print(*vptr++, out);
}
fprintf(out, ")");
break;
case T_SYMBOL:
fprintf(out, "%.*s", (int) string_length(symbol_string(exp)),
string_value(symbol_string(exp)));
break;
case T_FOREIGN_PTR:
fprintf(out, "#<foreign-pointer %p>", foreign_ptr_value(exp));
break;
case T_PRIMITIVE:
fprintf(out, "#<primitive-procedure %p>", primitive_implementation(exp));
break;
case T_PROCEDURE:
fprintf(out, "#<procedure ");
lisp_print(procedure_parameters(exp), out);
fprintf(out, ">");
break;
case T_EOF:
fprintf(out, "#<eof>");
break;
case T_PORT:
fprintf(out, "#<%s-port %p>",
is_input_port(exp) ? "input" : "output",
port_implementation(exp));
break;
case T_UNSPECIFIED:
/* actually, I could read this back... */
fprintf(out, "#<unspecified>");
break;
case T_MACRO:
fprintf(out, "#<macro ");
lisp_print(macro_parameters(exp), out);
fprintf(out, ">");
break;
case T_MAX_TYPE:
break;
}
}
static obj_t fd_error_str(obj_t xerrno)
{
return make_byte_string(strerror(fixnum_value(xerrno)));
}
