//
// Resolve_Path: C
//
// Given a path, determine if it is ultimately specifying a selection out
// of a context...and if it is, return that context. So `a/obj/key` would
// return the object assocated with obj, while `a/str/1` would return
// NULL if `str` were a string as it's not an object selection.
//
// !!! This routine overlaps the logic of Do_Path, and should potentially
// be a mode of that instead. It is not very complete, considering that it
// does not execute GROUP! (and perhaps shouldn't?) and only supports a
// path that picks contexts out of other contexts, via word selection.
//
REBCTX *Resolve_Path(const REBVAL *path, REBCNT *index_out)
{
RELVAL *selector;
const REBVAL *var;
REBARR *array;
REBCNT i;
array = VAL_ARRAY(path);
selector = ARR_HEAD(array);
if (IS_END(selector) || !ANY_WORD(selector))
return NULL; // !!! only handles heads of paths that are ANY-WORD!
var = GET_OPT_VAR_MAY_FAIL(selector, VAL_SPECIFIER(path));
++selector;
if (IS_END(selector))
return NULL; // !!! does not handle single-element paths
while (ANY_CONTEXT(var) && IS_WORD(selector)) {
i = Find_Canon_In_Context(
VAL_CONTEXT(var), VAL_WORD_CANON(selector), FALSE
);
++selector;
if (IS_END(selector)) {
*index_out = i;
return VAL_CONTEXT(var);
}
var = CTX_VAR(VAL_CONTEXT(var), i);
}
DEAD_END;
}
//
// Get_Object: C
//
// Get an instance variable from an ANY-CONTEXT! value.
//
REBVAL *Get_Object(const REBVAL *any_context, REBCNT index)
{
REBCTX *context = VAL_CONTEXT(any_context);
assert(GET_ARR_FLAG(CTX_VARLIST(context), ARRAY_FLAG_CONTEXT_VARLIST));
assert(index <= CTX_LEN(context));
return CTX_VAR(context, index);
}
//
// Get_System: C
//
// Return a second level object field of the system object.
//
REBVAL *Get_System(REBCNT i1, REBCNT i2)
{
REBVAL *obj;
obj = CTX_VAR(VAL_CONTEXT(ROOT_SYSTEM), i1);
if (i2 == 0) return obj;
assert(IS_OBJECT(obj));
return Get_Field(VAL_CONTEXT(obj), i2);
}
//
// RL_Get_Field: C
//
// Get a field value (context variable) of an object.
//
// Returns:
// Datatype of value or zero if word is not found in the object.
// Arguments:
// obj - object pointer (e.g. from RXA_OBJECT)
// word - global word identifier (integer)
// result - gets set to the value of the field
//
RL_API int RL_Get_Field(REBSER *obj, u32 word, RXIARG *result)
{
REBCTX *context = AS_CONTEXT(obj);
REBVAL *value;
if (!(word = Find_Word_In_Context(context, word, FALSE))) return 0;
value = CTX_VAR(context, word);
Value_To_RXI(result, value);
return Reb_To_RXT[VAL_TYPE_0(value)];
}
//
// RL_Set_Field: C
//
// Set a field (context variable) of an object.
//
// Returns:
// The type arg, or zero if word not found in object or if field is protected.
// Arguments:
// obj - object pointer (e.g. from RXA_OBJECT)
// word_id - global word identifier (integer)
// val - new value for field
// type - datatype of value
//
RL_API int RL_Set_Field(REBSER *obj, u32 word_id, RXIARG val, int type)
{
REBCTX *context = AS_CONTEXT(obj);
word_id = Find_Word_In_Context(context, word_id, FALSE);
if (word_id == 0) return 0;
if (GET_VAL_FLAG(CTX_KEY(context, word_id), TYPESET_FLAG_LOCKED))
return 0;
RXI_To_Value(CTX_VAR(context, word_id), &val, type);
return type;
}
//
// RL_Extend: C
//
// Appends embedded extension to system/catalog/boot-exts.
//
// Returns:
// A pointer to the REBOL library (see reb-lib.h).
// Arguments:
// source - A pointer to a UTF-8 (or ASCII) string that provides
// extension module header, function definitions, and other
// related functions and data.
// call - A pointer to the extension's command dispatcher.
// Notes:
// This function simply adds the embedded extension to the
// boot-exts list. All other processing and initialization
// happens later during startup. Each embedded extension is
// queried and init using LOAD-EXTENSION system native.
// See c:extensions-embedded
//
RL_API void *RL_Extend(const REBYTE *source, RXICAL call)
{
REBVAL *value;
REBARR *array;
value = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EXTS);
if (IS_BLOCK(value))
array = VAL_ARRAY(value);
else {
array = Make_Array(2);
Val_Init_Block(value, array);
}
value = Alloc_Tail_Array(array);
Val_Init_Binary(value, Copy_Bytes(source, -1)); // UTF-8
value = Alloc_Tail_Array(array);
SET_HANDLE_CODE(value, cast(CFUNC*, call));
return Extension_Lib();
}
//
// In_Object: C
//
// Get value from nested list of objects. List is null terminated.
// Returns object value, else returns 0 if not found.
//
REBVAL *In_Object(REBCTX *base, ...)
{
REBVAL *context = NULL;
REBCNT n;
va_list va;
va_start(va, base);
while ((n = va_arg(va, REBCNT))) {
if (n > CTX_LEN(base)) {
va_end(va);
return NULL;
}
context = CTX_VAR(base, n);
if (!ANY_CONTEXT(context)) {
va_end(va);
return NULL;
}
base = VAL_CONTEXT(context);
}
va_end(va);
return context;
}
//
// Get_Field: C
//
// Get an instance variable from an object series.
//
REBVAL *Get_Field(REBCTX *context, REBCNT index)
{
assert(index <= CTX_LEN(context));
return CTX_VAR(context, index);
}
//
// Type_Of: C
//
// Returns the datatype value for the given value.
// The datatypes are all at the head of the context.
//
REBVAL *Type_Of(const REBVAL *value)
{
return CTX_VAR(Lib_Context, SYM_FROM_KIND(VAL_TYPE(value)));
}
//
// Get_Type: C
//
// Returns the specified datatype value from the system context.
// The datatypes are all at the head of the context.
//
REBVAL *Get_Type(enum Reb_Kind kind)
{
return CTX_VAR(Lib_Context, SYM_FROM_KIND(kind));
}
//
// Val_Init_Datatype: C
//
void Val_Init_Datatype(REBVAL *value, enum Reb_Kind kind)
{
*value = *CTX_VAR(Lib_Context, SYM_FROM_KIND(kind));
}
//
// RL_Start: C
//
// Evaluate the default boot function.
//
// Returns:
// Zero on success, otherwise indicates an error occurred.
// Arguments:
// bin - optional startup code (compressed), can be null
// len - length of above bin
// flags - special flags
// Notes:
// This function completes the startup sequence by calling
// the sys/start function.
//
RL_API int RL_Start(REBYTE *bin, REBINT len, REBYTE *script, REBINT script_len, REBCNT flags)
{
REBVAL *val;
REBSER *ser;
struct Reb_State state;
REBCTX *error;
int error_num;
REBVAL result;
VAL_INIT_WRITABLE_DEBUG(&result);
if (bin) {
ser = Decompress(bin, len, -1, FALSE, FALSE);
if (!ser) return 1;
val = CTX_VAR(Sys_Context, SYS_CTX_BOOT_HOST);
Val_Init_Binary(val, ser);
}
if (script && script_len > 4) {
/* a 4-byte long payload type at the beginning */
i32 ptype = 0;
REBYTE *data = script + sizeof(ptype);
script_len -= sizeof(ptype);
memcpy(&ptype, script, sizeof(ptype));
if (ptype == 1) {/* COMPRESSed data */
ser = Decompress(data, script_len, -1, FALSE, FALSE);
} else {
ser = Make_Binary(script_len);
if (ser == NULL) {
OS_FREE(script);
return 1;
}
memcpy(BIN_HEAD(ser), data, script_len);
}
OS_FREE(script);
val = CTX_VAR(Sys_Context, SYS_CTX_BOOT_EMBEDDED);
Val_Init_Binary(val, ser);
}
PUSH_UNHALTABLE_TRAP(&error, &state);
// The first time through the following code 'error' will be NULL, but...
// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
if (error) {
//
// !!! We are not allowed to ask for a print operation that can take
// arbitrarily long without allowing for cancellation via Ctrl-C,
// but here we are wanting to print an error. If you're printing
// out an error and get a halt, it won't print the halt.
//
REBCTX *halt_error;
// Save error for WHY?
//
REBVAL *last = Get_System(SYS_STATE, STATE_LAST_ERROR);
Val_Init_Error(last, error);
PUSH_UNHALTABLE_TRAP(&halt_error, &state);
// The first time through the following code 'error' will be NULL, but...
// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
if (halt_error) {
assert(ERR_NUM(halt_error) == RE_HALT);
return ERR_NUM(halt_error);
}
Print_Value(last, 1024, FALSE);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
// !!! When running in a script, whether or not the Rebol interpreter
// just exits in an error case with a bad error code or breaks you
// into the console to debug the environment should be controlled by
// a command line option. Defaulting to returning an error code
// seems better, because kicking into an interactive session can
// cause logging systems to hang.
// For RE_HALT and all other errors we return the error
// number. Error numbers are not set in stone (currently), but
// are never zero...which is why we can use 0 for success.
//
return ERR_NUM(error);
}
if (Apply_Only_Throws(
&result, Sys_Func(SYS_CTX_FINISH_RL_START), END_VALUE
)) {
#if !defined(NDEBUG)
if (LEGACY(OPTIONS_EXIT_FUNCTIONS_ONLY))
fail (Error_No_Catch_For_Throw(&result));
#endif
if (
IS_FUNCTION_AND(&result, FUNC_CLASS_NATIVE) && (
VAL_FUNC_CODE(&result) == &N_quit
|| VAL_FUNC_CODE(&result) == &N_exit
)
) {
int status;
CATCH_THROWN(&result, &result);
status = Exit_Status_From_Value(&result);
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
Shutdown_Core();
OS_EXIT(status);
DEAD_END;
}
fail (Error_No_Catch_For_Throw(&result));
}
DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
// The convention in the API was to return 0 for success. We use the
// convention (as for FINISH_INIT_CORE) that any non-UNSET! result from
// FINISH_RL_START indicates something went wrong.
if (IS_UNSET(&result))
error_num = 0; // no error
else {
assert(FALSE); // should not happen (raise an error instead)
Debug_Fmt("** finish-rl-start returned non-NONE!:");
Debug_Fmt("%r", &result);
error_num = RE_MISC;
}
return error_num;
}
//
// Specialize_Action_Throws: C
//
// Create a new ACTION! value that uses the same implementation as another,
// but just takes fewer arguments or refinements. It does this by storing a
// heap-based "exemplar" FRAME! in the specialized action; this stores the
// values to preload in the stack frame cells when it is invoked.
//
// The caller may provide information on the order in which refinements are
// to be specialized, using the data stack. These refinements should be
// pushed in the *reverse* order of their invocation, so append/dup/part
// has /DUP at DS_TOP, and /PART under it. List stops at lowest_ordered_dsp.
//
bool Specialize_Action_Throws(
REBVAL *out,
REBVAL *specializee,
REBSTR *opt_specializee_name,
REBVAL *opt_def, // !!! REVIEW: binding modified directly (not copied)
REBDSP lowest_ordered_dsp
){
assert(out != specializee);
struct Reb_Binder binder;
if (opt_def)
INIT_BINDER(&binder);
REBACT *unspecialized = VAL_ACTION(specializee);
// This produces a context where partially specialized refinement slots
// will be on the stack (including any we are adding "virtually", from
// the current DSP down to the lowest_ordered_dsp).
//
REBCTX *exemplar = Make_Context_For_Action_Push_Partials(
specializee,
lowest_ordered_dsp,
opt_def ? &binder : nullptr,
CELL_MASK_NON_STACK
);
Manage_Array(CTX_VARLIST(exemplar)); // destined to be managed, guarded
if (opt_def) { // code that fills the frame...fully or partially
//
// Bind all the SET-WORD! in the body that match params in the frame
// into the frame. This means `value: value` can very likely have
// `value:` bound for assignments into the frame while `value` refers
// to whatever value was in the context the specialization is running
// in, but this is likely the more useful behavior.
//
// !!! This binds the actual arg data, not a copy of it--following
// OBJECT!'s lead. However, ordinary functions make a copy of the
// body they are passed before rebinding. Rethink.
// See Bind_Values_Core() for explanations of how the binding works.
Bind_Values_Inner_Loop(
&binder,
VAL_ARRAY_AT(opt_def),
exemplar,
FLAGIT_KIND(REB_SET_WORD), // types to bind (just set-word!)
0, // types to "add midstream" to binding as we go (nothing)
BIND_DEEP
);
// !!! Only one binder can be in effect, and we're calling arbitrary
// code. Must clean up now vs. in loop we do at the end. :-(
//
RELVAL *key = CTX_KEYS_HEAD(exemplar);
REBVAL *var = CTX_VARS_HEAD(exemplar);
for (; NOT_END(key); ++key, ++var) {
if (Is_Param_Unbindable(key))
continue; // !!! is this flag still relevant?
if (Is_Param_Hidden(key)) {
assert(GET_CELL_FLAG(var, ARG_MARKED_CHECKED));
continue;
}
if (GET_CELL_FLAG(var, ARG_MARKED_CHECKED))
continue; // may be refinement from stack, now specialized out
Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
}
SHUTDOWN_BINDER(&binder);
// Run block and ignore result (unless it is thrown)
//
PUSH_GC_GUARD(exemplar);
bool threw = Do_Any_Array_At_Throws(out, opt_def, SPECIFIED);
DROP_GC_GUARD(exemplar);
if (threw) {
DS_DROP_TO(lowest_ordered_dsp);
return true;
}
}
REBVAL *rootkey = CTX_ROOTKEY(exemplar);
// Build up the paramlist for the specialized function on the stack.
// The same walk used for that is used to link and process REB_X_PARTIAL
// arguments for whether they become fully specialized or not.
REBDSP dsp_paramlist = DSP;
Move_Value(DS_PUSH(), ACT_ARCHETYPE(unspecialized));
REBVAL *param = rootkey + 1;
REBVAL *arg = CTX_VARS_HEAD(exemplar);
REBDSP ordered_dsp = lowest_ordered_dsp;
for (; NOT_END(param); ++param, ++arg) {
if (TYPE_CHECK(param, REB_TS_REFINEMENT)) {
if (IS_NULLED(arg)) {
//
// A refinement that is nulled is a candidate for usage at the
// callsite. Hence it must be pre-empted by our ordered
// overrides. -but- the overrides only apply if their slot
// wasn't filled by the user code. Yet these values we are
// putting in disrupt that detection (!), so use another
// flag (PUSH_PARTIAL) to reflect this state.
//
while (ordered_dsp != dsp_paramlist) {
++ordered_dsp;
REBVAL *ordered = DS_AT(ordered_dsp);
if (not IS_WORD_BOUND(ordered)) // specialize 'print/asdf
fail (Error_Bad_Refine_Raw(ordered));
REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered));
if (
IS_NULLED(slot) or GET_CELL_FLAG(slot, PUSH_PARTIAL)
){
// It's still partial, so set up the pre-empt.
//
Init_Any_Word_Bound(
arg,
REB_SYM_WORD,
VAL_STORED_CANON(ordered),
exemplar,
VAL_WORD_INDEX(ordered)
);
SET_CELL_FLAG(arg, PUSH_PARTIAL);
goto unspecialized_arg;
}
// Otherwise the user filled it in, so skip to next...
}
goto unspecialized_arg; // ran out...no pre-empt needed
}
if (GET_CELL_FLAG(arg, ARG_MARKED_CHECKED)) {
assert(
IS_BLANK(arg)
or (
IS_REFINEMENT(arg)
and (
VAL_REFINEMENT_SPELLING(arg)
== VAL_PARAM_SPELLING(param)
)
)
);
}
else
Typecheck_Refinement_And_Canonize(param, arg);
goto specialized_arg_no_typecheck;
}
switch (VAL_PARAM_CLASS(param)) {
case REB_P_RETURN:
case REB_P_LOCAL:
assert(IS_NULLED(arg)); // no bindings, you can't set these
goto unspecialized_arg;
default:
break;
}
// It's an argument, either a normal one or a refinement arg.
if (not IS_NULLED(arg))
goto specialized_arg_with_check;
unspecialized_arg:
assert(NOT_CELL_FLAG(arg, ARG_MARKED_CHECKED));
assert(
IS_NULLED(arg)
or (IS_SYM_WORD(arg) and TYPE_CHECK(param, REB_TS_REFINEMENT))
);
Move_Value(DS_PUSH(), param);
continue;
specialized_arg_with_check:
// !!! If argument was previously specialized, should have been type
// checked already... don't type check again (?)
//
if (Is_Param_Variadic(param))
fail ("Cannot currently SPECIALIZE variadic arguments.");
if (TYPE_CHECK(param, REB_TS_DEQUOTE_REQUOTE) and IS_QUOTED(arg)) {
//
// Have to leave the quotes on, but still want to type check.
if (not TYPE_CHECK(param, CELL_KIND(VAL_UNESCAPED(arg))))
fail (arg); // !!! merge w/Error_Invalid_Arg()
}
else if (not TYPE_CHECK(param, VAL_TYPE(arg)))
fail (arg); // !!! merge w/Error_Invalid_Arg()
SET_CELL_FLAG(arg, ARG_MARKED_CHECKED);
specialized_arg_no_typecheck:
// Specialized-out arguments must still be in the parameter list,
// for enumeration in the evaluator to line up with the frame values
// of the underlying function.
assert(GET_CELL_FLAG(arg, ARG_MARKED_CHECKED));
Move_Value(DS_PUSH(), param);
TYPE_SET(DS_TOP, REB_TS_HIDDEN);
continue;
}
REBARR *paramlist = Pop_Stack_Values_Core(
dsp_paramlist,
SERIES_MASK_PARAMLIST
| (SER(unspecialized)->header.bits & PARAMLIST_MASK_INHERIT)
);
Manage_Array(paramlist);
RELVAL *rootparam = ARR_HEAD(paramlist);
VAL_ACT_PARAMLIST_NODE(rootparam) = NOD(paramlist);
// Everything should have balanced out for a valid specialization
//
while (ordered_dsp != DSP) {
++ordered_dsp;
REBVAL *ordered = DS_AT(ordered_dsp);
if (not IS_WORD_BOUND(ordered)) // specialize 'print/asdf
fail (Error_Bad_Refine_Raw(ordered));
REBVAL *slot = CTX_VAR(exemplar, VAL_WORD_INDEX(ordered));
assert(not IS_NULLED(slot) and NOT_CELL_FLAG(slot, PUSH_PARTIAL));
UNUSED(slot);
}
DS_DROP_TO(lowest_ordered_dsp);
// See %sysobj.r for `specialized-meta:` object template
REBVAL *example = Get_System(SYS_STANDARD, STD_SPECIALIZED_META);
REBCTX *meta = Copy_Context_Shallow_Managed(VAL_CONTEXT(example));
Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_DESCRIPTION)); // default
Move_Value(
CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE),
specializee
);
if (not opt_specializee_name)
Init_Nulled(CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME));
else
Init_Word(
CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME),
opt_specializee_name
);
MISC_META_NODE(paramlist) = NOD(meta);
REBACT *specialized = Make_Action(
paramlist,
&Specializer_Dispatcher,
ACT_UNDERLYING(unspecialized), // same underlying action as this
exemplar, // also provide a context of specialization values
1 // details array capacity
);
assert(CTX_KEYLIST(exemplar) == ACT_PARAMLIST(unspecialized));
assert(
GET_ACTION_FLAG(specialized, IS_INVISIBLE)
== GET_ACTION_FLAG(unspecialized, IS_INVISIBLE)
);
// The "body" is the FRAME! value of the specialization. It takes on the
// binding we want to use (which we can't put in the exemplar archetype,
// that binding has to be UNBOUND). It also remembers the original
// action in the phase, so Specializer_Dispatcher() knows what to call.
//
RELVAL *body = ARR_HEAD(ACT_DETAILS(specialized));
Move_Value(body, CTX_ARCHETYPE(exemplar));
INIT_BINDING(body, VAL_BINDING(specializee));
INIT_VAL_CONTEXT_PHASE(body, unspecialized);
Init_Action_Unbound(out, specialized);
return false; // code block did not throw
}
//
// Serial_Actor: C
//
static REB_R Serial_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
REBREQ *req; // IO request
REBVAL *spec; // port spec
REBVAL *arg; // action argument value
REBVAL *val; // e.g. port number value
REBINT result; // IO result
REBCNT refs; // refinement argument flags
REBCNT len; // generic length
REBSER *ser; // simplifier
REBVAL *path;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
// Validate PORT fields:
spec = CTX_VAR(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) fail (Error(RE_INVALID_PORT));
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) fail (Error(RE_INVALID_SPEC, spec));
//if (!IS_FILE(path)) fail (Error(RE_INVALID_SPEC, path));
req = cast(REBREQ*, Use_Port_State(port, RDI_SERIAL, sizeof(*req)));
// Actions for an unopened serial port:
if (!IS_OPEN(req)) {
switch (action) {
case SYM_OPEN:
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PATH);
if (! (IS_FILE(arg) || IS_STRING(arg) || IS_BINARY(arg)))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.path = ALLOC_N(REBCHR, MAX_SERIAL_DEV_PATH);
OS_STRNCPY(
req->special.serial.path,
//
// !!! This is assuming VAL_DATA contains native chars.
// Should it? (2 bytes on windows, 1 byte on linux/mac)
//
SER_AT(REBCHR, VAL_SERIES(arg), VAL_INDEX(arg)),
MAX_SERIAL_DEV_PATH
);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_SPEED);
if (! IS_INTEGER(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
req->special.serial.baud = VAL_INT32(arg);
//Secure_Port(SYM_SERIAL, ???, path, ser);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_DATA_SIZE);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 5
|| VAL_INT64(arg) > 8
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.data_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_STOP_BITS);
if (!IS_INTEGER(arg)
|| VAL_INT64(arg) < 1
|| VAL_INT64(arg) > 2
) {
fail (Error(RE_INVALID_PORT_ARG, arg));
}
req->special.serial.stop_bits = VAL_INT32(arg);
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PARITY);
if (IS_BLANK(arg)) {
req->special.serial.parity = SERIAL_PARITY_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_ODD:
req->special.serial.parity = SERIAL_PARITY_ODD;
break;
case SYM_EVEN:
req->special.serial.parity = SERIAL_PARITY_EVEN;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_FLOW_CONTROL);
if (IS_BLANK(arg)) {
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_NONE;
} else {
if (!IS_WORD(arg))
fail (Error(RE_INVALID_PORT_ARG, arg));
switch (VAL_WORD_SYM(arg)) {
case SYM_HARDWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_HARDWARE;
break;
case SYM_SOFTWARE:
req->special.serial.flow_control = SERIAL_FLOW_CONTROL_SOFTWARE;
break;
default:
fail (Error(RE_INVALID_PORT_ARG, arg));
}
}
if (OS_DO_DEVICE(req, RDC_OPEN))
fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
SET_OPEN(req);
return R_OUT;
case SYM_CLOSE:
return R_OUT;
case SYM_OPEN_Q:
return R_FALSE;
default:
fail (Error_On_Port(RE_NOT_OPEN, port, -12));
}
}
// Actions for an open socket:
switch (action) {
case SYM_READ:
refs = Find_Refines(frame_, ALL_READ_REFS);
// Setup the read buffer (allocate a buffer if needed):
arg = CTX_VAR(port, STD_PORT_DATA);
if (!IS_STRING(arg) && !IS_BINARY(arg)) {
Val_Init_Binary(arg, Make_Binary(32000));
}
ser = VAL_SERIES(arg);
req->length = SER_AVAIL(ser); // space available
if (req->length < 32000/2) Extend_Series(ser, 32000);
req->length = SER_AVAIL(ser);
// This used STR_TAIL (obsolete, equivalent to BIN_TAIL) but was it
// sure the series was byte sized? Added in a check.
assert(BYTE_SIZE(ser));
req->common.data = BIN_TAIL(ser); // write at tail
//if (SER_LEN(ser) == 0)
req->actual = 0; // Actual for THIS read, not for total.
#ifdef DEBUG_SERIAL
printf("(max read length %d)", req->length);
#endif
result = OS_DO_DEVICE(req, RDC_READ); // recv can happen immediately
if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
#ifdef DEBUG_SERIAL
for (len = 0; len < req->actual; len++) {
if (len % 16 == 0) printf("\n");
printf("%02x ", req->common.data[len]);
}
printf("\n");
#endif
*D_OUT = *arg;
return R_OUT;
case SYM_WRITE:
refs = Find_Refines(frame_, ALL_WRITE_REFS);
// Determine length. Clip /PART to size of string if needed.
spec = D_ARG(2);
len = VAL_LEN_AT(spec);
if (refs & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LIMIT), 0);
if (n <= len) len = n;
}
// Setup the write:
*CTX_VAR(port, STD_PORT_DATA) = *spec; // keep it GC safe
req->length = len;
req->common.data = VAL_BIN_AT(spec);
req->actual = 0;
//Print("(write length %d)", len);
result = OS_DO_DEVICE(req, RDC_WRITE); // send can happen immediately
if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, req->error));
break;
case SYM_UPDATE:
// Update the port object after a READ or WRITE operation.
// This is normally called by the WAKE-UP function.
arg = CTX_VAR(port, STD_PORT_DATA);
if (req->command == RDC_READ) {
if (ANY_BINSTR(arg)) {
SET_SERIES_LEN(
VAL_SERIES(arg),
VAL_LEN_HEAD(arg) + req->actual
);
}
}
else if (req->command == RDC_WRITE) {
SET_BLANK(arg); // Write is done.
}
return R_BLANK;
case SYM_OPEN_Q:
return R_TRUE;
case SYM_CLOSE:
if (IS_OPEN(req)) {
OS_DO_DEVICE(req, RDC_CLOSE);
SET_CLOSED(req);
}
break;
default:
fail (Error_Illegal_Action(REB_PORT, action));
}
return R_OUT;
}
