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));
}
}
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));
}
}
// ### digit-char-p char &optional radix => weight
Value CL_digit_char_p(unsigned int numargs, Value args[])
{
if (numargs < 1 || numargs > 2)
return wrong_number_of_arguments(S_digit_char_p, numargs, 1, 2);
BASE_CHAR c = char_value(args[0]);
int radix;
if (numargs == 2)
radix = check_index(args[1], 2, 36);
else
radix = 10;
if (c >= '0')
{
int n = c - '0';
if (radix <= 10)
return (n < radix) ? make_fixnum(n) : NIL;
if (n < 10)
return make_fixnum(n);
if (c >= 'A')
{
// A-Z
n -= 7;
if (n >= 10 && n < radix)
return make_fixnum(n);
if (c >= 'a')
{
// a-z
n -= 32;
if (n >= 10 && n < radix)
return make_fixnum(n);
}
}
}
return NIL;
}
bool Array_T::typep(Value type) const
{
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
tail = xcdr(tail);
if (element_type == UNSPECIFIED || ::equal(element_type, _element_type)
|| (_element_type == S_bit && ::equal(element_type, BIT_TYPE)))
{
if (tail == NIL)
return true;
if (::length(tail) == 1)
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == make_fixnum(_rank))
return true;
if (consp(dimensions))
{
if (::length(dimensions) == _rank)
{
unsigned long i = 0;
while (dimensions != NIL)
{
Value dim = xcar(dimensions);
if (dim == UNSPECIFIED || dim == make_fixnum(_dimensions[i]))
; // ok
else
return false;
dimensions = xcdr(dimensions);
++i;
}
return true;
}
}
}
}
}
}
}
else if (symbolp(type))
{
if (type == S_array || type == S_atom || type == T)
return true;
}
else
{
if (type == C_array || type == C_t)
return true;
}
return false;
}
bool SimpleArray_UB16_1::typep(Value type) const
{
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
if (element_type == UNSPECIFIED)
; // ok
else
{
Value upgraded_element_type = upgraded_array_element_type(element_type);
if (::equal(upgraded_element_type, UB16_TYPE))
; // ok
else if (::equal(upgraded_element_type,
list3(S_integer, FIXNUM_ZERO, make_fixnum(65535))))
; // ok
else if (::equal(upgraded_element_type,
list3(S_integer, FIXNUM_ZERO, list1(make_fixnum(65536)))))
; // ok
else
return false;
}
tail = xcdr(tail);
if (tail == NIL)
return true;
if (cdr(tail) == NIL) // i.e. length(tail) == 1
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == FIXNUM_ONE)
return true;
if (::equal(dimensions, list1(UNSPECIFIED)))
return true;
if (::equal(dimensions, list1(make_fixnum(_capacity))))
return true;
}
}
}
}
else if (symbolp(type))
{
if (type == S_vector || type == S_sequence || type == S_simple_array
|| type == S_array || type == S_atom || type == T)
return true;
}
else
{
if (type == C_vector || type == C_array || type == C_sequence || type == C_t)
return true;
}
return false;
}
/*
* DEV can be either a printer or devmode
*/
static Lisp_Object
print_dialog_worker (Lisp_Object dev, DWORD flags)
{
Lisp_Devmode *ldm = decode_devmode (dev);
PRINTDLGW pd;
memset (&pd, 0, sizeof (pd));
pd.lStructSize = sizeof (pd);
pd.hwndOwner = mswindows_get_selected_frame_hwnd ();
pd.hDevMode = devmode_to_hglobal (ldm);
pd.Flags = flags | PD_USEDEVMODECOPIESANDCOLLATE;
pd.nMinPage = 0;
pd.nMaxPage = 0xFFFF;
if (!qxePrintDlg (&pd))
{
global_free_2_maybe (pd.hDevNames, pd.hDevMode);
return Qnil;
}
handle_devmode_changes (ldm, pd.hDevNames, pd.hDevMode);
/* Finally, build the resulting plist */
{
Lisp_Object result = Qnil;
struct gcpro gcpro1;
GCPRO1 (result);
/* Do consing in reverse order.
Number of copies */
result = Fcons (Qcopies, Fcons (make_fixnum (pd.nCopies), result));
/* Page range */
if (pd.Flags & PD_PAGENUMS)
{
result = Fcons (Qto_page, Fcons (make_fixnum (pd.nToPage), result));
result = Fcons (Qfrom_page, Fcons (make_fixnum (pd.nFromPage), result));
result = Fcons (Qselected_page_button, Fcons (Qpages, result));
}
else if (pd.Flags & PD_SELECTION)
result = Fcons (Qselected_page_button, Fcons (Qselection, result));
else
result = Fcons (Qselected_page_button, Fcons (Qall, result));
/* Device name */
result = Fcons (Qname, Fcons (ldm->printer_name, result));
UNGCPRO;
global_free_2_maybe (pd.hDevNames, pd.hDevMode);
return result;
}
}
void
handle_single_step_trap (os_context_t *context, int kind, int register_offset)
{
fake_foreign_function_call(context);
#ifndef LISP_FEATURE_WIN32
thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
#endif
funcall2(StaticSymbolFunction(HANDLE_SINGLE_STEP_TRAP),
make_fixnum(kind),
make_fixnum(register_offset));
undo_fake_foreign_function_call(context); /* blocks signals again */
}
Value Array_T::dimensions() const
{
Value result = NIL;
for (unsigned long i = _rank; i-- > 0;)
result = make_cons(make_fixnum(_dimensions[i]), result);
return result;
}
// ### %read-from-string string eof-error-p eof-value start end preserve-whitespace
// => object, position
Value SYS_read_from_string_internal(Value arg1, Value arg2, Value arg3,
Value arg4, Value arg5, Value arg6)
{
AbstractString * string = check_string(arg1);
bool eof_error_p = (arg2 != NIL);
bool preserve_whitespace = (arg6 != NIL);
INDEX start;
if (arg4 != NIL)
start = check_index(arg4);
else
start = 0;
INDEX end;
if (arg5 != NIL)
end = check_index(arg5);
else
end = string->length();
StringInputStream * in = new StringInputStream(string, start, end);
Thread * const thread = current_thread();
Value result;
Readtable * rt = check_readtable(thread->symbol_value(S_current_readtable));
if (preserve_whitespace)
result = stream_read_preserving_whitespace(make_value(in), eof_error_p, arg3, false, thread, rt);
else
result = stream_read(make_value(in), eof_error_p, arg3, false, thread, rt);
return thread->set_values(result, make_fixnum(in->offset()));
}
static Lisp_Object
msprinter_device_system_metrics (struct device *d,
enum device_metrics m)
{
switch (m)
{
/* Device sizes - pixel and mm */
#define FROB(met, index1, index2) \
case DM_##met: \
return build_devicecaps_cons \
(DEVICE_MSPRINTER_HDC (d), index1, index2);
FROB (size_device, PHYSICALWIDTH, PHYSICALHEIGHT);
FROB (size_device_mm, HORZSIZE, VERTSIZE);
FROB (size_workspace, HORZRES, VERTRES);
FROB (offset_workspace, PHYSICALOFFSETX, PHYSICALOFFSETY);
FROB (device_dpi, LOGPIXELSX, LOGPIXELSY);
#undef FROB
case DM_num_bit_planes:
/* this is what X means by bitplanes therefore we ought to be
consistent. num planes is always 1 under mswindows and
therefore useless */
return make_fixnum (GetDeviceCaps (DEVICE_MSPRINTER_HDC (d), BITSPIXEL));
case DM_num_color_cells: /* Printers are non-palette devices */
case DM_slow_device: /* Animation would be a really bad idea */
case DM_security: /* Not provided by windows */
return Qzero;
}
/* Do not know such property */
return Qunbound;
}
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);
}
}
}
obj_t vector_ref(obj_t obj, size_t index)
{
CHECK_OBJ(obj);
CHECK(is_vector(obj), "must be vector", obj);
vector_obj_t *vec = (vector_obj_t *)obj;
CHECK(index < vec->v_size, "index out of range", obj, make_fixnum(index));
return *elem_addr(vec, index);
}
static obj_t file_write_date(obj_t path)
{
struct stat buf;
if (stat(string_chars(path), &buf) < 0)
return obj_False;
else
return make_fixnum(buf.st_mtime);
}
object
make_integer(__mpz_struct *u)
{
if ((u)->_mp_size == 0) return small_fixnum(0);
if (mpz_fits_slong_p(u)) {
return make_fixnum(mpz_get_si(u));
}
return make_bignum(u);
}
Fixnum fixnum_gcd(Fixnum _n, Fixnum _m)
{
int n, m;
n = theFIXNUM(_n);
m = theFIXNUM(_m);
return make_fixnum(gcd(n, m));
}
object *mul_proc(object *arguments) {
long result = 1;
while (!is_the_empty_list(arguments)) {
result *= (car(arguments))->data.fixnum.value;
arguments = cdr(arguments);
}
return make_fixnum(result);
}
object *sub_proc(object *arguments) {
long result;
result = (car(arguments))->data.fixnum.value;
while (!is_the_empty_list(arguments = cdr(arguments))) {
result -= (car(arguments))->data.fixnum.value;
}
return make_fixnum(result);
}
inline SimpleArray_UB32_1 * check_simple_array_ub32_1(Value value)
{
if (simple_array_ub32_1_p(value))
return the_simple_array_ub32_1(value);
Value expected_type = list3(S_simple_array, S_unsigned_byte, list1(make_fixnum(32)));
signal_type_error(value, expected_type);
// Not reached.
return NULL;
}
obj_t make_C_procedure(C_procedure_t code,
obj_t name,
interval_t arg_range,
obj_t env)
{
CHECK_OBJ(env);
proc_flags_t flags = PF_COMPILED_C | PF_ARGS_EVALUATED;
return make_proc(flags, (obj_t)code, name, make_fixnum(arg_range), env);
}
bool SimpleString::typep(Value type) const
{
if (classp(type))
return (type == C_string || type == C_vector || type == C_array
|| type == C_sequence || type == C_t);
if (symbolp(type))
return (type == S_string || type == S_base_string || type == S_simple_string
|| type == S_simple_base_string || type == S_vector
|| type == S_simple_array || type == S_array || type == S_sequence
|| type == S_atom || type == T);
if (consp(type))
{
Value type_specifier_atom = xcar(type);
Value tail = xcdr(type);
if (type_specifier_atom == S_array || type_specifier_atom == S_simple_array)
{
if (consp(tail))
{
Value element_type = xcar(tail);
tail = xcdr(tail);
if (element_type == UNSPECIFIED || element_type == S_character
|| element_type == S_base_char)
{
if (tail == NIL)
return true;
if (cdr(tail) == NIL) // i.e. length(tail) == 1
{
Value dimensions = xcar(tail);
if (dimensions == UNSPECIFIED)
return true;
if (dimensions == FIXNUM_ONE)
return true;
if (consp(dimensions))
{
if (::length(dimensions) == 1)
{
Value dim = xcar(dimensions);
if (dim == UNSPECIFIED || dim == make_fixnum(_capacity))
return true;
}
}
}
}
}
}
else if (type_specifier_atom == S_string
|| type_specifier_atom == S_base_string
|| type_specifier_atom == S_simple_string
|| type_specifier_atom == S_simple_base_string)
{
Value size = car(tail);
return (size == UNSPECIFIED || check_index(size) == _capacity);
}
}
return false;
}
void vector_set(obj_t obj, size_t index, obj_t elem)
{
CHECK_OBJ(obj);
CHECK(is_vector(obj), "must be vector", obj);
vector_obj_t *vec = (vector_obj_t *)obj;
//XXX CHECK(is_mutable(obj), "must be mutable", pair);
CHECK(index < vec->v_size, "index out of range", obj, make_fixnum(index));
MUTATE(obj);
*elem_addr(vec, index) = elem;
}
inline object
log_op2(fixnum op,object x,object y) {
enum type tx=type_of(x),ty=type_of(y);
if (tx==t_fixnum && ty==t_fixnum)
return make_fixnum(fixnum_log_op2(op,fix(x),fix(y)));
else
return maybe_replace_big(integer_log_op2(op,x,tx,y,ty));
}
static void fd_exec(obj_t self, struct thread *thread, obj_t *args)
{
obj_t *oldargs;
oldargs = args - 1;
thread->sp = args + 1;
{
PROCESS_INFORMATION piProcInfo;
STARTUPINFO siStartInfo;
SECURITY_ATTRIBUTES saAttr;
int inpipes[2], outpipes[2];
HANDLE old_handles[2];
const char *command_line = string_chars(args[0]);
siStartInfo.cb = sizeof(STARTUPINFO);
siStartInfo.lpReserved = NULL;
siStartInfo.lpReserved2 = NULL;
siStartInfo.cbReserved2 = 0;
siStartInfo.lpDesktop = NULL;
/* pipe_setup initializes the rest of siStartInfo */
saAttr.nLength = sizeof(SECURITY_ATTRIBUTES);
saAttr.bInheritHandle = true;
saAttr.lpSecurityDescriptor = NULL;
pipe_setup(&siStartInfo, inpipes, outpipes, old_handles);
if (! CreateProcess(NULL, command_line, NULL, NULL, true, 0,
NULL, NULL, &siStartInfo, &piProcInfo)) {
DWORD debug_info = GetLastError();
oldargs[0] = obj_False;
oldargs[1] = obj_False;
} else {
oldargs[0] = make_fixnum(inpipes[1]); /* fd we can write to */
oldargs[1] = make_fixnum(outpipes[0]); /* fd we can read from */
setup_input_checker(outpipes[0]);
}
pipe_cleanup(inpipes, outpipes, old_handles);
}
do_return(thread, oldargs, oldargs);
}
static int
plist_get_margin (Lisp_Object plist, Lisp_Object prop, int mm_p)
{
Lisp_Object val =
Fplist_get (plist, prop, make_fixnum (mswindows_get_default_margin (prop)));
if (!FIXNUMP (val))
invalid_argument ("Margin value must be an integer", val);
return MulDiv (XFIXNUM (val), mm_p ? 254 : 100, 144);
}
/* Add a (POS . LINE) pair to the ring, and rotate it. */
static void
add_position_to_cache (struct buffer *b, Charbpos pos, EMACS_INT line)
{
Lisp_Object *ring = XVECTOR_DATA (LINE_NUMBER_RING (b));
int i = LINE_NUMBER_RING_SIZE - 1;
/* Set the last marker in the ring to point nowhere. */
if (CONSP (ring[i]))
Fset_marker (XCAR (ring[i]), Qnil, Qnil);
/* Rotate the ring... */
for (; i > 0; i--)
ring[i] = ring[i - 1];
/* ...and update it. */
ring[0] = Fcons (Fset_marker (Fmake_marker (), make_fixnum (pos),
wrap_buffer (b)),
make_fixnum (line));
}
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));
}
Value Function::parts()
{
String * description = new String(prin1_to_string());
description->append_char('\n');
Value elements = NIL;
Value name = operator_name();
elements = make_cons(make_cons(make_simple_string("NAME"),
name != NULL_VALUE ? name : NIL),
elements);
elements = make_cons(make_cons(make_simple_string("ARITY"),
make_fixnum(arity())),
elements);
elements = make_cons(make_cons(make_simple_string("MINARGS"),
make_fixnum(minargs())),
elements);
elements = make_cons(make_cons(make_simple_string("MAXARGS"),
make_fixnum(maxargs())),
elements);
return current_thread()->set_values(make_value(description), T, CL_nreverse(elements));
}
lispobj
alloc_string(const char *str)
{
int len = strlen(str);
lispobj result = alloc_vector(type_SimpleString, len + 1, 8);
struct vector *vec = (struct vector *) PTR(result);
vec->length = make_fixnum(len);
strcpy((char *) vec->data, str);
return result;
}
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));
}
Integer parse_integer(char *token)
{
Integer n;
if (is_fixnum_token(token))
n = make_fixnum(atoi(token));
else
n = parse_bignum(token);
free(token);
return n;
}
