void do_gpu_sha(){
int i;
uint32_t digest[8*STRIDE];
uint32_t block[20*STRIDE] = {0};
block[(72/4)*STRIDE] = 0x9FEF014;
block[(76/4)*STRIDE] = 0x2a400100;
sha256cl_context ctx;
sha256_init(0,&ctx);
sha256_starts(0,&ctx);
sha256_update(0,&ctx,block,80);
sha256_finish(0,&ctx,digest);
for(i=0; i < 8; i++)
printf("%8.8X",D_REF(digest,7-i,0));
printf("\n");
sha256_starts(0,&ctx);
sha256_update(0,&ctx,digest,32);
sha256_finish(0,&ctx,digest);
for(i=0; i < 8; i++)
printf("%8.8X",D_REF(digest,7-i,0));
printf("\n");
}
/***********************************************************************
**
** Get_Obj_Mods -- return a block of modified words from an object
**
***********************************************************************/
REBVAL *Get_Obj_Mods(REBFRM *frame, REBVAL **inter_block)
{
REBVAL *obj = D_ARG(1);
REBVAL *words, *val;
REBFRM *frm = VAL_OBJ_FRAME(obj);
REBSER *ser = Make_Block(2);
REBOOL clear = D_REF(2);
//DISABLE_GC;
val = BLK_HEAD(frm->values);
words = BLK_HEAD(frm->words);
for (; NOT_END(val); val++, words++)
if (!(VAL_FLAGS(val) & FLAGS_CLEAN)) {
Append_Val(ser, words);
if (clear) VAL_FLAGS(val) |= FLAGS_CLEAN;
}
if (!STR_LEN(ser)) {
ENABLE_GC;
goto is_none;
}
Bind_Block(frm, BLK_HEAD(ser), FALSE);
VAL_SERIES(Temp_Blk_Value) = ser;
//ENABLE_GC;
return Temp_Blk_Value;
}
*/ REBCNT Get_Round_Flags(REBVAL *ds)
/*
** 1 n [number! money! time!] "The value to round"
** 2 /to "Return the nearest multiple of the scale parameter"
** 3 scale [number! money! time!] "Must be a non-zero value"
** 4 /even "Halves round toward even results"
** 5 /down "Round toward zero, ignoring discarded digits. (truncate)"
** 6 /half-down "Halves round toward zero"
** 7 /floor "Round in negative direction"
** 8 /ceiling "Round in positive direction"
** 9 /half-ceiling "Halves round in positive direction"
**
***********************************************************************/
{
REBCNT flags = 0;
if (D_REF(2)) SET_FLAG(flags, RF_TO);
if (D_REF(4)) SET_FLAG(flags, RF_EVEN);
if (D_REF(5)) SET_FLAG(flags, RF_DOWN);
if (D_REF(6)) SET_FLAG(flags, RF_HALF_DOWN);
if (D_REF(7)) SET_FLAG(flags, RF_FLOOR);
if (D_REF(8)) SET_FLAG(flags, RF_CEILING);
if (D_REF(9)) SET_FLAG(flags, RF_HALF_CEILING);
return flags;
}
//
// Find_Refines: C
//
// Scans the stack for function refinements that have been
// specified in the mask (each as a bit) and are being used.
//
REBCNT Find_Refines(struct Reb_Frame *frame_, REBCNT mask)
{
REBINT n;
REBCNT result = 0;
REBINT max = D_ARGC;
for (n = 0; n < max; n++) {
if ((mask & (1 << n) && D_REF(n + 1)))
result |= 1 << n;
}
return result;
}
*/ REBCNT Find_Refines(REBVAL *ds, REBCNT mask)
/*
** Scans the stack for function refinements that have been
** specified in the mask (each as a bit) and are being used.
**
***********************************************************************/
{
REBINT n;
REBCNT result = 0;
REBINT len = DS_ARGC;
for (n = 0; n < len; n++) {
if ((mask & (1 << n) && D_REF(n+1)))
result |= 1 << n;
}
return result;
}
//
// "Returns the union of two data sets."
//
// set1 [any-array! any-string! binary! bitset! typeset!] "first set"
// set2 [any-array! any-string! binary! bitset! typeset!] "second set"
// /case "Use case-sensitive comparison"
// /skip "Treat the series as records of fixed size"
// size [integer!]
// ]
//
REBNATIVE(union)
{
REBVAL *val1 = D_ARG(1);
REBVAL *val2 = D_ARG(2);
const REBOOL cased = D_REF(3);
const REBOOL skip = D_REF(4) ? Int32s(D_ARG(5), 1) : 1;
if (IS_BITSET(val1) || IS_BITSET(val2)) {
if (VAL_TYPE(val1) != VAL_TYPE(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
Val_Init_Bitset(D_OUT, Xandor_Binary(A_OR, val1, val2));
return R_OUT;
}
if (IS_TYPESET(val1) || IS_TYPESET(val2)) {
if (VAL_TYPE(val1) != VAL_TYPE(val2))
fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
*D_OUT = *val1;
*/ static REBINT Do_Set_Operation(struct Reb_Call *call_, REBCNT flags)
/*
** Do set operations on a series.
**
***********************************************************************/
{
REBVAL *val;
REBVAL *val1;
REBVAL *val2 = 0;
REBSER *ser;
REBSER *hser = 0; // hash table for series
REBSER *retser; // return series
REBSER *hret; // hash table for return series
REBCNT i;
REBINT h = TRUE;
REBCNT skip = 1; // record size
REBCNT cased = 0; // case sensitive when TRUE
SET_NONE(D_OUT);
val1 = D_ARG(1);
i = 2;
// Check for second series argument:
if (flags != SET_OP_UNIQUE) {
val2 = D_ARG(i++);
if (VAL_TYPE(val1) != VAL_TYPE(val2))
raise Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2));
}
// Refinements /case and /skip N
cased = D_REF(i++); // cased
if (D_REF(i++)) skip = Int32s(D_ARG(i), 1);
switch (VAL_TYPE(val1)) {
case REB_BLOCK:
i = VAL_LEN(val1);
// Setup result block:
if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
retser = BUF_EMIT; // use preallocated shared block
Resize_Series(retser, i);
hret = Make_Hash_Sequence(i); // allocated
// Optimization note: !!
// This code could be optimized for small blocks by not hashing them
// and extending Find_Key to do a FIND on the value itself w/o the hash.
do {
// Check what is in series1 but not in series2:
if (GET_FLAG(flags, SOP_CHECK))
hser = Hash_Block(val2, cased);
// Iterate over first series:
ser = VAL_SERIES(val1);
i = VAL_INDEX(val1);
for (; val = BLK_SKIP(ser, i), i < SERIES_TAIL(ser); i += skip) {
if (GET_FLAG(flags, SOP_CHECK)) {
h = Find_Key(VAL_SERIES(val2), hser, val, skip, cased, 1) >= 0;
if (GET_FLAG(flags, SOP_INVERT)) h = !h;
}
if (h) Find_Key(retser, hret, val, skip, cased, 2);
}
// Iterate over second series?
if ((i = GET_FLAG(flags, SOP_BOTH))) {
val = val1;
val1 = val2;
val2 = val;
CLR_FLAG(flags, SOP_BOTH);
}
if (GET_FLAG(flags, SOP_CHECK))
Free_Series(hser);
} while (i);
if (hret)
Free_Series(hret);
Val_Init_Block(D_OUT, Copy_Array_Shallow(retser));
RESET_TAIL(retser); // required - allow reuse
break;
case REB_BINARY:
cased = TRUE;
SET_TYPE(D_OUT, REB_BINARY);
case REB_STRING:
i = VAL_LEN(val1);
// Setup result block:
if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
retser = BUF_MOLD;
Reset_Buffer(retser, i);
RESET_TAIL(retser);
do {
REBUNI uc;
cased = cased ? AM_FIND_CASE : 0;
// Iterate over first series:
ser = VAL_SERIES(val1);
i = VAL_INDEX(val1);
for (; i < SERIES_TAIL(ser); i += skip) {
uc = GET_ANY_CHAR(ser, i);
if (GET_FLAG(flags, SOP_CHECK)) {
h = Find_Str_Char(VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_TAIL(val2), skip, uc, cased) != NOT_FOUND;
if (GET_FLAG(flags, SOP_INVERT)) h = !h;
}
if (h && (Find_Str_Char(retser, 0, 0, SERIES_TAIL(retser), skip, uc, cased) == NOT_FOUND)) {
Append_String(retser, ser, i, skip);
}
}
// Iterate over second series?
if ((i = GET_FLAG(flags, SOP_BOTH))) {
val = val1;
val1 = val2;
val2 = val;
CLR_FLAG(flags, SOP_BOTH);
}
} while (i);
ser = Copy_String(retser, 0, -1);
if (IS_BINARY(D_OUT))
Val_Init_Binary(D_OUT, ser);
else
Val_Init_String(D_OUT, ser);
break;
case REB_BITSET:
switch (flags) {
case SET_OP_UNIQUE:
return R_ARG1;
case SET_OP_UNION:
i = A_OR;
break;
case SET_OP_INTERSECT:
i = A_AND;
break;
case SET_OP_DIFFERENCE:
i = A_XOR;
break;
case SET_OP_EXCLUDE:
i = 0; // special case
break;
}
ser = Xandor_Binary(i, val1, val2);
Val_Init_Bitset(D_OUT, ser);
break;
case REB_TYPESET:
switch (flags) {
case SET_OP_UNIQUE:
break;
case SET_OP_UNION:
VAL_TYPESET(val1) |= VAL_TYPESET(val2);
break;
case SET_OP_INTERSECT:
VAL_TYPESET(val1) &= VAL_TYPESET(val2);
break;
case SET_OP_DIFFERENCE:
VAL_TYPESET(val1) ^= VAL_TYPESET(val2);
break;
case SET_OP_EXCLUDE:
VAL_TYPESET(val1) &= ~VAL_TYPESET(val2);
break;
}
return R_ARG1;
default:
raise Error_Invalid_Arg(val1);
}
return R_OUT;
}
*/ static REB_R File_Actor(struct Reb_Call *call_, REBSER *port, REBCNT action)
/*
** Internal port handler for files.
**
***********************************************************************/
{
REBVAL *spec;
REBVAL *path;
REBREQ *file = 0;
REBCNT args = 0;
REBCNT len;
REBOOL opened = FALSE; // had to be opened (shortcut case)
//Print("FILE ACTION: %r", Get_Action_Word(action));
Validate_Port(port, action);
*D_OUT = *D_ARG(1);
// Validate PORT fields:
spec = BLK_SKIP(port, STD_PORT_SPEC);
if (!IS_OBJECT(spec)) Trap1_DEAD_END(RE_INVALID_SPEC, spec);
path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
if (!path) Trap1_DEAD_END(RE_INVALID_SPEC, spec);
if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
else if (!IS_FILE(path)) Trap1_DEAD_END(RE_INVALID_SPEC, path);
// Get or setup internal state data:
file = (REBREQ*)Use_Port_State(port, RDI_FILE, sizeof(*file));
switch (action) {
case A_READ:
args = Find_Refines(call_, ALL_READ_REFS);
// Handle the READ %file shortcut case:
if (!IS_OPEN(file)) {
REBCNT nargs = AM_OPEN_READ;
if (args & AM_READ_SEEK) nargs |= AM_OPEN_SEEK;
Setup_File(file, nargs, path);
Open_File_Port(port, file, path);
opened = TRUE;
}
if (args & AM_READ_SEEK) Set_Seek(file, D_ARG(ARG_READ_INDEX));
len = Set_Length(
file, D_REF(ARG_READ_PART) ? VAL_INT64(D_ARG(ARG_READ_LENGTH)) : -1
);
Read_File_Port(D_OUT, port, file, path, args, len);
if (opened) {
OS_DO_DEVICE(file, RDC_CLOSE);
Cleanup_File(file);
}
if (file->error) Trap_Port_DEAD_END(RE_READ_ERROR, port, file->error);
break;
case A_APPEND:
if (!(IS_BINARY(D_ARG(2)) || IS_STRING(D_ARG(2)) || IS_BLOCK(D_ARG(2))))
Trap1_DEAD_END(RE_INVALID_ARG, D_ARG(2));
file->special.file.index = file->special.file.size;
SET_FLAG(file->modes, RFM_RESEEK);
case A_WRITE:
args = Find_Refines(call_, ALL_WRITE_REFS);
spec = D_ARG(2); // data (binary, string, or block)
// Handle the READ %file shortcut case:
if (!IS_OPEN(file)) {
REBCNT nargs = AM_OPEN_WRITE;
if (args & AM_WRITE_SEEK || args & AM_WRITE_APPEND) nargs |= AM_OPEN_SEEK;
else nargs |= AM_OPEN_NEW;
Setup_File(file, nargs, path);
Open_File_Port(port, file, path);
opened = TRUE;
}
else {
if (!GET_FLAG(file->modes, RFM_WRITE)) Trap1_DEAD_END(RE_READ_ONLY, path);
}
// Setup for /append or /seek:
if (args & AM_WRITE_APPEND) {
file->special.file.index = -1; // append
SET_FLAG(file->modes, RFM_RESEEK);
}
if (args & AM_WRITE_SEEK) Set_Seek(file, D_ARG(ARG_WRITE_INDEX));
// Determine length. Clip /PART to size of string if needed.
len = VAL_LEN(spec);
if (args & AM_WRITE_PART) {
REBCNT n = Int32s(D_ARG(ARG_WRITE_LENGTH), 0);
if (n <= len) len = n;
}
Write_File_Port(file, spec, len, args);
if (opened) {
OS_DO_DEVICE(file, RDC_CLOSE);
Cleanup_File(file);
}
if (file->error) Trap1_DEAD_END(RE_WRITE_ERROR, path);
break;
case A_OPEN:
args = Find_Refines(call_, ALL_OPEN_REFS);
// Default file modes if not specified:
if (!(args & (AM_OPEN_READ | AM_OPEN_WRITE))) args |= (AM_OPEN_READ | AM_OPEN_WRITE);
Setup_File(file, args, path);
Open_File_Port(port, file, path); // !!! needs to change file modes to R/O if necessary
break;
case A_COPY:
if (!IS_OPEN(file)) Trap1_DEAD_END(RE_NOT_OPEN, path); //!!!! wrong msg
len = Set_Length(file, D_REF(2) ? VAL_INT64(D_ARG(3)) : -1);
Read_File_Port(D_OUT, port, file, path, args, len);
break;
case A_OPENQ:
if (IS_OPEN(file)) return R_TRUE;
return R_FALSE;
case A_CLOSE:
if (IS_OPEN(file)) {
OS_DO_DEVICE(file, RDC_CLOSE);
Cleanup_File(file);
}
break;
case A_DELETE:
if (IS_OPEN(file)) Trap1_DEAD_END(RE_NO_DELETE, path);
Setup_File(file, 0, path);
if (OS_DO_DEVICE(file, RDC_DELETE) < 0 ) Trap1_DEAD_END(RE_NO_DELETE, path);
break;
case A_RENAME:
if (IS_OPEN(file)) Trap1_DEAD_END(RE_NO_RENAME, path);
else {
REBSER *target;
Setup_File(file, 0, path);
// Convert file name to OS format:
if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
Trap1_DEAD_END(RE_BAD_FILE_PATH, D_ARG(2));
file->common.data = BIN_DATA(target);
OS_DO_DEVICE(file, RDC_RENAME);
Free_Series(target);
if (file->error) Trap1_DEAD_END(RE_NO_RENAME, path);
}
break;
case A_CREATE:
// !!! should it leave file open???
if (!IS_OPEN(file)) {
Setup_File(file, AM_OPEN_WRITE | AM_OPEN_NEW, path);
if (OS_DO_DEVICE(file, RDC_CREATE) < 0) Trap_Port_DEAD_END(RE_CANNOT_OPEN, port, file->error);
OS_DO_DEVICE(file, RDC_CLOSE);
}
break;
case A_QUERY:
if (!IS_OPEN(file)) {
Setup_File(file, 0, path);
if (OS_DO_DEVICE(file, RDC_QUERY) < 0) return R_NONE;
}
Ret_Query_File(port, file, D_OUT);
// !!! free file path?
break;
case A_MODIFY:
Set_Mode_Value(file, Get_Mode_Id(D_ARG(2)), D_ARG(3));
if (!IS_OPEN(file)) {
Setup_File(file, 0, path);
if (OS_DO_DEVICE(file, RDC_MODIFY) < 0) return R_NONE;
}
return R_TRUE;
break;
case A_INDEXQ:
SET_INTEGER(D_OUT, file->special.file.index + 1);
break;
case A_LENGTHQ:
SET_INTEGER(D_OUT, file->special.file.size - file->special.file.index); // !clip at zero
break;
case A_HEAD:
file->special.file.index = 0;
goto seeked;
case A_TAIL:
file->special.file.index = file->special.file.size;
goto seeked;
case A_NEXT:
file->special.file.index++;
goto seeked;
case A_BACK:
if (file->special.file.index > 0) file->special.file.index--;
goto seeked;
case A_SKIP:
file->special.file.index += Get_Num_Arg(D_ARG(2));
goto seeked;
case A_HEADQ:
DECIDE(file->special.file.index == 0);
case A_TAILQ:
DECIDE(file->special.file.index >= file->special.file.size);
case A_PASTQ:
DECIDE(file->special.file.index > file->special.file.size);
case A_CLEAR:
// !! check for write enabled?
SET_FLAG(file->modes, RFM_RESEEK);
SET_FLAG(file->modes, RFM_TRUNCATE);
file->length = 0;
if (OS_DO_DEVICE(file, RDC_WRITE) < 0) Trap1_DEAD_END(RE_WRITE_ERROR, path);
break;
/* Not yet implemented:
A_AT, // 38
A_PICK, // 41
A_PATH, // 42
A_PATH_SET, // 43
A_FIND, // 44
A_SELECT, // 45
A_TAKE, // 49
A_INSERT, // 50
A_REMOVE, // 52
A_CHANGE, // 53
A_POKE, // 54
A_QUERY, // 64
A_FLUSH, // 65
*/
default:
Trap_Action_DEAD_END(REB_PORT, action);
}
return R_OUT;
seeked:
SET_FLAG(file->modes, RFM_RESEEK);
return R_ARG1;
is_true:
return R_TRUE;
is_false:
return R_FALSE;
}
//
// Series_Common_Action_Returns: C
//
// This routine is called to handle actions on ANY-SERIES! that can be taken
// care of without knowing what specific kind of series it is. So generally
// index manipulation, and things like LENGTH/etc.
//
// The strange name is to convey the result in an if statement, in the same
// spirit as the `if (XXX_Throws(...)) { /* handle throw */ }` pattern.
//
REBOOL Series_Common_Action_Returns(
REB_R *r, // `r_out` would be slightly confusing, considering R_OUT
REBFRM *frame_,
REBSYM action
) {
REBVAL *value = D_ARG(1);
REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
REBINT index = cast(REBINT, VAL_INDEX(value));
REBINT tail = cast(REBINT, VAL_LEN_HEAD(value));
REBINT len = 0;
switch (action) {
//-- Navigation:
case SYM_HEAD:
VAL_INDEX(value) = 0;
break;
case SYM_TAIL:
VAL_INDEX(value) = (REBCNT)tail;
break;
case SYM_HEAD_Q:
*r = (index == 0) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_TAIL_Q:
*r = (index >= tail) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_PAST_Q:
*r = (index > tail) ? R_TRUE : R_FALSE;
return TRUE; // handled
case SYM_NEXT:
if (index < tail) VAL_INDEX(value)++;
break;
case SYM_BACK:
if (index > 0) VAL_INDEX(value)--;
break;
case SYM_SKIP:
case SYM_AT:
len = Get_Num_From_Arg(arg);
{
REBI64 i = (REBI64)index + (REBI64)len;
if (action == SYM_SKIP) {
if (IS_LOGIC(arg)) i--;
} else { // A_AT
if (len > 0) i--;
}
if (i > (REBI64)tail) i = (REBI64)tail;
else if (i < 0) i = 0;
VAL_INDEX(value) = (REBCNT)i;
}
break;
case SYM_INDEX_OF:
SET_INTEGER(D_OUT, cast(REBI64, index) + 1);
*r = R_OUT;
return TRUE; // handled
case SYM_LENGTH:
SET_INTEGER(D_OUT, tail > index ? tail - index : 0);
*r = R_OUT;
return TRUE; // handled
case SYM_REMOVE:
// /PART length
FAIL_IF_LOCKED_SERIES(VAL_SERIES(value));
len = D_REF(2) ? Partial(value, 0, D_ARG(3)) : 1;
index = cast(REBINT, VAL_INDEX(value));
if (index < tail && len != 0)
Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
break;
case SYM_ADD: // Join_Strings(value, arg);
case SYM_SUBTRACT: // "test this" - 10
case SYM_MULTIPLY: // "t" * 4 = "tttt"
case SYM_DIVIDE:
case SYM_REMAINDER:
case SYM_POWER:
case SYM_ODD_Q:
case SYM_EVEN_Q:
case SYM_ABSOLUTE:
fail (Error_Illegal_Action(VAL_TYPE(value), action));
default:
return FALSE; // not a common operation, not handled
}
*D_OUT = *value;
*r = R_OUT;
return TRUE; // handled
}