*/ void Set_Var(const REBVAL *word, const REBVAL *value)
/*
** Set the word (variable) value. (Use macro when possible).
**
***********************************************************************/
{
REBINT index = VAL_WORD_INDEX(word);
struct Reb_Call *call;
REBSER *frm;
assert(!THROWN(value));
if (!HAS_FRAME(word)) raise Error_1(RE_NOT_DEFINED, word);
assert(VAL_WORD_FRAME(word));
// Print("Set %s to %s [frame: %x idx: %d]", Get_Word_Name(word), Get_Type_Name(value), VAL_WORD_FRAME(word), VAL_WORD_INDEX(word));
if (index > 0) {
frm = VAL_WORD_FRAME(word);
if (VAL_GET_EXT(FRM_WORDS(frm) + index, EXT_WORD_LOCK))
raise Error_1(RE_LOCKED_WORD, word);
FRM_VALUES(frm)[index] = *value;
return;
}
if (index == 0) raise Error_0(RE_SELF_PROTECTED);
// Find relative value:
call = DSF;
while (VAL_WORD_FRAME(word) != VAL_WORD_FRAME(DSF_LABEL(call))) {
call = PRIOR_DSF(call);
if (!call) raise Error_1(RE_NOT_DEFINED, word); // change error !!!
}
*DSF_ARG(call, -index) = *value;
}
*/ void Get_Var_Into_Core(REBVAL *out, const REBVAL *word)
/*
** Variant of Get_Var_Core that always traps and never returns a
** direct pointer into a frame. It is thus able to give back
** `self` lookups, and doesn't have to check the word's protection
** status before returning.
**
** See comments in Get_Var_Core for what it's actually doing.
**
***********************************************************************/
{
REBSER *context = VAL_WORD_FRAME(word);
if (context) {
REBINT index = VAL_WORD_INDEX(word);
if (index > 0) {
*out = *(FRM_VALUES(context) + index);
assert(!IS_TRASH(out));
assert(!THROWN(out));
return;
}
if (index < 0) {
struct Reb_Call *call = DSF;
while (call) {
if (
call->args_ready
&& context == VAL_FUNC_WORDS(DSF_FUNC(call))
) {
assert(!IS_CLOSURE(DSF_FUNC(call)));
*out = *DSF_ARG(call, -index);
assert(!IS_TRASH(out));
assert(!THROWN(out));
return;
}
call = PRIOR_DSF(call);
}
raise Error_1(RE_NO_RELATIVE, word);
}
// Key difference between Get_Var_Into and Get_Var...fabricating
// an object REBVAL.
// !!! Could fake function frames stow the function value itself
// so 'binding-of' can return it and use for binding (vs. TRUE)?
assert(!IS_SELFLESS(context));
Val_Init_Object(out, context);
return;
}
raise Error_1(RE_NOT_DEFINED, word);
}
pointer list_to_undef(pointer a) {
char *dispatch;
if (is_symbol(car(a))) {
dispatch=sym_name(car(a));
if (!strcmp(dispatch,"send-notes"))
return send_notes(cadr(a));
return Error_1("list>undef: unknown dispatch type:",car(a));
}
else
return Error_1("list>undef: no symbol:",car(a));
}
pointer list_to_int(pointer a) {
int res=0;
char *dispatch;
if (is_symbol(car(a))) {
dispatch=sym_name(car(a));
if (!strcmp(dispatch,"random"))
return random_int(cadr(a),caddr(a));
else
return Error_1("list>int: unknown dispatch type:",car(a));
}
else
return Error_1("list>int: no symbol:",car(a));
return mk_integer(res);
}
pointer list_to_list(pointer a) {
pointer res=nil_pointer();
char *dispatch;
if (is_symbol(car(a))) {
dispatch=sym_name(car(a));
if (!strcmp(dispatch,"get-selected-notes"))
res=seld_notes();
else
return Error_1("list>list: unknown dispatch type:",car(a));
}
else
return Error_1("list>list: no symbol:",car(a));
return res;
}
*/ ATTRIBUTE_NO_RETURN static void Error_Compression(const z_stream *strm, int ret)
/*
** Zlib gives back string error messages. We use them or fall
** back on the integer code if there is no message.
**
***********************************************************************/
{
REBVAL arg;
if (ret == Z_MEM_ERROR) {
// We do not technically know the amount of memory that zlib asked
// for and did not get. Hence categorizing it as an "out of memory"
// error might be less useful than leaving as a compression error,
// but that is what the old code here historically did.
raise Error_No_Memory(0);
}
if (strm->msg)
Val_Init_String(
&arg, Copy_Bytes(cb_cast(strm->msg), strlen(strm->msg))
);
else
SET_INTEGER(&arg, ret);
Error_1(RE_BAD_COMPRESSION, &arg);
}
*/ static void Loop_Series(REBVAL *out, REBVAL *var, REBSER* body, REBVAL *start, REBINT ei, REBINT ii)
/*
***********************************************************************/
{
REBINT si = VAL_INDEX(start);
REBCNT type = VAL_TYPE(start);
*var = *start;
if (ei >= cast(REBINT, VAL_TAIL(start)))
ei = cast(REBINT, VAL_TAIL(start));
if (ei < 0) ei = 0;
SET_NONE(out); // Default result to NONE if the loop does not run
for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
VAL_INDEX(var) = si;
if (Do_Block_Throws(out, body, 0)) {
if (Loop_Throw_Should_Return(out)) break;
}
if (VAL_TYPE(var) != type) raise Error_1(RE_INVALID_TYPE, var);
si = VAL_INDEX(var);
}
}
*/ void Bind_Stack_Word(REBSER *frame, REBVAL *word)
/*
***********************************************************************/
{
REBINT index;
index = Find_Arg_Index(frame, VAL_WORD_SYM(word));
if (!index) raise Error_1(RE_NOT_IN_CONTEXT, word);
VAL_WORD_FRAME(word) = frame;
VAL_WORD_INDEX(word) = -index;
}
*/ void Make_Module(REBVAL *out, const REBVAL *spec)
/*
** Create a module from a spec and an init block.
** Call the Make_Module function in the system/intrinsic object.
**
***********************************************************************/
{
if (Do_Sys_Func_Throws(out, SYS_CTX_MAKE_MODULE_P, spec, 0)) {
// Gave back an unhandled RETURN, BREAK, CONTINUE, etc...
raise Error_No_Catch_For_Throw(out);
}
// !!! Shouldn't this be testing for !IS_MODULE(out)?
if (IS_NONE(out)) raise Error_1(RE_INVALID_SPEC, spec);
}
*/ void Make_Port(REBVAL *out, const REBVAL *spec)
/*
** Create a new port. This is done by calling the MAKE_PORT
** function stored in the system/intrinsic object.
**
***********************************************************************/
{
if (Do_Sys_Func_Throws(out, SYS_CTX_MAKE_PORT_P, spec, 0)) {
// Gave back an unhandled RETURN, BREAK, CONTINUE, etc...
raise Error_No_Catch_For_Throw(out);
}
// !!! Shouldn't this be testing for !IS_PORT( ) ?
if (IS_NONE(out)) raise Error_1(RE_INVALID_SPEC, spec);
}
int main(int argc, char *argv[]) {
if(!strcmp(argv[1], "0")) {
Error_1();
} else if (!strcmp(argv[1], "1")){
Non_Error_2();
} else if (!strcmp(argv[1], "2")){
Error_3();
} else if(!strcmp(argv[1], "3")) {
Error_4();
} else if(!strcmp(argv[1], "4")) {
Error_5();
} else if(!strcmp(argv[1], "5")) {
Error_6();
}
return 0;
}
*/ static void Collect_Frame_Inner_Loop(REBINT *binds, REBVAL value[], REBCNT modes)
/*
** The inner recursive loop used for Collect_Frame function below.
**
***********************************************************************/
{
for (; NOT_END(value); value++) {
if (ANY_WORD(value)) {
if (!binds[VAL_WORD_CANON(value)]) { // only once per word
if (IS_SET_WORD(value) || modes & BIND_ALL) {
REBVAL *word;
binds[VAL_WORD_CANON(value)] = SERIES_TAIL(BUF_WORDS);
EXPAND_SERIES_TAIL(BUF_WORDS, 1);
word = BLK_LAST(BUF_WORDS);
Val_Init_Word_Typed(
word,
VAL_TYPE(value),
VAL_WORD_SYM(value),
// Allow all datatypes but END or UNSET (initially):
~((TYPESET(REB_END) | TYPESET(REB_UNSET)))
);
}
} else {
// If word duplicated:
if (modes & BIND_NO_DUP) {
// Reset binding table (note BUF_WORDS may have expanded):
REBVAL *word;
for (word = BLK_HEAD(BUF_WORDS); NOT_END(word); word++)
binds[VAL_WORD_CANON(word)] = 0;
RESET_TAIL(BUF_WORDS); // allow reuse
raise Error_1(RE_DUP_VARS, value);
}
}
continue;
}
// Recurse into sub-blocks:
if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
Collect_Frame_Inner_Loop(binds, VAL_BLK_DATA(value), modes);
// In this mode (foreach native), do not allow non-words:
//else if (modes & BIND_GET) raise Error_Invalid_Arg(value);
}
BLK_TERM(BUF_WORDS);
}
*/ static void Init_Dir_Path(REBREQ *dir, REBVAL *path, REBINT wild, REBCNT policy)
/*
** Convert REBOL dir path to file system path.
** On Windows, we will also need to append a * if necessary.
**
** ARGS:
** Wild:
** 0 - no wild cards, path must end in / else error
** 1 - accept wild cards * and ?, and * if need
** -1 - not wild, if path does not end in /, add it
**
***********************************************************************/
{
REBINT len;
REBSER *ser;
//REBYTE *flags;
SET_FLAG(dir->modes, RFM_DIR);
// We depend on To_Local_Path giving us 2 extra chars for / and *
ser = Value_To_OS_Path(path, TRUE);
len = ser->tail;
dir->special.file.path = cast(REBCHR*, ser->data);
Secure_Port(SYM_FILE, dir, path, ser);
if (len == 1 && OS_CH_EQUAL(dir->special.file.path[0], '.')) {
if (wild > 0) {
dir->special.file.path[0] = OS_MAKE_CH('*');
dir->special.file.path[1] = OS_MAKE_CH('\0');
}
}
else if (
len == 2
&& OS_CH_EQUAL(dir->special.file.path[0], '.')
&& OS_CH_EQUAL(dir->special.file.path[1], '.')
) {
// Insert * if needed:
if (wild > 0) {
dir->special.file.path[len++] = OS_MAKE_CH('/');
dir->special.file.path[len++] = OS_MAKE_CH('*');
dir->special.file.path[len] = OS_MAKE_CH('\0');
}
}
else if (
OS_CH_EQUAL(dir->special.file.path[len-1], '/')
|| OS_CH_EQUAL(dir->special.file.path[len-1], '\\')
) {
if (policy & REMOVE_TAIL_SLASH) {
dir->special.file.path[len-1] = OS_MAKE_CH('\0');
}
else {
// Insert * if needed:
if (wild > 0) {
dir->special.file.path[len++] = OS_MAKE_CH('*');
dir->special.file.path[len] = OS_MAKE_CH('\0');
}
}
} else {
// Path did not end with /, so we better be wild:
if (wild == 0) {
// !!! Comment said `OS_FREE(dir->special.file.path);` (needed?)
raise Error_1(RE_BAD_FILE_PATH, path);
}
else if (wild < 0) {
dir->special.file.path[len++] = OS_MAKE_CH(OS_DIR_SEP);
dir->special.file.path[len] = OS_MAKE_CH('\0');
}
}
}
*/ REBFLG MT_Struct(REBVAL *out, REBVAL *data, enum Reb_Kind type)
/*
* Format:
* make struct! [
* field1 [type1]
* field2: [type2] field2-init-value
* field3: [struct [field1 [type1]]]
* field4: [type1[3]]
* ...
* ]
***********************************************************************/
{
//RL_Print("%s\n", __func__);
REBINT max_fields = 16;
VAL_STRUCT_FIELDS(out) = Make_Series(
max_fields, sizeof(struct Struct_Field), MKS_NONE
);
MANAGE_SERIES(VAL_STRUCT_FIELDS(out));
if (IS_BLOCK(data)) {
//if (Reduce_Block_No_Set_Throws(VAL_SERIES(data), 0, NULL))...
//data = DS_POP;
REBVAL *blk = VAL_BLK_DATA(data);
REBINT field_idx = 0; /* for field index */
u64 offset = 0; /* offset in data */
REBCNT eval_idx = 0; /* for spec block evaluation */
REBVAL *init = NULL; /* for result to save in data */
REBOOL expect_init = FALSE;
REBINT raw_size = -1;
REBUPT raw_addr = 0;
REBCNT alignment = 0;
VAL_STRUCT_SPEC(out) = Copy_Array_Shallow(VAL_SERIES(data));
VAL_STRUCT_DATA(out) = Make_Series(
1, sizeof(struct Struct_Data), MKS_NONE
);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA(out), 1);
VAL_STRUCT_DATA_BIN(out) = Make_Series(max_fields << 2, 1, MKS_NONE);
VAL_STRUCT_OFFSET(out) = 0;
// We tell the GC to manage this series, but it will not cause a
// synchronous garbage collect. Still, when's the right time?
ENSURE_SERIES_MANAGED(VAL_STRUCT_SPEC(out));
MANAGE_SERIES(VAL_STRUCT_DATA(out));
MANAGE_SERIES(VAL_STRUCT_DATA_BIN(out));
/* set type early such that GC will handle it correctly, i.e, not collect series in the struct */
SET_TYPE(out, REB_STRUCT);
if (IS_BLOCK(blk)) {
parse_attr(blk, &raw_size, &raw_addr);
++ blk;
}
while (NOT_END(blk)) {
REBVAL *inner;
struct Struct_Field *field = NULL;
u64 step = 0;
EXPAND_SERIES_TAIL(VAL_STRUCT_FIELDS(out), 1);
DS_PUSH_NONE;
inner = DS_TOP; /* save in stack so that it won't be GC'ed when MT_Struct is recursively called */
field = (struct Struct_Field *)SERIES_SKIP(VAL_STRUCT_FIELDS(out), field_idx);
field->offset = (REBCNT)offset;
if (IS_SET_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = TRUE;
if (raw_addr) {
/* initialization is not allowed for raw memory struct */
raise Error_Invalid_Arg(blk);
}
} else if (IS_WORD(blk)) {
field->sym = VAL_WORD_SYM(blk);
expect_init = FALSE;
}
else
raise Error_Has_Bad_Type(blk);
++ blk;
if (!IS_BLOCK(blk))
raise Error_Invalid_Arg(blk);
if (!parse_field_type(field, blk, inner, &init)) { return FALSE; }
++ blk;
STATIC_assert(sizeof(field->size) <= 4);
STATIC_assert(sizeof(field->dimension) <= 4);
step = (u64)field->size * (u64)field->dimension;
if (step > VAL_STRUCT_LIMIT)
raise Error_1(RE_SIZE_LIMIT, out);
EXPAND_SERIES_TAIL(VAL_STRUCT_DATA_BIN(out), step);
if (expect_init) {
REBVAL safe; // result of reduce or do (GC saved during eval)
init = &safe;
if (IS_BLOCK(blk)) {
if (Reduce_Block_Throws(init, VAL_SERIES(blk), 0, FALSE))
raise Error_No_Catch_For_Throw(init);
++ blk;
} else {
DO_NEXT_MAY_THROW(
eval_idx,
init,
VAL_SERIES(data),
blk - VAL_BLK_DATA(data)
);
if (eval_idx == THROWN_FLAG)
raise Error_No_Catch_For_Throw(init);
blk = VAL_BLK_SKIP(data, eval_idx);
}
if (field->array) {
if (IS_INTEGER(init)) { /* interpreted as a C pointer */
void *ptr = cast(void *, cast(REBUPT, VAL_INT64(init)));
/* assuming it's an valid pointer and holding enough space */
memcpy(SERIES_SKIP(VAL_STRUCT_DATA_BIN(out), (REBCNT)offset), ptr, field->size * field->dimension);
} else if (IS_BLOCK(init)) {
REBCNT n = 0;
if (VAL_LEN(init) != field->dimension)
raise Error_Invalid_Arg(init);
/* assign */
for (n = 0; n < field->dimension; n ++) {
if (!assign_scalar(&VAL_STRUCT(out), field, n, VAL_BLK_SKIP(init, n))) {
//RL_Print("Failed to assign element value\n");
goto failed;
}
}
}
else
raise Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(blk));
} else {
/* scalar */
if (!assign_scalar(&VAL_STRUCT(out), field, 0, init)) {
//RL_Print("Failed to assign scalar value\n");
goto failed;
}
}
} else if (raw_addr == 0) {
/* parse struct attribute */
static void parse_attr (REBVAL *blk, REBINT *raw_size, REBUPT *raw_addr)
{
REBVAL *attr = VAL_BLK_DATA(blk);
*raw_size = -1;
*raw_addr = 0;
while (NOT_END(attr)) {
if (IS_SET_WORD(attr)) {
switch (VAL_WORD_CANON(attr)) {
case SYM_RAW_SIZE:
++ attr;
if (IS_INTEGER(attr)) {
if (*raw_size > 0) /* duplicate raw-size */
raise Error_Invalid_Arg(attr);
*raw_size = VAL_INT64(attr);
if (*raw_size <= 0)
raise Error_Invalid_Arg(attr);
}
else
raise Error_Invalid_Arg(attr);
break;
case SYM_RAW_MEMORY:
++ attr;
if (IS_INTEGER(attr)) {
if (*raw_addr != 0) /* duplicate raw-memory */
raise Error_Invalid_Arg(attr);
*raw_addr = VAL_UNT64(attr);
if (*raw_addr == 0)
raise Error_Invalid_Arg(attr);
}
else
raise Error_Invalid_Arg(attr);
break;
case SYM_EXTERN:
++ attr;
if (*raw_addr != 0) /* raw-memory is exclusive with extern */
raise Error_Invalid_Arg(attr);
if (!IS_BLOCK(attr)
|| VAL_LEN(attr) != 2) {
raise Error_Invalid_Arg(attr);
}
else {
REBVAL *lib;
REBVAL *sym;
CFUNC *addr;
lib = VAL_BLK_SKIP(attr, 0);
sym = VAL_BLK_SKIP(attr, 1);
if (!IS_LIBRARY(lib))
raise Error_Invalid_Arg(attr);
if (IS_CLOSED_LIB(VAL_LIB_HANDLE(lib)))
raise Error_0(RE_BAD_LIBRARY);
if (!ANY_BINSTR(sym))
raise Error_Invalid_Arg(sym);
addr = OS_FIND_FUNCTION(
LIB_FD(VAL_LIB_HANDLE(lib)), s_cast(VAL_DATA(sym))
);
if (!addr)
raise Error_1(RE_SYMBOL_NOT_FOUND, sym);
*raw_addr = cast(REBUPT, addr);
}
break;
/*
case SYM_ALIGNMENT:
++ attr;
if (IS_INTEGER(attr)) {
alignment = VAL_INT64(attr);
} else {
raise Error_Invalid_Arg(attr);
}
break;
*/
default:
raise Error_Invalid_Arg(attr);
}
}
else
raise Error_Invalid_Arg(attr);
++ attr;
}
}
*/ int Do_Port_Action(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Call a PORT actor (action) value. Search PORT actor
** first. If not found, search the PORT scheme actor.
**
** NOTE: stack must already be setup correctly for action, and
** the caller must cleanup the stack.
**
***********************************************************************/
{
REBVAL *actor;
REBCNT n = 0;
assert(action < A_MAX_ACTION);
// Verify valid port (all of these must be false):
if (
// Must be = or larger than std port:
(SERIES_TAIL(port) < STD_PORT_MAX) ||
// Must be an object series:
!IS_FRAME(BLK_HEAD(port)) ||
// Must have a spec object:
!IS_OBJECT(BLK_SKIP(port, STD_PORT_SPEC))
) {
raise Error_0(RE_INVALID_PORT);
}
// Get actor for port, if it has one:
actor = BLK_SKIP(port, STD_PORT_ACTOR);
if (IS_NONE(actor)) return R_NONE;
// If actor is a native function:
if (IS_NATIVE(actor))
return cast(REBPAF, VAL_FUNC_CODE(actor))(call_, port, action);
// actor must be an object:
if (!IS_OBJECT(actor)) raise Error_0(RE_INVALID_ACTOR);
// Dispatch object function:
n = Find_Action(actor, action);
actor = Obj_Value(actor, n);
if (!n || !actor || !ANY_FUNC(actor))
raise Error_1(RE_NO_PORT_ACTION, Get_Action_Word(action));
if (Redo_Func_Throws(actor)) {
// No special handling needed, as we are just going to return
// the output value in D_OUT anyway.
}
return R_OUT;
// If not in PORT actor, use the SCHEME actor:
#ifdef no_longer_used
if (n == 0) {
actor = Obj_Value(scheme, STD_SCHEME_actor);
if (!actor) goto err;
if (IS_NATIVE(actor)) goto fun;
if (!IS_OBJECT(actor)) goto err; //vTrap_Expect(value, STD_PORT_actor, REB_OBJECT);
n = Find_Action(actor, action);
if (n == 0) goto err;
}
#endif
}
*/ static REB_R Dir_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Internal port handler for file directories.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBVAL *state;
REBREQ dir;
REBCNT args = 0;
REBINT result;
REBCNT len;
//REBYTE *flags;
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
CLEARS(&dir);
// Validate and fetch relevant PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) raise Error_1(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) raise Error_1(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) raise Error_1(RE_INVALID_SPEC, path);
state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
//flags = Security_Policy(SYM_FILE, path);
// Get or setup internal state data:
dir.port = port;
dir.device = RDI_FILE;
switch (action) {
case A_READ:
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(call_, ALL_READ_REFS);
if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
Init_Dir_Path(&dir, path, 1, POL_READ);
Val_Init_Block(state, Make_Array(7)); // initial guess
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0)
raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
*D_OUT = *state;
SET_NONE(state);
}
else {
// !!! This copies the strings in the block, shallowly. What is
// the purpose of doing this? Why copy at all?
Val_Init_Block(
D_OUT,
Copy_Array_Core_Managed(
VAL_SERIES(state),
0,
VAL_BLK_LEN(state),
FALSE, // !deep
TS_STRING
)
);
}
break;
case A_CREATE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
create:
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
result = OS_DO_DEVICE(&dir, RDC_CREATE);
///OS_FREE(dir.file.path);
if (result < 0) raise Error_1(RE_NO_CREATE, path);
if (action == A_CREATE) {
// !!! Used to return R_ARG2, but create is single arity. :-/
return R_ARG1;
}
SET_NONE(state);
break;
case A_RENAME:
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
else {
REBSER *target;
Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
raise Error_1(RE_BAD_FILE_PATH, D_ARG(2));
dir.common.data = BIN_DATA(target);
OS_DO_DEVICE(&dir, RDC_RENAME);
Free_Series(target);
if (dir.error) raise Error_1(RE_NO_RENAME, path);
}
break;
case A_DELETE:
//Trap_Security(flags[POL_WRITE], POL_WRITE, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, 0, POL_WRITE);
// !!! add *.r deletion
// !!! add recursive delete (?)
result = OS_DO_DEVICE(&dir, RDC_DELETE);
///OS_FREE(dir.file.path);
if (result < 0) raise Error_1(RE_NO_DELETE, path);
// !!! Returned R_ARG2 before, but there is no second argument :-/
return R_ARG1;
case A_OPEN:
// !! If open fails, what if user does a READ w/o checking for error?
if (IS_BLOCK(state)) raise Error_1(RE_ALREADY_OPEN, path);
//Trap_Security(flags[POL_READ], POL_READ, path);
args = Find_Refines(call_, ALL_OPEN_REFS);
if (args & AM_OPEN_NEW) goto create;
//if (args & ~AM_OPEN_READ) raise Error_1(RE_INVALID_SPEC, path);
Val_Init_Block(state, Make_Array(7));
Init_Dir_Path(&dir, path, 1, POL_READ);
result = Read_Dir(&dir, VAL_SERIES(state));
///OS_FREE(dir.file.path);
if (result < 0) raise Error_On_Port(RE_CANNOT_OPEN, port, dir.error);
break;
case A_OPENQ:
if (IS_BLOCK(state)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
SET_NONE(state);
break;
case A_QUERY:
//Trap_Security(flags[POL_READ], POL_READ, path);
SET_NONE(state);
Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
Ret_Query_File(port, &dir, D_OUT);
///OS_FREE(dir.file.path);
break;
//-- Port Series Actions (only called if opened as a port)
case A_LENGTH:
len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
SET_INTEGER(D_OUT, len);
break;
default:
raise Error_Illegal_Action(REB_PORT, action);
}
return R_OUT;
}
*/ REBVAL *Get_Var_Core(const REBVAL *word, REBOOL trap, REBOOL writable)
/*
** Get the word--variable--value. (Generally, use the macros like
** GET_VAR or GET_MUTABLE_VAR instead of this). This routine is
** called quite a lot and so attention to performance is important.
**
** Coded assuming most common case is trap=TRUE and writable=FALSE
**
***********************************************************************/
{
REBSER *context = VAL_WORD_FRAME(word);
if (context) {
REBINT index = VAL_WORD_INDEX(word);
// POSITIVE INDEX: The word is bound directly to a value inside
// a frame, and represents the zero-based offset into that series.
// This is how values would be picked out of object-like things...
// (Including looking up 'append' in the user context.)
if (index > 0) {
REBVAL *value;
if (
writable &&
VAL_GET_EXT(FRM_WORDS(context) + index, EXT_WORD_LOCK)
) {
if (trap) raise Error_1(RE_LOCKED_WORD, word);
return NULL;
}
value = FRM_VALUES(context) + index;
assert(!THROWN(value));
return value;
}
// NEGATIVE INDEX: Word is stack-relative bound to a function with
// no persistent frame held by the GC. The value *might* be found
// on the stack (or not, if all instances of the function on the
// call stack have finished executing). We walk backward in the call
// stack to see if we can find the function's "identifying series"
// in a call frame...and take the first instance we see (even if
// multiple invocations are on the stack, most recent wins)
if (index < 0) {
struct Reb_Call *call = DSF;
// Get_Var could theoretically be called with no evaluation on
// the stack, so check for no DSF first...
while (call) {
if (
call->args_ready
&& context == VAL_FUNC_WORDS(DSF_FUNC(call))
) {
REBVAL *value;
assert(!IS_CLOSURE(DSF_FUNC(call)));
if (
writable &&
VAL_GET_EXT(
VAL_FUNC_PARAM(DSF_FUNC(call), -index),
EXT_WORD_LOCK
)
) {
if (trap) raise Error_1(RE_LOCKED_WORD, word);
return NULL;
}
value = DSF_ARG(call, -index);
assert(!THROWN(value));
return value;
}
call = PRIOR_DSF(call);
}
if (trap) raise Error_1(RE_NO_RELATIVE, word);
return NULL;
}
// ZERO INDEX: The word is SELF. Although the information needed
// to produce an OBJECT!-style REBVAL lives in the zero offset
// of the frame, it's not a value that we can return a direct
// pointer to. Use GET_VAR_INTO instead for that.
assert(!IS_SELFLESS(context));
if (trap) raise Error_0(RE_SELF_PROTECTED);
return NULL; // is this a case where we should *always* trap?
}
if (trap) raise Error_1(RE_NOT_DEFINED, word);
return NULL;
}
