*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def) /* ***********************************************************************/ { REBVAL *spec; REBVAL *body; REBCNT len; if ( !IS_BLOCK(def) || (len = VAL_LEN(def)) < 2 || !IS_BLOCK(spec = VAL_BLK(def)) ) return FALSE; body = VAL_BLK_SKIP(def, 1); VAL_FUNC_SPEC(value) = VAL_SERIES(spec); VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec)); if (type != REB_COMMAND) { if (len != 2 || !IS_BLOCK(body)) return FALSE; VAL_FUNC_BODY(value) = VAL_SERIES(body); } else Make_Command(value, def); VAL_SET(value, type); if (type == REB_FUNCTION || type == REB_CLOSURE) Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value)); return TRUE; }
*/ REBINT PD_Block(REBPVS *pvs) /* ***********************************************************************/ { REBINT n = 0; /* Issues!!! a/1.3 a/not-found: 10 error or append? a/not-followed: 10 error or append? */ if (IS_INTEGER(pvs->select)) { n = Int32(pvs->select) + VAL_INDEX(pvs->value) - 1; } else if (IS_WORD(pvs->select)) { n = Find_Word(VAL_SERIES(pvs->value), VAL_INDEX(pvs->value), VAL_WORD_CANON(pvs->select)); if (n != NOT_FOUND) n++; } else { // other values: n = Find_Block_Simple(VAL_SERIES(pvs->value), VAL_INDEX(pvs->value), pvs->select) + 1; } if (n < 0 || (REBCNT)n >= VAL_TAIL(pvs->value)) { if (pvs->setval) return PE_BAD_SELECT; return PE_NONE; } if (pvs->setval) TRAP_PROTECT(VAL_SERIES(pvs->value)); pvs->value = VAL_BLK_SKIP(pvs->value, n); // if valset - check PROTECT on block //if (NOT_END(pvs->path+1)) Next_Path(pvs); return PE_OK; return PE_SET; }
*/ REBFLG Copy_Function(REBVAL *value, REBVAL *args) /* ***********************************************************************/ { REBVAL *spec = VAL_BLK(args); REBVAL *body = VAL_BLK_SKIP(args, 1); if (IS_END(spec)) body = 0; else { // Spec given, must be block or * if (IS_BLOCK(spec)) { VAL_FUNC_SPEC(value) = VAL_SERIES(spec); VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec)); } else if (!IS_STAR(spec)) return FALSE; } if (body && !IS_END(body)) { if (!IS_FUNCTION(value) && !IS_CLOSURE(value)) return FALSE; // Body must be block: if (!IS_BLOCK(body)) return FALSE; VAL_FUNC_BODY(value) = VAL_SERIES(body); } // No body, use protytpe: else if (IS_FUNCTION(value) || IS_CLOSURE(value)) VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(value)); // Rebind function words: if (IS_FUNCTION(value)) Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value)); return TRUE; }
*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def) /* ***********************************************************************/ { REBVAL *spec; REBVAL *body; REBCNT len; if ( !IS_BLOCK(def) //// || type < REB_CLOSURE // for now || (len = VAL_LEN(def)) < 2 || !IS_BLOCK(spec = VAL_BLK(def)) ) return FALSE; body = VAL_BLK_SKIP(def, 1); // Print("Make_Func"); //: %s spec %d", Get_Sym_Name(type+1), SERIES_TAIL(spec)); VAL_FUNC_SPEC(value) = VAL_SERIES(spec); VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec)); if (type != REB_COMMAND) { if (len != 2 || !IS_BLOCK(body)) return FALSE; VAL_FUNC_BODY(value) = VAL_SERIES(body); } else Make_Command(value, def); VAL_SET(value, type); if (type == REB_FUNCTION) Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value), VAL_FUNC_BODY(value)); return TRUE; }
*/ REBVAL *Append_Event() /* ** Append an event to the end of the current event port queue. ** Return a pointer to the event value. ** ** Note: this function may be called from out of environment, ** so do NOT extend the event queue here. If it does not have ** space, return 0. (Should it overwrite or wrap???) ** ***********************************************************************/ { REBVAL *port; REBVAL *value; REBVAL *state; port = Get_System(SYS_PORTS, PORTS_SYSTEM); if (!IS_PORT(port)) return 0; // verify it is a port object // Get queue block: state = VAL_BLK_SKIP(port, STD_PORT_STATE); if (!IS_BLOCK(state)) return 0; // Append to tail if room: if (SERIES_FULL(VAL_SERIES(state))) Crash(RP_MAX_EVENTS); VAL_TAIL(state)++; value = VAL_BLK_TAIL(state); SET_END(value); value--; SET_NONE(value); //Dump_Series(VAL_SERIES(state), "state"); //Print("Tail: %d %d", VAL_TAIL(state), nn++); return value; }
*/ REBVAL *Pick_Block(REBVAL *block, REBVAL *selector) /* ***********************************************************************/ { REBINT n = 0; n = Get_Num_Arg(selector); n += VAL_INDEX(block) - 1; if (n < 0 || (REBCNT)n >= VAL_TAIL(block)) return 0; return VAL_BLK_SKIP(block, n); }
*/ void Make_Command(REBVAL *value, REBVAL *def) /* ** Assumes prior function has already stored the spec and args ** series. This function validates the body. ** ***********************************************************************/ { REBVAL *args = BLK_HEAD(VAL_FUNC_ARGS(value)); REBCNT n; REBVAL *val = VAL_BLK_SKIP(def, 1); REBEXT *ext; if ( VAL_LEN(def) != 3 || !(IS_MODULE(val) || IS_OBJECT(val)) || !IS_HANDLE(VAL_OBJ_VALUE(val, 1)) || !IS_INTEGER(val+1) || VAL_INT64(val+1) > 0xffff ) Trap1(RE_BAD_FUNC_DEF, def); val = VAL_OBJ_VALUE(val, 1); if ( !(ext = &Ext_List[VAL_I32(val)]) || !(ext->call) ) Trap1(RE_BAD_EXTENSION, def); // make command! [[arg-spec] handle cmd-index] VAL_FUNC_BODY(value) = Copy_Block_Len(VAL_SERIES(def), 1, 2); // Check for valid command arg datatypes: args++; // skip self n = 1; for (; NOT_END(args); args++, n++) { // If the typeset contains args that are not valid: // (3 is the default when no args given, for not END and UNSET) if (3 != ~VAL_TYPESET(args) && (VAL_TYPESET(args) & ~RXT_ALLOWED_TYPES)) Trap1(RE_BAD_FUNC_ARG, args); } VAL_SET(value, REB_COMMAND); }
// // PD_Map: C // REBINT PD_Map(REBPVS *pvs) { REBVAL *data = pvs->value; REBVAL *val = 0; REBINT n = 0; if (IS_END(pvs->path+1)) val = pvs->setval; if (IS_NONE(pvs->select)) return PE_NONE; if (!ANY_WORD(pvs->select) && !ANY_BINSTR(pvs->select) && !IS_INTEGER(pvs->select) && !IS_CHAR(pvs->select)) return PE_BAD_SELECT; n = Find_Entry(VAL_SERIES(data), pvs->select, val); if (!n) return PE_NONE; TRAP_PROTECT(VAL_SERIES(data)); pvs->value = VAL_BLK_SKIP(data, ((n-1)*2)+1); return PE_OK; }
*/ static REBFLG Set_Struct_Var(REBSTU *stu, REBVAL *word, REBVAL *elem, REBVAL *val) /* ***********************************************************************/ { struct Struct_Field *field = NULL; REBCNT i = 0; field = (struct Struct_Field *)SERIES_DATA(stu->fields); for (i = 0; i < SERIES_TAIL(stu->fields); i ++, field ++) { if (VAL_WORD_CANON(word) == VAL_SYM_CANON(BLK_SKIP(PG_Word_Table.series, field->sym))) { if (field->array) { if (elem == NULL) { //set the whole array REBCNT n = 0; if ((!IS_BLOCK(val) || field->dimension != VAL_LEN(val))) { return FALSE; } for(n = 0; n < field->dimension; n ++) { if (!assign_scalar(stu, field, n, VAL_BLK_SKIP(val, n))) { return FALSE; } } } else {// set only one element if (!IS_INTEGER(elem) || VAL_INT32(elem) <= 0 || VAL_INT32(elem) > cast(REBINT, field->dimension)) { return FALSE; } return assign_scalar(stu, field, VAL_INT32(elem) - 1, val); } return TRUE; } else { return assign_scalar(stu, field, 0, val); } return TRUE; } } return FALSE; }
*/ REBINT Find_Typeset(REBVAL *block) /* ***********************************************************************/ { REBVAL value; REBVAL *val; REBINT n; VAL_SET(&value, REB_TYPESET); Make_Typeset(block, &value, 0); val = VAL_BLK_SKIP(ROOT_TYPESETS, 1); for (n = 1; NOT_END(val); val++, n++) { if (EQUAL_TYPESET(&value, val)){ //Print("FTS: %d", n); return n; } } // Print("Size Typesets: %d", VAL_TAIL(ROOT_TYPESETS)); Append_Value(VAL_SERIES(ROOT_TYPESETS), &value); return n; }
*/ 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; } }