// ### %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()));
}
// ### logical-namestring-p object => generalized-boolean
Value SYS_logical_namestring_p(Value arg)
{
if (!(stringp(arg)))
return NIL;
AbstractString * host = get_host_string(the_string(arg));
if (host == NULL || host->length() == 0)
return NIL;
if (LOGICAL_PATHNAME_TRANSLATION_TABLE->get(make_value(host)) != NULL_VALUE)
return T;
return NIL;
}
// ### canonicalize-logical-host host => canonical-host
Value SYS_canonicalize_logical_host(Value arg)
{
AbstractString * s = check_string(arg);
if (s->length() == 0)
{
// "The null string, "", is not a valid value for any component of a
// logical pathname." 19.3.2.2
return signal_lisp_error("Invalid logical host name: \"\"");
}
return make_value(canonicalize_string_component(s));
}
bool SimpleString::equal(Value value) const
{
if (!stringp(value))
return false;
AbstractString * s = the_string(value);
if (this == s)
return true;
if (_capacity != s->length())
return false;
// REVIEW optimize
for (INDEX i = 0; i < _capacity; i++)
{
if (_chars[i] != s->fast_char_at(i))
return false;
}
return true;
}
// ### character
Value CL_character(Value arg)
{
if (characterp(arg))
return arg;
else if (stringp(arg))
{
AbstractString * s = the_string(arg);
if (s->length() == 1)
return make_character(s->fast_char_at(0));
}
else if (symbolp(arg))
{
SimpleString * s = the_symbol(arg)->name();
if (s && s->length() == 1)
return make_character(s->fast_char_at(0));
}
return signal_type_error(arg, S_character_designator);
}
// ### make-logical-pathname namestring => logical-pathname
Value SYS_make_logical_pathname(Value arg)
{
AbstractString * s = check_string(arg);
AbstractString * h = get_host_string(s);
if (h != NULL)
{
if (h->length() == 0)
{
// "The null string, "", is not a valid value for any component of a
// logical pathname." 19.3.2.2
return signal_lisp_error("Invalid logical host name: \"\"");
}
if (LOGICAL_PATHNAME_TRANSLATION_TABLE->get(make_value(h)) != NULL_VALUE)
return make_value(new LogicalPathname(h, s->substring(s->index_of(':') + 1)));
}
return signal_lisp_error(new TypeError("Logical namestring does not specify a valid host",
arg, list2(S_satisfies, S_logical_namestring_p)));
}
// ### make-string-input-stream string &optional start end => string-stream
Value CL_make_string_input_stream(unsigned int numargs, Value args[])
{
if (numargs < 1 || numargs > 3)
return wrong_number_of_arguments(S_make_string_input_stream, numargs, 1, 3);
AbstractString * string = check_string(args[0]);
unsigned long start;
if (numargs >= 2)
start = check_index(args[1]);
else
start = 0;
unsigned long end;
if (numargs == 3 && args[2] != NIL)
end = check_index(args[2]);
else
end = string->length();
return make_value(new StringInputStream(string, start, end));
}
// Move data from result set message to user variables.
void PreparedStatement::Builder::moveFromResultSet(thread_db* tdbb, ResultSet* rs) const
{
for (Array<OutputSlot>::const_iterator i = outputSlots.begin(); i != outputSlots.end(); ++i)
{
switch (i->type)
{
case TYPE_SSHORT:
*(SSHORT*) i->address = rs->getSmallInt(tdbb, i->number);
break;
case TYPE_SLONG:
*(SLONG*) i->address = rs->getInt(tdbb, i->number);
break;
case TYPE_SINT64:
*(SINT64*) i->address = rs->getBigInt(tdbb, i->number);
break;
case TYPE_DOUBLE:
*(double*) i->address = rs->getDouble(tdbb, i->number);
break;
case TYPE_STRING:
{
AbstractString* str = (AbstractString*) i->address;
str->replace(0, str->length(), rs->getString(tdbb, i->number));
break;
}
case TYPE_METANAME:
*(MetaName*) i->address = rs->getMetaName(tdbb, i->number);
break;
default:
fb_assert(false);
}
if (i->specifiedAddress && rs->isNull(i->number))
*i->specifiedAddress = false;
}
}
LogicalPathname::LogicalPathname(AbstractString * host, AbstractString * rest)
: Pathname(WIDETAG_LOGICAL_PATHNAME)
{
// final int limit = rest.length();
// for (int i = 0; i < limit; i++) {
// char c = rest.charAt(i);
// if (LOGICAL_PATHNAME_CHARS.indexOf(c) < 0) {
// error(new ParseError("The character #\\" + c + " is not valid in a logical pathname."));
// return;
// }
// }
// this.host = new SimpleString(host);
_host = make_value(host);
// "The device component of a logical pathname is always :UNSPECIFIC; no
// other component of a logical pathname can be :UNSPECIFIC."
_device = K_unspecific;
long semi = rest->last_index_of(';');
if (semi >= 0)
{
// directory
AbstractString * d = rest->substring(0, semi);
_directory = parse_logical_pathname_directory(d);
rest = rest->substring(semi + 1);
}
else
{
// "If a relative-directory-marker precedes the directories, the
// directory component is parsed as relative; otherwise, the directory
// component is parsed as absolute."
_directory = make_cons(K_absolute);
}
long dot = rest->index_of('.');
if (dot >= 0)
{
AbstractString * n = rest->substring(0, dot);
if (n->equal("*"))
_name = K_wild;
else
_name = make_value(n->upcase());
rest = rest->substring(dot + 1);
dot = rest->index_of('.');
if (dot >= 0)
{
AbstractString * t = rest->substring(0, dot);
if (t->equal("*"))
_type = K_wild;
else
// _type = new SimpleString(t.toUpperCase());
_type = make_value(t->upcase());
// What's left is the version.
AbstractString * v = rest->substring(dot + 1);
if (v->equal("*"))
_version = K_wild;
else if (v->equal("NEWEST") || v->equal("newest"))
_version = K_newest;
else
// _version = PACKAGE_CL.intern("PARSE-INTEGER").execute(new SimpleString(v));
printf("FIXME!! LogicalPathname constructor\n");
}
else
{
AbstractString * t = rest;
if (t->equal("*"))
_type = K_wild;
else
// type = new SimpleString(t.toUpperCase());
_type = make_value(t->upcase());
}
}
else
{
AbstractString * n = rest;
if (n->equal("*"))
_name = K_wild;
else if (n->length() > 0)
// name = new SimpleString(n.toUpperCase());
_name = make_value(n->upcase());
}
}
String * format_to_string(Value format_control, Value format_arguments)
{
Thread * const thread = current_thread();
AbstractString * const control = check_string(format_control);
assert(listp(format_arguments));
unsigned long numargs = length(format_arguments);
Value * args = new (GC) Value[numargs];
for (unsigned long i = 0; i < numargs; i++)
{
args[i] = car(format_arguments);
format_arguments = xcdr(format_arguments);
}
String * result = new String();
unsigned long limit = control->length();
unsigned long j = 0;
const unsigned long NEUTRAL = 0;
const unsigned long TILDE = 1;
unsigned long state = NEUTRAL;
unsigned long mincol = 0;
char padchar = ' ';
for (unsigned long i = 0; i < limit; i++)
{
char c = control->fast_char_at(i);
if (state == NEUTRAL)
{
if (c == '~')
state = TILDE;
else
result->append_char(c);
}
else if (state == TILDE)
{
if (c >= '0' && c <= '9')
{
String * token = new String();
token->append_char(c);
++i;
while (i < limit && (c = control->char_at(i)) >= '0' && c <= '9')
{
token->append_char(c);
++i;
}
// "Prefix parameters are notated as signed (sign is optional)
// decimal numbers..."
Value number = make_number(token, 10, NULL);
mincol = check_index(number);
if (c == ',')
{
++i;
if (i >= limit)
signal_lisp_error("invalid format directive");
c = control->char_at(i);
if (c == '\'')
{
++i;
if (i >= limit)
signal_lisp_error("invalid format directive");
padchar = control->char_at(i);
++i;
if (i >= limit)
signal_lisp_error("invalid format directive");
c = control->char_at(i);
}
}
// Fall through...
}
if (c == 'A' || c == 'a')
{
if (j < numargs)
{
Value obj = args[j++];
void * last_special_binding = thread->last_special_binding();
thread->bind_special(S_print_escape, NIL);
thread->bind_special(S_print_readably, NIL);
result->append(write_to_string(obj));
thread->set_last_special_binding(last_special_binding);
}
}
else if (c == 'S' || c == 's')
{
if (j < numargs)
{
Value obj = args[j++];
void * last_special_binding = thread->last_special_binding();
thread->bind_special(S_print_escape, T);
result->append(write_to_string(obj));
thread->set_last_special_binding(last_special_binding);
}
}
else if (c == 'C' || c == 'c')
{
if (j < numargs)
{
Value obj = args[j++];
void * last_special_binding = thread->last_special_binding();
result->append(princ_to_string(obj));
thread->set_last_special_binding(last_special_binding);
}
}
else if (c == 'D' || c == 'd')
{
if (j < numargs)
{
Value obj = args[j++];
void * last_special_binding = thread->last_special_binding();
thread->bind_special(S_print_base, make_integer(10));
AbstractString * s = write_to_string(obj);
if (s->length() < mincol)
{
unsigned long limit = mincol - s->length();
for (unsigned long k = 0; k < limit; k++)
result->append_char(padchar);
}
result->append(s);
thread->set_last_special_binding(last_special_binding);
}
}
else if (c == 'X' || c == 'x')
{
if (j < numargs)
{
Value obj = args[j++];
void * last_special_binding = thread->last_special_binding();
thread->bind_special(S_print_base, make_integer(16));
AbstractString * s = princ_to_string(obj);
if (s->length() < mincol)
{
unsigned long limit = mincol - s->length();
for (unsigned long k = 0; k < limit; k++)
result->append_char(padchar);
}
result->append(s);
thread->set_last_special_binding(last_special_binding);
}
}
else if (c == 'B' || c == 'b')
{
if (j < numargs)
{
Value obj = args[j++];
void * last_special_binding = thread->last_special_binding();
thread->bind_special(S_print_base, FIXNUM_TWO);
result->append(princ_to_string(obj));
thread->set_last_special_binding(last_special_binding);
}
}
else if (c == '%')
{
result->append_char('\n');
}
state = NEUTRAL;
}
else
{
// There are no other valid states.
assert(false);
}
}
return result;
}