/*
* returns possible next characters
* (rk-lib-expect-seq '("k" "y") ja-rk-rule) -> ("o" "e" "u" "i" "a")
*/
static uim_lisp
rk_expect_seq(uim_lisp seq, uim_lisp rules)
{
uim_lisp cur, res = uim_scm_null();
for (cur = rules; !uim_scm_nullp(cur); cur = uim_scm_cdr(cur)) {
uim_lisp rule = uim_scm_car(cur);
uim_lisp key = CAR(CAR(rule));
uim_lisp e = str_seq_partial(seq, key);
if (TRUEP(e)) {
res = uim_scm_cons(e, res);
}
}
return res; /* don't return uim_scm_f() */
}
static uim_lisp
rk_find_partial_seqs(uim_lisp seq, uim_lisp rules)
{
uim_lisp ret = uim_scm_null();
for (; !uim_scm_nullp(rules); rules = uim_scm_cdr(rules)) {
uim_lisp rule = uim_scm_car(rules);
uim_lisp key = uim_scm_car(uim_scm_car(rule));
if (TRUEP(str_seq_partial(seq, key))) {
ret = uim_scm_cons(rule, ret);
}
}
return uim_scm_callf("reverse", "o", ret);
}
lref_t lport_set_translate_mode(lref_t port, lref_t mode)
{
if (!TEXT_PORTP(port))
vmerror_wrong_type_n(1, port);
if (!BOOLP(mode))
vmerror_wrong_type_n(2, mode);
lflush_port(port);
bool old_translate_mode = PORT_TEXT_INFO(port)->translate;
PORT_TEXT_INFO(port)->translate = TRUEP(mode);
return boolcons(old_translate_mode);
}
lref_t lrich_write(lref_t obj, lref_t machine_readable, lref_t port)
{
if (NULLP(port))
port = CURRENT_OUTPUT_PORT();
if (!PORTP(port))
vmerror_wrong_type_n(3, port);
if (PORT_INPUTP(port))
vmerror_unsupported(_T("cannot rich-write to input ports"));
if (PORT_CLASS(port)->rich_write == NULL)
return boolcons(false);
if (PORT_CLASS(port)->rich_write(port, obj, TRUEP(machine_readable)))
return port;
return boolcons(false);
}
static lref_t execute_fast_op(lref_t fop, lref_t env)
{
lref_t retval = NIL;
lref_t sym;
lref_t binding;
lref_t fn;
lref_t args;
size_t argc;
lref_t argv[ARG_BUF_LEN];
lref_t after;
lref_t tag;
lref_t cell;
lref_t escape_retval;
jmp_buf *jmpbuf;
STACK_CHECK(&fop);
_process_interrupts();
fstack_enter_eval_frame(&fop, fop, env);
while(!NULLP(fop)) {
switch(fop->header.opcode)
{
case FOP_LITERAL:
retval = fop->as.fast_op.arg1;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_REF:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
retval = binding;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_SET:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, retval);
fop = fop->as.fast_op.next;
break;
case FOP_APPLY_GLOBAL:
sym = fop->as.fast_op.arg1;
fn = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(fn))
vmerror_unbound(sym);
argc = 0;
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_APPLY:
argc = 0;
fn = execute_fast_op(fop->as.fast_op.arg1, env);
args = fop->as.fast_op.arg2;
while (CONSP(args)) {
if (argc >= ARG_BUF_LEN) {
vmerror_unsupported(_T("too many actual arguments"));
break;
}
argv[argc] = execute_fast_op(CAR(args), env);
args = CDR(args);
argc++;
}
if (!NULLP(args))
vmerror_arg_out_of_range(fop->as.fast_op.arg2,
_T("bad formal argument list"));
fop = apply(fn, argc, argv, &env, &retval);
break;
case FOP_IF_TRUE:
if (TRUEP(retval))
fop = fop->as.fast_op.arg1;
else
fop = fop->as.fast_op.arg2;
break;
case FOP_RETVAL:
fop = fop->as.fast_op.next;
break;
case FOP_SEQUENCE:
retval = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.arg2;
break;
case FOP_THROW:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
escape_retval = execute_fast_op(fop->as.fast_op.arg2, env);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: throw ~a, retval = ~a\n"), tag, escape_retval));
CURRENT_TIB()->escape_frame = find_matching_escape(CURRENT_TIB()->frame, tag);
CURRENT_TIB()->escape_value = escape_retval;
if (CURRENT_TIB()->escape_frame == NULL) {
/* If we don't find a matching catch for the throw, we have a
* problem and need to invoke a trap. */
vmtrap(TRAP_UNCAUGHT_THROW,
(enum vmt_options_t)(VMT_MANDATORY_TRAP | VMT_HANDLER_MUST_ESCAPE),
2, tag, escape_retval);
}
unwind_stack_for_throw();
fop = fop->as.fast_op.next;
break;
case FOP_CATCH:
tag = execute_fast_op(fop->as.fast_op.arg1, env);
jmpbuf = fstack_enter_catch_frame(tag, CURRENT_TIB()->frame);
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: setjmp tag: ~a, frame: ~c&, jmpbuf: ~c&\n"), tag, CURRENT_TIB()->frame, jmpbuf));
if (setjmp(*jmpbuf) == 0) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
} else {
dscwritef(DF_SHOW_THROWS, (_T("; DEBUG: catch, retval = ~a\n"), CURRENT_TIB()->escape_value));
retval = CURRENT_TIB()->escape_value;
CURRENT_TIB()->escape_value = NIL;
}
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_WITH_UNWIND_FN:
fstack_enter_unwind_frame(execute_fast_op(fop->as.fast_op.arg1, env));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
after = CURRENT_TIB()->frame[FOFS_UNWIND_AFTER];
fstack_leave_frame();
apply1(after, 0, NULL);
fop = fop->as.fast_op.next;
break;
case FOP_CLOSURE:
retval = lclosurecons(env,
lcons(lcar(fop->as.fast_op.arg1),
fop->as.fast_op.arg2),
lcdr(fop->as.fast_op.arg1));
fop = fop->as.fast_op.next;
break;
case FOP_CAR:
retval = lcar(retval);
fop = fop->as.fast_op.next;
break;
case FOP_CDR:
retval = lcdr(retval);
fop = fop->as.fast_op.next;
break;
case FOP_NOT:
retval = boolcons(!TRUEP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_NULLP:
retval = boolcons(NULLP(retval));
fop = fop->as.fast_op.next;
break;
case FOP_EQP:
retval = boolcons(EQ(execute_fast_op(fop->as.fast_op.arg1, env),
execute_fast_op(fop->as.fast_op.arg2, env)));
fop = fop->as.fast_op.next;
break;
case FOP_GET_ENV:
retval = env;
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_DEF: // three args, third was genv, but currently unused
retval = lidefine_global(fop->as.fast_op.arg1, fop->as.fast_op.arg2);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FSP:
retval = fixcons((fixnum_t)CURRENT_TIB()->fsp);
fop = fop->as.fast_op.next;
break;
case FOP_GET_FRAME:
retval = fixcons((fixnum_t)CURRENT_TIB()->frame);
fop = fop->as.fast_op.next;
break;
case FOP_GET_HFRAMES:
retval = CURRENT_TIB()->handler_frames;
fop = fop->as.fast_op.next;
break;
case FOP_SET_HFRAMES:
CURRENT_TIB()->handler_frames = execute_fast_op(fop->as.fast_op.arg1, env);
fop = fop->as.fast_op.next;
break;
case FOP_GLOBAL_PRESERVE_FRAME:
sym = fop->as.fast_op.arg1;
binding = SYMBOL_VCELL(sym);
if (UNBOUND_MARKER_P(binding))
vmerror_unbound(sym);
SET_SYMBOL_VCELL(sym, fixcons((fixnum_t)CURRENT_TIB()->frame));
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fop = fop->as.fast_op.next;
break;
case FOP_STACK_BOUNDARY:
sym = execute_fast_op(fop->as.fast_op.arg1, env);
fstack_enter_boundary_frame(sym);
retval = execute_fast_op(fop->as.fast_op.arg2, env);
fstack_leave_frame();
fop = fop->as.fast_op.next;
break;
case FOP_FAST_ENQUEUE_CELL:
retval = execute_fast_op(fop->as.fast_op.arg2, env);
cell = execute_fast_op(fop->as.fast_op.arg1, env);
SET_CDR(CAR(retval), cell);
SET_CAR(retval, cell);
fop = fop->as.fast_op.next;
break;
case FOP_WHILE_TRUE:
while(TRUEP(execute_fast_op(fop->as.fast_op.arg1, env))) {
retval = execute_fast_op(fop->as.fast_op.arg2, env);
}
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_BY_INDEX:
retval = lenvlookup_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_REF_RESTARG:
retval = lenvlookup_restarg_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env);
fop = fop->as.fast_op.next;
break;
case FOP_LOCAL_SET_BY_INDEX:
lenvlookup_set_by_index(FIXNM(fop->as.fast_op.arg1),
FIXNM(fop->as.fast_op.arg2),
env,
retval);
fop = fop->as.fast_op.next;
break;
default:
panic("Unsupported fast-op");
}
}
fstack_leave_frame();
return retval;
}
lref_t debug_print_object(lref_t obj, lref_t port, bool machine_readable)
{
_TCHAR buf[STACK_STRBUF_LEN];
if (DEBUG_FLAG(DF_PRINT_ADDRESSES))
scwritef("#@~c&=", port, obj);
lref_t tmp;
size_t ii;
lref_t slots;
const _TCHAR *fast_op_name;
switch (TYPE(obj))
{
case TC_NIL:
WRITE_TEXT_CONSTANT(port, _T("()"));
break;
case TC_BOOLEAN:
if (TRUEP(obj))
WRITE_TEXT_CONSTANT(port, _T("#t"));
else
WRITE_TEXT_CONSTANT(port, _T("#f"));
break;
case TC_CONS:
write_char(port, _T('('));
debug_print_object(lcar(obj), port, machine_readable);
for (tmp = lcdr(obj); CONSP(tmp); tmp = lcdr(tmp))
{
write_char(port, _T(' '));
debug_print_object(lcar(tmp), port, machine_readable);
}
if (!NULLP(tmp))
{
WRITE_TEXT_CONSTANT(port, _T(" . "));
debug_print_object(tmp, port, machine_readable);
}
write_char(port, _T(')'));
break;
case TC_FIXNUM:
_sntprintf(buf, STACK_STRBUF_LEN, _T("%" SCAN_PRIiFIXNUM), FIXNM(obj));
write_text(port, buf, _tcslen(buf));
break;
case TC_FLONUM:
debug_print_flonum(obj, port, machine_readable);
break;
case TC_CHARACTER:
if (machine_readable)
{
if (CHARV(obj) < CHARNAMECOUNT)
scwritef(_T("#\\~cs"), port, charnames[(size_t) CHARV(obj)]);
else if (CHARV(obj) >= CHAREXTENDED - 1)
scwritef(_T("#\\<~cd>"), port, (int) CHARV(obj));
else
scwritef(_T("#\\~cc"), port, (int) CHARV(obj));
}
else
scwritef(_T("~cc"), port, (int) CHARV(obj));
break;
case TC_SYMBOL:
if (NULLP(SYMBOL_HOME(obj)))
{
if (DEBUG_FLAG(DF_PRINT_FOR_DIFF))
scwritef("#:<uninterned-symbol>", port);
else
scwritef("#:~a@~c&", port, SYMBOL_PNAME(obj), obj);
}
else if (SYMBOL_HOME(obj) == interp.control_fields[VMCTRL_PACKAGE_KEYWORD])
scwritef(":~a", port, SYMBOL_PNAME(obj));
else
{
/* With only a minimal c-level package implementation, we
* just assume every symbol is private. */
scwritef("~a::~a", port, SYMBOL_HOME(obj)->as.package.name, SYMBOL_PNAME(obj));
}
break;
case TC_VECTOR:
WRITE_TEXT_CONSTANT(port, _T("["));
for (ii = 0; ii < obj->as.vector.dim; ii++)
{
debug_print_object(obj->as.vector.data[ii], port, true);
if (ii + 1 < obj->as.vector.dim)
write_char(port, _T(' '));
}
write_char(port, _T(']'));
break;
case TC_STRUCTURE:
WRITE_TEXT_CONSTANT(port, _T("#S("));
debug_print_object(CAR(STRUCTURE_LAYOUT(obj)), port, true);
for (ii = 0, slots = CAR(CDR(STRUCTURE_LAYOUT(obj)));
ii < STRUCTURE_DIM(obj); ii++, slots = CDR(slots))
{
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(CAR(CAR(slots)), port, true);
WRITE_TEXT_CONSTANT(port, _T(" "));
debug_print_object(STRUCTURE_ELEM(obj, ii), port, true);
}
WRITE_TEXT_CONSTANT(port, _T(")"));
break;
case TC_STRING:
debug_print_string(obj, port, machine_readable);
break;
case TC_HASH:
debug_print_hash(obj, port, machine_readable);
break;
case TC_PACKAGE:
scwritef("~u ~a", port, (lref_t) obj, obj->as.package.name);
break;
case TC_SUBR:
scwritef("~u,~cd:~a", port, (lref_t) obj, SUBR_TYPE(obj), SUBR_NAME(obj));
break;
case TC_CLOSURE:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u\n\tcode:~s\n\tenv:~s\n\tp-list:~s", port,
(lref_t) obj, CLOSURE_CODE(obj), CLOSURE_ENV(obj),
CLOSURE_PROPERTY_LIST(obj));
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_VALUES_TUPLE:
scwritef("~u ~s", port, (lref_t) obj, obj->as.values_tuple.values);
break;
case TC_MACRO:
if (DEBUG_FLAG(DF_PRINT_CLOSURE_CODE))
scwritef("~u ~s", port, (lref_t) obj, obj->as.macro.transformer);
else
scwritef("~u", port, (lref_t) obj);
break;
case TC_END_OF_FILE:
scwritef("~u", port, (lref_t) obj);
break;
case TC_PORT:
scwritef(_T("~u~cs~cs~cs ~cs ~s"), port,
obj,
PORT_INPUTP(obj) ? " (input)" : "",
PORT_OUTPUTP(obj) ? " (output)" : "",
BINARY_PORTP(obj) ? " (binary)" : "",
PORT_CLASS(obj)->name,
PORT_PINFO(obj)->port_name);
break;
case TC_FAST_OP:
fast_op_name = fast_op_opcode_name(obj->header.opcode);
if (fast_op_name)
scwritef("#<FOP@~c&:~cs ~s ~s => ~s>", port, (lref_t) obj,
fast_op_name,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
else
scwritef("#<FOP@~c&:~cd ~s ~s => ~s>", port, (lref_t) obj,
obj->header.opcode,
obj->as.fast_op.arg1,
obj->as.fast_op.arg2,
obj->as.fast_op.next);
break;
case TC_FASL_READER:
scwritef(_T("~u~s"), port,
obj,
FASL_READER_PORT(obj));
break;
case TC_UNBOUND_MARKER:
scwritef("#<UNBOUND-MARKER>", port);
break;
case TC_FREE_CELL:
scwritef("#<FREE CELL -- Forget a call to gc_mark? ~c&>", port, obj);
break;
default:
scwritef("#<INVALID OBJECT - UNKNOWN TYPE ~c&>", port, obj);
}
return port;
}
void bgl_odbc_sql_set_env_attr(SQLHENV env,
obj_t attribute,
obj_t value)
{
SQLRETURN v;
SQLUINTEGER uintval = 0;
SQLPOINTER valueptr = 0;
SQLINTEGER stringlength = 0;
SQLINTEGER attr = 0;
if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "connection-pooling"))
{
attr = SQL_ATTR_CONNECTION_POOLING;
if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(value)), "off"))
{
uintval = SQL_CP_OFF;
valueptr = (SQLPOINTER)uintval;
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(value)), "one-per-driver"))
{
uintval = SQL_CP_ONE_PER_DRIVER;
valueptr = (SQLPOINTER)uintval;
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(value)), "one-per-environment"))
{
uintval = SQL_CP_ONE_PER_HENV;
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_env_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "match"))
{
attr = SQL_ATTR_CP_MATCH;
if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(value)), "strict"))
{
uintval = SQL_CP_STRICT_MATCH;
valueptr = (SQLPOINTER)uintval;
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(value)), "relaxed"))
{
uintval = SQL_CP_ONE_PER_DRIVER;
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_env_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "odbc-version"))
{
attr = SQL_ATTR_ODBC_VERSION;
if(INTEGERP(value))
{
uintval = (SQLUINTEGER)CINT(value);
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_env_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "output-nts"))
{
attr = SQL_ATTR_OUTPUT_NTS;
if(TRUEP(value))
{
uintval = SQL_TRUE;
valueptr = (SQLPOINTER)uintval;
}
else
{
uintval = SQL_FALSE;
valueptr = (SQLPOINTER)uintval;
}
}
else
{
odbc_error("bgl_odbc_sql_set_env_attr",
"Invalid or Unsupported attribute ",
attribute);
}
v = SQLSetEnvAttr(env,
attr,
valueptr,
stringlength);
if(!SQL_SUCCEEDED(v))
{
report_odbc_error("bgl_odbc_sql_set_env_attr",
SQL_HANDLE_ENV,
env);
}
}
void bgl_odbc_sql_set_connect_attr(SQLHANDLE dbc,
obj_t attribute,
obj_t value)
{
SQLRETURN v;
SQLUINTEGER uintval = 0;
SQLPOINTER valueptr = 0;
SQLINTEGER stringlength = 0;
SQLINTEGER attr = 0;
if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "access-mode"))
{
attr = SQL_ATTR_ACCESS_MODE;
if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "read-only"))
{
uintval = SQL_MODE_READ_ONLY;
valueptr = (SQLPOINTER)uintval;
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "read-write"))
{
uintval = SQL_MODE_READ_WRITE;
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_connect_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "asynch-enable"))
{
attr = SQL_ATTR_ASYNC_ENABLE;
if(TRUEP( value ))
{
uintval = SQL_ASYNC_ENABLE_ON;
valueptr = (SQLPOINTER)uintval;
}
else
{
uintval = SQL_ASYNC_ENABLE_OFF;
valueptr = (SQLPOINTER)uintval;
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "auto-ipd"))
{
attr = SQL_ATTR_AUTO_IPD;
if(TRUEP( value ))
{
uintval = SQL_TRUE;
valueptr = (SQLPOINTER)uintval;
}
else
{
uintval = SQL_FALSE;
valueptr = (SQLPOINTER)uintval;
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "autocommit"))
{
attr = SQL_ATTR_AUTOCOMMIT;
if(TRUEP( value ))
{
uintval = SQL_AUTOCOMMIT_OFF;
valueptr = (SQLPOINTER)uintval;
}
else
{
uintval = SQL_AUTOCOMMIT_ON;
valueptr = (SQLPOINTER)uintval;
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "connection-timeout"))
{
attr = SQL_ATTR_CONNECTION_TIMEOUT;
if(INTEGERP( value ))
{
uintval = CINT(value);
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_connect_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "login-timeout"))
{
attr = SQL_ATTR_LOGIN_TIMEOUT;
if(INTEGERP( value ))
{
uintval = CINT(value);
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_connect_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "current-catalog"))
{
attr = SQL_ATTR_CURRENT_CATALOG;
if(STRINGP( value ))
{
valueptr = (SQLPOINTER)BSTRING_TO_STRING(value);
stringlength = strlen(BSTRING_TO_STRING(value));
}
else
{
odbc_error("bgl_odbc_sql_set_connect_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "metadata-id"))
{
attr = SQL_ATTR_METADATA_ID;
if(TRUEP( value ))
{
uintval = SQL_TRUE;
valueptr = (SQLPOINTER)uintval;
}
else
{
uintval = SQL_FALSE;
valueptr = (SQLPOINTER)uintval;
}
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "odbc-cursor"))
{
attr = SQL_ATTR_ODBC_CURSORS;
if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "use-if-needed"))
{
uintval = SQL_CUR_USE_IF_NEEDED;
valueptr = (SQLPOINTER)uintval;
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "use-odbc"))
{
uintval = SQL_CUR_USE_ODBC;
valueptr = (SQLPOINTER)uintval;
}
else if(0 == strcmp(BSTRING_TO_STRING(SYMBOL_TO_STRING(attribute)), "use-driver"))
{
uintval = SQL_CUR_USE_DRIVER;
valueptr = (SQLPOINTER)uintval;
}
else
{
odbc_error("bgl_odbc_sql_set_connect_attr",
"Invalid attribute value",
MAKE_PAIR(attribute, value));
}
}
else
{
odbc_error("bgl_odbc_sql_set_connect_attr",
"Invalid Or Unsupported attribute",
MAKE_PAIR(attribute, value));
}
v = SQLSetConnectAttr(dbc,
attr,
valueptr,
stringlength);
if(!SQL_SUCCEEDED(v))
{
report_odbc_error("bgl_odbc_sql_set_connect_attr",
SQL_HANDLE_DBC,
dbc);
}
}
static void
write_obj(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
ScmObj sym;
#if SCM_USE_SRFI38
if (INTERESTINGP(obj)) {
scm_intobj_t index = get_shared_index(obj);
if (index > 0) {
/* defined datum */
scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index);
return;
}
if (index < 0) {
/* defining datum, with the new index negated */
scm_format(port, SCM_FMT_RAW_C, "#~ZU=", (size_t)-index);
/* Print it; the next time it'll be defined. */
}
}
#endif
switch (SCM_TYPE(obj)) {
#if SCM_USE_INT
case ScmInt:
scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj));
break;
#endif
case ScmCons:
if (ERROBJP(obj))
write_errobj(port, obj, otype);
else
write_list(port, obj, otype);
break;
case ScmSymbol:
scm_port_puts(port, SCM_SYMBOL_NAME(obj));
break;
#if SCM_USE_CHAR
case ScmChar:
write_char(port, obj, otype);
break;
#endif
#if SCM_USE_STRING
case ScmString:
write_string(port, obj, otype);
break;
#endif
case ScmFunc:
scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr ");
sym = scm_symbol_bound_to(obj);
if (TRUEP(sym))
scm_display(port, sym);
else
scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj);
scm_port_put_char(port, '>');
break;
#if SCM_USE_HYGIENIC_MACRO
case ScmMacro:
scm_port_puts(port, "#<macro ");
write_obj(port, SCM_HMACRO_RULES(obj), otype);
scm_port_puts(port, ">");
break;
case ScmFarsymbol:
write_farsymbol(port, obj, otype);
break;
case ScmSubpat:
if (SCM_SUBPAT_PVARP(obj)) {
#if SCM_DEBUG_MACRO
scm_port_puts(port, "#<pvar ");
write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
scm_format(port, SCM_FMT_RAW_C, " ~MD>",
SCM_SUBPAT_PVAR_INDEX(obj));
#else /* not SCM_DEBUG_MACRO */
write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
#endif /* not SCM_DEBUG_MACRO */
} else {
SCM_ASSERT(SCM_SUBPAT_REPPATP(obj));
write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype);
#if SCM_DEBUG_MACRO
scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..",
SCM_SUBPAT_REPPAT_PVCOUNT(obj));
#else
scm_port_puts(port, " ...");
#endif
}
break;
#endif /* SCM_USE_HYGIENIC_MACRO */
case ScmClosure:
#if SCM_USE_LEGACY_MACRO
if (SYNTACTIC_CLOSUREP(obj))
scm_port_puts(port, "#<syntactic closure ");
else
#endif
scm_port_puts(port, "#<closure ");
write_obj(port, SCM_CLOSURE_EXP(obj), otype);
scm_port_put_char(port, '>');
break;
#if SCM_USE_VECTOR
case ScmVector:
write_vector(port, obj, otype);
break;
#endif
case ScmPort:
write_port(port, obj, otype);
break;
#if SCM_USE_CONTINUATION
case ScmContinuation:
scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj);
break;
#endif
case ScmValuePacket:
scm_port_puts(port, "#<values ");
write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype);
#if SCM_USE_VALUECONS
#if SCM_USE_STORAGE_FATTY
/* SCM_VALUEPACKET_VALUES() changes the type destructively */
SCM_ENTYPE(obj, ScmValuePacket);
#else /* SCM_USE_STORAGE_FATTY */
#error "valuecons is not supported on this storage implementation"
#endif /* SCM_USE_STORAGE_FATTY */
#endif /* SCM_USE_VALUECONS */
scm_port_put_char(port, '>');
break;
case ScmConstant:
write_constant(port, obj, otype);
break;
#if SCM_USE_SSCM_EXTENSIONS
case ScmCPointer:
scm_format(port, SCM_FMT_RAW_C,
"#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj));
break;
case ScmCFuncPointer:
scm_format(port, SCM_FMT_RAW_C,
"#<c_func_pointer ~P>",
(void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj));
break;
#endif
case ScmRational:
case ScmReal:
case ScmComplex:
default:
SCM_NOTREACHED;
}
}
