*/ RL_API REBYTE *RL_Word_String(u32 word) /* ** Return a string related to a given global word identifier. ** ** Returns: ** A copy of the word string, null terminated. ** Arguments: ** word - a global word identifier ** Notes: ** The result is a null terminated copy of the name for your own use. ** The string is always UTF-8 encoded (chars > 127 are encoded.) ** In this API, word identifiers are always canonical. Therefore, ** the returned string may have different spelling/casing than expected. ** The string is allocated with OS_ALLOC and you can OS_FREE it any time. ** ***********************************************************************/ { REBYTE *s1, *s2; // !!This code should use a function from c-words.c (but nothing perfect yet.) if (word == 0 || word >= PG_Word_Table.series->tail) return 0; s1 = VAL_SYM_NAME(BLK_SKIP(PG_Word_Table.series, word)); s2 = OS_ALLOC_ARRAY(REBYTE, LEN_BYTES(s1) + 1); COPY_BYTES(s2, s1, LEN_BYTES(s1) + 1); return s2; }
// // RL_Word_String: C // // Return a string related to a given global word identifier. // // Returns: // A copy of the word string, null terminated. // Arguments: // word - a global word identifier // Notes: // The result is a null terminated copy of the name for your own use. // The string is always UTF-8 encoded (chars > 127 are encoded.) // In this API, word identifiers are always canonical. Therefore, // the returned string may have different spelling/casing than expected. // The string is allocated with OS_ALLOC and you can OS_FREE it any time. // RL_API REBYTE *RL_Word_String(u32 word) { REBYTE *s1, *s2; // !!This code should use a function from c-words.c (but nothing perfect yet.) if (word == 0 || word >= ARR_LEN(PG_Word_Table.array)) return 0; s1 = VAL_SYM_NAME(ARR_AT(PG_Word_Table.array, word)); s2 = OS_ALLOC_N(REBYTE, LEN_BYTES(s1) + 1); COPY_BYTES(s2, s1, LEN_BYTES(s1) + 1); return s2; }
*/ REBINT Emit_Integer(REBYTE *buf, REBI64 val) /* ***********************************************************************/ { INT_TO_STR(val, buf); return LEN_BYTES(buf); }
*/ void Put_Str(REBYTE *buf) /* ** Outputs a null terminated UTF-8 string. ** If buf is larger than StdIO Device allows, error out. ** OS dependent line termination must be done prior to call. ** ** !!! A request should ideally have a way to enforce that it is not ** going to modify the data. We currently require the caller to ** pass us data that could be written to, but "promise not to" ** since it is a RDC_WRITE operation. To stay on the right side ** of the compiler, use a strdup()/free() instead of an m_cast. ** ***********************************************************************/ { /* This function could be called by signal handler and inside of Fetch_Buf */ REBREQ req; memcpy(&req, &Std_IO_Req, sizeof(req)); req.length = LEN_BYTES(buf); req.common.data = buf; req.actual = 0; OS_Do_Device(&req, RDC_WRITE); if (req.error) Host_Crash("stdio write"); }
static int Fetch_Buf() { REBCNT len = LEN_BYTES(inbuf); Std_IO_Req.common.data = inbuf + len; Std_IO_Req.length = inbuf_len - len - 1; Std_IO_Req.actual = 0; OS_Do_Device(&Std_IO_Req, RDC_READ); // If error, don't crash, just ignore it: if (Std_IO_Req.error) return 0; //Host_Crash("stdio read"); // Terminate (LF) last line? if (len > 0 && Std_IO_Req.actual == 0) { inbuf[len++] = LF; inbuf[len] = 0; return TRUE; } // Null terminate buffer: len = Std_IO_Req.actual; Std_IO_Req.common.data[len] = 0; return len > 0; }
// // RL_Do_Binary: C // // Evaluate an encoded binary script such as compressed text. // // Returns: // The datatype of the result or zero if error in the encoding. // Arguments: // bin - by default, a REBOL compressed UTF-8 (or ASCII) script. // length - the length of the data. // flags - special flags (set to zero at this time). // key - encoding, encryption, or signature key. // result - value returned from evaluation. // Notes: // As of A104, only compressed scripts are supported, however, // rebin, cloaked, signed, and encrypted formats will be supported. // RL_API int RL_Do_Binary( int *exit_status, const REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *out ) { REBSER *text; #ifdef DUMP_INIT_SCRIPT int f; #endif int maybe_rxt; // could be REBRXT, or negative number for error :-/ text = Decompress(bin, length, -1, FALSE, FALSE); if (!text) return 0; Append_Codepoint_Raw(text, 0); #ifdef DUMP_INIT_SCRIPT f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE ); _write(f, BIN_HEAD(text), LEN_BYTES(BIN_HEAD(text))); _close(f); #endif PUSH_GUARD_SERIES(text); maybe_rxt = RL_Do_String(exit_status, BIN_HEAD(text), flags, out); DROP_GUARD_SERIES(text); Free_Series(text); return maybe_rxt; }
*/ void Init_Mold(REBCNT size) /* ***********************************************************************/ { REBYTE *cp; REBYTE c; const REBYTE *dc; Set_Root_Series(TASK_MOLD_LOOP, Make_Block(size/10), "mold loop"); Set_Root_Series(TASK_BUF_MOLD, Make_Unicode(size), "mold buffer"); // Create quoted char escape table: Char_Escapes = cp = ALLOC_ARRAY_ZEROFILL(REBYTE, MAX_ESC_CHAR + 1); for (c = '@'; c <= '_'; c++) *cp++ = c; Char_Escapes[cast(REBYTE, TAB)] = '-'; Char_Escapes[cast(REBYTE, LF)] = '/'; Char_Escapes[cast(REBYTE, '"')] = '"'; Char_Escapes[cast(REBYTE, '^')] = '^'; URL_Escapes = cp = ALLOC_ARRAY_ZEROFILL(REBYTE, MAX_URL_CHAR + 1); //for (c = 0; c <= MAX_URL_CHAR; c++) if (IS_LEX_DELIMIT(c)) cp[c] = ESC_URL; for (c = 0; c <= ' '; c++) cp[c] = ESC_URL | ESC_FILE; dc = cb_cast(";%\"()[]{}<>"); for (c = LEN_BYTES(dc); c > 0; c--) URL_Escapes[*dc++] = ESC_URL | ESC_FILE; }
*/ void Debug_String(const void *p, REBCNT len, REBOOL uni, REBINT lines) /* ***********************************************************************/ { REBUNI uc; const REBYTE *bp = uni ? NULL : cast(const REBYTE *, p); const REBUNI *up = uni ? cast(const REBUNI *, p) : NULL; if (Trace_Limit > 0) { if (Trace_Buffer->tail >= Trace_Limit) Remove_Series(Trace_Buffer, 0, 2000); if (len == UNKNOWN) len = uni ? Strlen_Uni(up) : LEN_BYTES(bp); // !!! account for unicode! for (; len > 0; len--) { uc = uni ? *up++ : *bp++; Append_Byte(Trace_Buffer, uc); } //Append_Unencoded_Len(Trace_Buffer, bp, len); for (; lines > 0; lines--) Append_Byte(Trace_Buffer, LF); } else { Prin_OS_String(p, len, uni); for (; lines > 0; lines--) Print_OS_Line(); } }
*/ void Init_Mold(REBCNT size) /* ***********************************************************************/ { REBYTE *cp; REBYTE c; REBYTE *dc; Set_Root_Series(TASK_MOLD_LOOP, Make_Block(size/10), "mold loop"); Set_Root_Series(TASK_BUF_MOLD, Make_Unicode(size), "mold buffer"); // Create quoted char escape table: Char_Escapes = cp = Make_Mem(MAX_ESC_CHAR+1); // cleared for (c = '@'; c <= '_'; c++) *cp++ = c; Char_Escapes[TAB] = '-'; Char_Escapes[LF] = '/'; Char_Escapes['"'] = '"'; Char_Escapes['^'] = '^'; URL_Escapes = cp = Make_Mem(MAX_URL_CHAR+1); // cleared //for (c = 0; c <= MAX_URL_CHAR; c++) if (IS_LEX_DELIMIT(c)) cp[c] = ESC_URL; for (c = 0; c <= ' '; c++) cp[c] = ESC_URL | ESC_FILE; dc = ";%\"()[]{}<>"; for (c = LEN_BYTES(dc); c > 0; c--) URL_Escapes[*dc++] = ESC_URL | ESC_FILE; }
*/ REBOOL Cloak(REBOOL decode, REBYTE *cp, REBCNT dlen, REBYTE *kp, REBCNT klen, REBFLG as_is) /* ** Simple data scrambler. Quality depends on the key length. ** Result is made in place (data string). ** ** The key (kp) is passed as a REBVAL or REBYTE (when klen is !0). ** ***********************************************************************/ { REBCNT i, n; REBYTE src[20]; REBYTE dst[20]; if (dlen == 0) return TRUE; // Decode KEY as VALUE field (binary, string, or integer) if (klen == 0) { REBVAL *val = (REBVAL*)kp; REBSER *ser; switch (VAL_TYPE(val)) { case REB_BINARY: kp = VAL_BIN_DATA(val); klen = VAL_LEN(val); break; case REB_STRING: ser = Temp_Bin_Str_Managed(val, &i, &klen); kp = BIN_SKIP(ser, i); break; case REB_INTEGER: INT_TO_STR(VAL_INT64(val), dst); klen = LEN_BYTES(dst); as_is = FALSE; break; } if (klen == 0) return FALSE; } if (!as_is) { for (i = 0; i < 20; i++) src[i] = kp[i % klen]; SHA1(src, 20, dst); klen = 20; kp = dst; } if (decode) for (i = dlen-1; i > 0; i--) cp[i] ^= cp[i-1] ^ kp[i % klen]; // Change starting byte based all other bytes. n = 0xa5; for (i = 1; i < dlen; i++) n += cp[i]; cp[0] ^= (REBYTE)n; if (!decode) for (i = 1; i < dlen; i++) cp[i] ^= cp[i-1] ^ kp[i % klen]; return TRUE; }
*/ REBYTE *Form_Integer(REBYTE *buf, REBI64 val) /* ** Form standard REBOL integer value (32 or 64). ** Make sure you have room in your buffer before calling this! ** ***********************************************************************/ { INT_TO_STR(val, buf); return buf+LEN_BYTES(buf); }
*/ REBCNT Encode_UTF8(REBYTE *dst, REBINT max, void *src, REBCNT *len, REBFLG uni, REBFLG ccr) /* ** Encode the unicode into UTF8 byte string. ** ** Source string can be byte or unichar sized (uni = TRUE); ** Max is the maximum size of the result (UTF8). ** Returns number of source chars used. ** Updates len for dst bytes used. ** Does not add a terminator. ** ***********************************************************************/ { REBUNI c; REBINT n; REBYTE buf[8]; REBYTE *bs = dst; // save start REBYTE *bp = (REBYTE*)src; REBUNI *up = (REBUNI*)src; REBCNT cnt; if (len) cnt = *len; else { cnt = (REBCNT)(uni ? wcslen((const wchar_t*)bp) : LEN_BYTES((REBYTE*)bp)); } for (; max > 0 && cnt > 0; cnt--) { c = uni ? *up++ : *bp++; if (c < 0x80) { #if defined(TO_WINDOWS) if (ccr && c == LF) { // If there's not room, don't try to output CRLF if (2 > max) {up--; break;} *dst++ = CR; max--; c = LF; } #endif *dst++ = (REBYTE)c; max--; } else { n = Encode_UTF8_Char(buf, c); if (n > max) {up--; break;} memcpy(dst, buf, n); dst += n; max -= n; } } if (len) *len = dst - bs; return uni ? up - (REBUNI*)src : bp - (REBYTE*)src; }
int main() { time_t t; srand((unsigned) time(&t)); unsigned int id = rand(), i; char cname[CNAME_MAX_SIZE], time[TIME_BUFFER_SIZE], valid[TIME_BUFFER_SIZE], csr[CSR_MAX_SIZE], csr_cpy[CSR_MAX_SIZE], certificate[CERTIFICATE_MAX_SIZE], certificate_cpy[CERTIFICATE_MAX_SIZE]; unsigned char auth_key[SMQV_PKEY_SIZE], token_keypair[MSS_SKEY_SIZE + MSS_PKEY_SIZE], token_skey[MSS_SKEY_SIZE], token_pkey[MSS_PKEY_SIZE], csr_signature[MSS_SIGNATURE_SIZE], signature[ECDSA_SIGNATURE_SIZE]; // valid: 3333XXXXXXXXXX now(&valid); valid[0] = '3'; valid[1] = '3'; valid[2] = '3'; valid[3] = '3'; sprintf(cname, "TESTE do CERTIFICATE"); unsigned char seed[LEN_BYTES(MSS_SEC_LVL)] = {0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39,0x3A,0x3B,0x3C,0x3D,0x3E,0x3F}; memcpy(token_keypair, mss_keygen(seed), MSS_SKEY_SIZE + MSS_PKEY_SIZE); memcpy(token_skey, token_keypair, MSS_SKEY_SIZE); memcpy(token_pkey, token_keypair + MSS_SKEY_SIZE, MSS_PKEY_SIZE); for(i = 0; i < SMQV_PKEY_SIZE; i++) auth_key[i] = rand(); /** * CSR */ generate_csr(id, cname, auth_key, token_pkey, token_skey, csr); if(read_csr(&id, cname, time, auth_key, token_pkey, csr_signature, csr)) printf("CSR generation/read - OK\n"); else printf("CSR generation/read - Fail\n"); printf("\n"); /** * CERTIFICATE */ unsigned char ca_skey[ECDSA_SKEY_SIZE], ca_pkey[ECDSA_PKEY_SIZE]; ecdsa_keygen(ca_skey, ca_pkey); generate_certificate(csr, valid, ca_skey, certificate); if(read_certificate(&id, cname, time, valid, auth_key, token_pkey, signature, ca_pkey, certificate)) printf("CERTIFICATE generation/read - OK\n"); else printf("CERTIFICATE generation/read - Fail\n"); printf("\n"); return 0; }
// // Cloak: C // // Simple data scrambler. Quality depends on the key length. // Result is made in place (data string). // // The key (kp) is passed as a REBVAL or REBYTE (when klen is !0). // REBOOL Cloak(REBOOL decode, REBYTE *cp, REBCNT dlen, REBYTE *kp, REBCNT klen, REBOOL as_is) { REBCNT i, n; REBYTE src[20]; REBYTE dst[20]; if (dlen == 0) return TRUE; // Decode KEY as VALUE field (binary, string, or integer) if (klen == 0) { REBVAL *val = (REBVAL*)kp; REBSER *ser; switch (VAL_TYPE(val)) { case REB_BINARY: kp = VAL_BIN_AT(val); klen = VAL_LEN_AT(val); break; case REB_STRING: ser = Temp_Bin_Str_Managed(val, &i, &klen); kp = BIN_AT(ser, i); break; case REB_INTEGER: INT_TO_STR(VAL_INT64(val), dst); klen = LEN_BYTES(dst); as_is = FALSE; break; } if (klen == 0) return FALSE; } if (!as_is) { for (i = 0; i < 20; i++) src[i] = kp[i % klen]; SHA1(src, 20, dst); klen = 20; kp = dst; } if (decode) for (i = dlen-1; i > 0; i--) cp[i] ^= cp[i-1] ^ kp[i % klen]; // Change starting byte based all other bytes. n = 0xa5; for (i = 1; i < dlen; i++) n += cp[i]; cp[0] ^= (REBYTE)n; if (!decode) for (i = 1; i < dlen; i++) cp[i] ^= cp[i-1] ^ kp[i % klen]; return TRUE; }
*/ static void Prin_OS_String(const void *p, REBCNT len, REBOOL uni) /* ** Print a string, but no line terminator or space. ** ** The width of the input is specified by UNI. ** ***********************************************************************/ { #define BUF_SIZE 1024 REBYTE buffer[BUF_SIZE]; // on stack REBYTE *buf = &buffer[0]; REBINT n; REBCNT len2; const REBYTE *bp = uni ? NULL : cast(const REBYTE *, p); const REBUNI *up = uni ? cast(const REBUNI *, p) : NULL; if (!p) Panic(RP_NO_PRINT_PTR); // Determine length if not provided: if (len == UNKNOWN) len = uni ? Strlen_Uni(up) : LEN_BYTES(bp); SET_FLAG(Req_SIO->flags, RRF_FLUSH); Req_SIO->actual = 0; Req_SIO->common.data = buf; buffer[0] = 0; // for debug tracing while ((len2 = len) > 0) { Do_Signals(); // returns # of chars, size returns buf bytes output n = Encode_UTF8( buf, BUF_SIZE-4, uni ? cast(const void *, up) : cast(const void *, bp), &len2, uni, OS_CRLF ); if (n == 0) break; Req_SIO->length = len2; // byte size of buffer if (uni) up += n; else bp += n; len -= n; OS_DO_DEVICE(Req_SIO, RDC_WRITE); if (Req_SIO->error) Panic(RP_IO_ERROR); } }
*/ RL_API int RL_Do_Binary(REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result) /* ** Evaluate an encoded binary script such as compressed text. ** ** Returns: ** The datatype of the result or zero if error in the encoding. ** Arguments: ** bin - by default, a REBOL compressed UTF-8 (or ASCII) script. ** length - the length of the data. ** flags - special flags (set to zero at this time). ** key - encoding, encryption, or signature key. ** result - value returned from evaluation. ** Notes: ** As of A104, only compressed scripts are supported, however, ** rebin, cloaked, signed, and encrypted formats will be supported. ** ***********************************************************************/ { REBSER spec = {0}; REBSER *text; REBVAL *val; #ifdef DUMP_INIT_SCRIPT int f; #endif //Cloak(TRUE, code, NAT_SPEC_SIZE, &key[0], 20, TRUE); spec.data = bin; spec.tail = length; text = Decompress(&spec, 0, -1, 10000000, 0); if (!text) return FALSE; Append_Byte(text, 0); #ifdef DUMP_INIT_SCRIPT f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE ); _write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text))); _close(f); #endif SAVE_SERIES(text); val = Do_String(text->data, flags); UNSAVE_SERIES(text); if (IS_ERROR(val)) // && (VAL_ERR_NUM(val) != RE_QUIT)) { Print_Value(val, 1000, FALSE); if (result) { *result = Value_To_RXI(val); return Reb_To_RXT[VAL_TYPE(val)]; } return 0; }
*/ RL_API u32 RL_Map_Word(REBYTE *string) /* ** Given a word as a string, return its global word identifier. ** ** Returns: ** The word identifier that matches the string. ** Arguments: ** string - a valid word as a UTF-8 encoded string. ** Notes: ** Word identifiers are persistent, and you can use them anytime. ** If the word is new (not found in master symbol table) ** it will be added and the new word identifier is returned. ** ***********************************************************************/ { return Make_Word(string, LEN_BYTES(string)); }
*/ REBSER *Copy_Bytes(const REBYTE *src, REBINT len) /* ** Create a string series from the given bytes. ** Source is always latin-1 valid. Result is always 8bit. ** ***********************************************************************/ { REBSER *dst; if (len < 0) len = LEN_BYTES(src); dst = Make_Binary(len); memcpy(STR_DATA(dst), src, len); SERIES_TAIL(dst) = len; STR_TERM(dst); return dst; }
*/ REBINT Compare_UTF8(REBYTE *s1, REBYTE *s2, REBCNT l2) /* ** Compare two UTF8 strings. ** ** It is necessary to decode the strings to check if the match ** case-insensitively. ** ** Returns: ** -3: no match, s2 > s1 ** -1: no match, s1 > s2 ** 0: exact match ** 1: non-case match, s2 > s1 ** 3: non-case match, s1 > s2 ** ** So, result + 2 for no-match gives proper sort order. ** And, result - 2 for non-case match gives sort order. ** ** Used for: WORD comparison. ** ***********************************************************************/ { REBINT c1, c2; REBCNT l1 = LEN_BYTES(s1); REBINT result = 0; for (; l1 > 0 && l2 > 0; s1++, s2++, l1--, l2--) { c1 = (REBYTE)*s1; c2 = (REBYTE)*s2; if (c1 > 127) c1 = Decode_UTF8_Char(&s1, &l1); //!!! can return 0 on error! if (c2 > 127) c2 = Decode_UTF8_Char(&s2, &l2); if (c1 != c2) { if (c1 >= UNICODE_CASES || c2 >= UNICODE_CASES || LO_CASE(c1) != LO_CASE(c2)) { return (c1 > c2) ? -1 : -3; } if (!result) result = (c1 > c2) ? 3 : 1; } } if (l1 != l2) result = (l1 > l2) ? -1 : -3; return result; }
*/ REBINT Compare_Word(REBVAL *s, REBVAL *t, REBFLG is_case) /* ** Compare the names of two words and return the difference. ** Note that words are kept UTF8 encoded. ** Positive result if s > t and negative if s < t. ** ***********************************************************************/ { REBYTE *sp = VAL_WORD_NAME(s); REBYTE *tp = VAL_WORD_NAME(t); // Use a more strict comparison than normal: if (is_case) return CMP_BYTES(sp, tp); // They are the equivalent words: if (VAL_WORD_CANON(s) == VAL_WORD_CANON(t)) return 0; // They must be differ by case: return Compare_UTF8(sp, tp, LEN_BYTES(tp)) + 2; }
*/ RL_API int RL_Do_Binary(int *exit_status, const REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result) /* ** Evaluate an encoded binary script such as compressed text. ** ** Returns: ** The datatype of the result or zero if error in the encoding. ** Arguments: ** bin - by default, a REBOL compressed UTF-8 (or ASCII) script. ** length - the length of the data. ** flags - special flags (set to zero at this time). ** key - encoding, encryption, or signature key. ** result - value returned from evaluation. ** Notes: ** As of A104, only compressed scripts are supported, however, ** rebin, cloaked, signed, and encrypted formats will be supported. ** ***********************************************************************/ { REBSER *text; #ifdef DUMP_INIT_SCRIPT int f; #endif int do_result; text = Decompress(bin, length, -1, FALSE, FALSE); if (!text) return FALSE; Append_Codepoint_Raw(text, 0); #ifdef DUMP_INIT_SCRIPT f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE ); _write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text))); _close(f); #endif PUSH_GUARD_SERIES(text); do_result = RL_Do_String(exit_status, text->data, flags, result); DROP_GUARD_SERIES(text); Free_Series(text); return do_result; }
static REBYTE *Get_Next_Line() { REBYTE *bp = inbuf; REBYTE *out; REBCNT len; // Scan for line terminator or end: for (bp = inbuf; *bp != CR && *bp != LF && *bp != 0; bp++); // If found, copy the line and remove it from buffer: if (*bp) { if (*bp == CR && bp[1] == LF) bp++; len = bp - inbuf; out = OS_ALLOC_ARRAY(REBYTE, len + 2); COPY_BYTES(out, inbuf, len+1); out[len+1] = 0; memmove(inbuf, bp + 1, 1 + LEN_BYTES(bp + 1)); return out; } return 0; // more input needed }
*/ REBINT Bin_To_Money(REBVAL *result, REBVAL *val) /* ***********************************************************************/ { REBCNT len; REBYTE buf[MAX_HEX_LEN+4] = {0}; // binary to convert if (IS_BINARY(val)) { len = VAL_LEN(val); if (len > 12) len = 12; memcpy(buf, VAL_BIN_DATA(val), len); } #ifdef removed else if (IS_ISSUE(val)) { //if (!(len = Scan_Hex_Bytes(val, 24, buf))) return FALSE; REBYTE *ap = Get_Word_Name(val); REBYTE *bp = &buf[0]; REBCNT alen; REBUNI c; len = LEN_BYTES(ap); // UTF-8 len if (len & 1) return FALSE; // must have even # of chars len /= 2; if (len > 12) return FALSE; // valid even for UTF-8 for (alen = 0; alen < len; alen++) { if (!Scan_Hex2(ap, &c, 0)) return FALSE; *bp++ = (REBYTE)c; ap += 2; } } #endif else raise Error_Invalid_Arg(val); memcpy(buf + 12 - len, buf, len); // shift to right side memset(buf, 0, 12 - len); VAL_MONEY_AMOUNT(result) = binary_to_deci(buf); return TRUE; }
// // RL_Map_Word: C // // Given a word as a string, return its global word identifier. // // Returns: // The word identifier that matches the string. // Arguments: // string - a valid word as a UTF-8 encoded string. // Notes: // Word identifiers are persistent, and you can use them anytime. // If the word is new (not found in master symbol table) // it will be added and the new word identifier is returned. // RL_API u32 RL_Map_Word(REBYTE *string) { return Make_Word(string, LEN_BYTES(string)); }
*/ REBCNT Make_Word(REBYTE *str, REBCNT len) /* ** Given a string and its length, compute its hash value, ** search for a match, and if not found, add it to the table. ** Length of zero indicates you provided a zero terminated string. ** Return the table index for the word (whether found or new). ** ***********************************************************************/ { REBINT hash; REBINT size; REBINT skip; REBINT n; REBCNT h; REBCNT *hashes; REBVAL *words; REBVAL *w; //REBYTE *sss = Get_Sym_Name(1); // (Debugging method) if (len == 0) len = LEN_BYTES(str); // If hash part of word table is too dense, expand it: if (PG_Word_Table.series->tail > PG_Word_Table.hashes->tail/2) Expand_Word_Table(); ASSERT((SERIES_TAIL(PG_Word_Table.series) == SERIES_TAIL(Bind_Table)), RP_BIND_TABLE_SIZE); // If word symbol part of word table is full, expand it: if (SERIES_FULL(PG_Word_Table.series)) { Extend_Series(PG_Word_Table.series, 256); } if (SERIES_FULL(Bind_Table)) { Extend_Series(Bind_Table, 256); CLEAR_SERIES(Bind_Table); } size = (REBINT)PG_Word_Table.hashes->tail; words = BLK_HEAD(PG_Word_Table.series); hashes = (REBCNT *)PG_Word_Table.hashes->data; // Hash the word, including a skip factor for lookup: hash = Hash_Word(str, len); skip = (hash & 0x0000FFFF) % size; if (skip == 0) skip = 1; hash = (hash & 0x00FFFF00) % size; //Debug_Fmt("%s hash %d skip %d", str, hash, skip); // Search hash table for word match: while (NZ(h = hashes[hash])) { while ((n = Compare_UTF8(VAL_SYM_NAME(words+h), str, len)) >= 0) { //if (Match_String("script", str, len)) // Debug_Fmt("---- %s %d %d\n", VAL_SYM_NAME(&words[h]), n, h); if (n == 0) return h; // direct hit if (VAL_SYM_ALIAS(words+h)) h = VAL_SYM_ALIAS(words+h); else goto make_sym; // Create new alias for word } hash += skip; if (hash >= size) hash -= size; } make_sym: n = PG_Word_Table.series->tail; w = words + n; if (h) { // Alias word (h = canon word) VAL_SYM_ALIAS(words+h) = n; VAL_SYM_CANON(w) = VAL_SYM_CANON(words+h); } else { // Canon (base version of) word (h == 0) hashes[hash] = n; VAL_SYM_CANON(w) = n; } VAL_SYM_ALIAS(w) = 0; VAL_SYM_NINDEX(w) = Make_Word_Name(str, len); VAL_SET(w, REB_HANDLE); // These are allowed because of the SERIES_FULL checks above which // add one extra to the TAIL check comparision. However, their // termination values (nulls) will be missing. PG_Word_Table.series->tail++; Bind_Table->tail++; return n; }
*/ REBINT Emit_Decimal(REBYTE *cp, REBDEC d, REBFLG percent, REBYTE point, REBINT digits) /* ***********************************************************************/ { REBYTE out[MAX_NUMCHR]; REBINT len; REBINT n; REBINT i; REBI64 sig; REBINT pt; REBFLG neg; REBYTE *start = cp; *cp = out[0] = 0; // Deal with 0 as special case: if (d == 0.0 || d == -0.0) { *cp++ = '0'; if (!percent) { *cp++ = '.'; *cp++ = '0'; } } else { if (percent) d *= 100.0; if (NZ(neg = (d < 0))) d = -d; if (Convert_Decimal(d, &sig, &pt)) { // Not exp format. len = Form_Integer(out, sig) - out; if (neg) *cp++ = '-'; // Trim un-needed trailing zeros: for (len--; len > 0 && len >= pt; len--) { if (out[len] == '0') out[len] = 0; else break; } // Leading zero, as in 0.1 if (pt <= 0) *cp++ = '0'; // Other leading digits: for (n = 0; out[n] && n < pt; n++) *cp++ = out[n]; if (!percent || n <= len) { // Decimal point: *cp++ = point; // Zeros before first significant digit: for (i = 0; i > pt; i--) *cp++ = '0'; // All remaining digits: for (; n <= len; n++) *cp++ = out[n]; // Force extra zero in 1.0 cases: if (cp[-1] == point) *cp++ = '0'; } } else { REBYTE *pp; // Requires exp format: if (percent) Trap0(RE_OVERFLOW); len = Get_System_Int(SYS_OPTIONS, OPTIONS_DECIMAL_DIGITS, MAX_DIGITS); if (len > MAX_DIGITS) len = MAX_DIGITS; gcvt(d, len, cp); // returns 1.2e123 (also 1e123) pp = strchr(cp, '.'); if (pp && (pp[1] == 'e' || pp[1] == 'E')) { memcpy(pp, pp+1, strlen(pp)); } if (point != '.' && pp) { cp = strchr(cp, '.'); if (cp) *cp = point; } cp = start + LEN_BYTES(start); } } if (percent) *cp++ = '%'; *cp = 0; return cp - start; }
// // Form_Integer: C // // Form standard REBOL integer value (32 or 64). // Make sure you have room in your buffer before calling this! // REBYTE *Form_Integer(REBYTE *buf, REBI64 val) { INT_TO_STR(val, buf); return buf+LEN_BYTES(buf); }
// // MAKE_Tuple: C // void MAKE_Tuple(REBVAL *out, enum Reb_Kind type, const REBVAL *arg) { if (IS_TUPLE(arg)) { *out = *arg; return; } VAL_RESET_HEADER(out, REB_TUPLE); REBYTE *vp = VAL_TUPLE(out); // !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or // similar URL!s. In Rebol3 these captures come back the same type // as the input instead of as STRING!, which was a latent bug in the // network code of the 12-Dec-2012 release: // // https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110 // // All attempts to convert a URL!-flavored IP address failed. Taking // URL! here fixes it, though there are still open questions. // if (IS_STRING(arg) || IS_URL(arg)) { REBCNT len; REBYTE *ap = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_TUPLE, &len, FALSE); if (Scan_Tuple(ap, len, out)) return; goto bad_arg; } if (ANY_ARRAY(arg)) { REBCNT len = 0; REBINT n; RELVAL *item = VAL_ARRAY_AT(arg); for (; NOT_END(item); ++item, ++vp, ++len) { if (len >= MAX_TUPLE) goto bad_make; if (IS_INTEGER(item)) { n = Int32(item); } else if (IS_CHAR(item)) { n = VAL_CHAR(item); } else goto bad_make; if (n > 255 || n < 0) goto bad_make; *vp = n; } VAL_TUPLE_LEN(out) = len; for (; len < MAX_TUPLE; len++) *vp++ = 0; return; } REBCNT alen; if (IS_ISSUE(arg)) { REBUNI c; const REBYTE *ap = VAL_WORD_HEAD(arg); REBCNT len = LEN_BYTES(ap); // UTF-8 len if (len & 1) goto bad_arg; // must have even # of chars len /= 2; if (len > MAX_TUPLE) goto bad_arg; // valid even for UTF-8 VAL_TUPLE_LEN(out) = len; for (alen = 0; alen < len; alen++) { const REBOOL unicode = FALSE; if (!Scan_Hex2(ap, &c, unicode)) goto bad_arg; *vp++ = cast(REBYTE, c); ap += 2; } } else if (IS_BINARY(arg)) { REBYTE *ap = VAL_BIN_AT(arg); REBCNT len = VAL_LEN_AT(arg); if (len > MAX_TUPLE) len = MAX_TUPLE; VAL_TUPLE_LEN(out) = len; for (alen = 0; alen < len; alen++) *vp++ = *ap++; } else goto bad_arg; for (; alen < MAX_TUPLE; alen++) *vp++ = 0; return; bad_arg: fail (Error_Invalid_Arg(arg)); bad_make: fail (Error_Bad_Make(REB_TUPLE, arg)); }
*/ void Crash(REBINT id, ...) /* ** Print a failure message and abort. ** ** LATIN1 ONLY!! (For now) ** ** The error is identified by id number, which can reference an ** error message string in the boot strings block. ** ** Note that lower level error messages should not attempt to ** use the %r (mold value) format (uses higher level functions). ** ** See panics.h for list of crash errors. ** ***********************************************************************/ { va_list args; REBYTE buf[CRASH_BUF_SIZE]; REBYTE *msg; REBINT n = 0; va_start(args, id); DISABLE_GC; if (Reb_Opts->crash_dump) { Dump_Info(); Dump_Stack(0, 0); } // "REBOL PANIC #nnn:" COPY_BYTES(buf, Crash_Msgs[CM_ERROR], CRASH_BUF_SIZE); APPEND_BYTES(buf, " #", CRASH_BUF_SIZE); Form_Int(buf + LEN_BYTES(buf), id); APPEND_BYTES(buf, ": ", CRASH_BUF_SIZE); // "REBOL PANIC #nnn: put error message here" // The first few error types only print general error message. // Those errors > RP_STR_BASE have specific error messages (from boot.r). if (id < RP_BOOT_DATA) n = CM_DEBUG; else if (id < RP_INTERNAL) n = CM_BOOT; else if (id < RP_ASSERTS) n = CM_INTERNAL; else if (id < RP_DATATYPE) n = CM_ASSERT; else if (id < RP_STR_BASE) n = CM_DATATYPE; else if (id > RP_STR_BASE + RS_MAX - RS_ERROR) n = CM_DEBUG; // Use the above string or the boot string for the error (in boot.r): msg = (REBYTE*)(n >= 0 ? Crash_Msgs[n] : BOOT_STR(RS_ERROR, id - RP_STR_BASE - 1)); Form_Var_Args(buf + LEN_BYTES(buf), CRASH_BUF_SIZE - 1 - LEN_BYTES(buf), msg, args); n = LEN_BYTES(Crash_Msgs[CM_CONTACT]); if ((LEN_BYTES(buf) + n) < (CRASH_BUF_SIZE - 1)) APPEND_BYTES(buf, Crash_Msgs[CM_CONTACT], n); // Convert to OS-specific char-type: #ifdef disable_for_now //OS_WIDE_CHAR /// win98 does not support it { REBCHR s1[512]; REBCHR s2[2000]; n = TO_OS_STR(s1, Crash_Msgs[CM_ERROR], LEN_BYTES(Crash_Msgs[CM_ERROR])); if (n > 0) s1[n] = 0; // terminate else OS_EXIT(200); // bad conversion n = TO_OS_STR(s2, buf, LEN_BYTES(buf)); if (n > 0) s2[n] = 0; else OS_EXIT(200); OS_CRASH(s1, s2); } #else OS_CRASH(Crash_Msgs[CM_ERROR], buf); #endif }
*/ RL_API int RL_Do_String(int *exit_status, const REBYTE *text, REBCNT flags, RXIARG *result) /* ** Load a string and evaluate the resulting block. ** ** Returns: ** The datatype of the result if a positive number (or 0 if the ** type has no representation in the "RXT" API). An error code ** if it's a negative number. Two negative numbers are reserved ** for non-error conditions: -1 for halting (e.g. Escape), and ** -2 is reserved for exiting with exit_status set. ** ** Arguments: ** text - A null terminated UTF-8 (or ASCII) string to transcode ** into a block and evaluate. ** flags - set to zero for now ** result - value returned from evaluation, if NULL then result ** will be returned on the top of the stack ** ** Notes: ** This API was from before Rebol's open sourcing and had little ** vetting and few clients. The one client it did have was the ** "sample" console code (which wound up being the "only" ** console code for quite some time). ** ***********************************************************************/ { REBSER *code; REBVAL out; REBOL_STATE state; const REBVAL *error; // assumes it can only be run at the topmost level where // the data stack is completely empty. assert(DSP == -1); PUSH_UNHALTABLE_TRAP(&error, &state); // The first time through the following code 'error' will be NULL, but... // `raise Error` can longjmp here, so 'error' won't be NULL *if* that happens! if (error) { if (VAL_ERR_NUM(error) == RE_HALT) return -1; // !!! Revisit hardcoded # // Save error for WHY? *Get_System(SYS_STATE, STATE_LAST_ERROR) = *error; if (result) *result = Value_To_RXI(error); else DS_PUSH(error); return -VAL_ERR_NUM(error); } code = Scan_Source(text, LEN_BYTES(text)); PUSH_GUARD_SERIES(code); // Bind into lib or user spaces? if (flags) { // Top words will be added to lib: Bind_Values_Set_Forward_Shallow(BLK_HEAD(code), Lib_Context); Bind_Values_Deep(BLK_HEAD(code), Lib_Context); } else { REBCNT len; REBVAL vali; REBSER *user = VAL_OBJ_FRAME(Get_System(SYS_CONTEXTS, CTX_USER)); len = user->tail; Bind_Values_All_Deep(BLK_HEAD(code), user); SET_INTEGER(&vali, len); Resolve_Context(user, Lib_Context, &vali, FALSE, 0); } if (Do_At_Throws(&out, code, 0)) { DROP_GUARD_SERIES(code); if ( IS_NATIVE(&out) && ( VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_QUIT_NATIVE) || VAL_FUNC_CODE(&out) == VAL_FUNC_CODE(ROOT_EXIT_NATIVE) ) ) { CATCH_THROWN(&out, &out); DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); *exit_status = Exit_Status_From_Value(&out); return -2; // Revisit hardcoded # } raise Error_No_Catch_For_Throw(&out); } DROP_GUARD_SERIES(code); DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state); if (result) *result = Value_To_RXI(&out); else DS_PUSH(&out); return Reb_To_RXT[VAL_TYPE(&out)]; }