char* dfsch_getcwd(){
char* buf;
DWORD len = GetCurrentDirectory(0, NULL);
if (!len){
dfsch_error("GetCurrentDirectory() returned error", NULL);
}
buf = GC_MALLOC_ATOMIC(len);
if (!GetCurrentDirectory(len, buf)){
dfsch_error("GetCurrentDirectory() returned error", NULL);
}
return buf;
}
static void file_port_batch_read_end(file_port_t* port){
if (!port->open){
dfsch_error("Port is already closed", (dfsch_object_t*)port);
}
funlockfile(port->file);
}
struct tm* dfsch_decoded_time_get_tm(dfsch_object_t* time){
if (DFSCH_TYPE_OF(time) != &decoded_time_type){
dfsch_error("Not a decoded time", time);
}
return &(((decoded_time_t*)time)->tm);
}
void dfsch_load_source(dfsch_object_t* env,
char* fname,
int toplevel,
char* source){
dfsch_parser_ctx_t *parser = dfsch_parser_create();
load_thread_info_t* lti = get_load_ti();
load_operation_t this_op;
dfsch_package_t* saved_package = dfsch_get_current_package();
dfsch_parser_callback(parser, load_source_callback, env);
dfsch_parser_set_source(parser, dfsch_make_string_cstr(fname));
dfsch_parser_eval_env(parser, env);
DFSCH_UNWIND {
this_op.fname = fname;
this_op.toplevel = toplevel;
this_op.next = lti->operation;
lti->operation = &this_op;
dfsch_parser_feed(parser, source);
} DFSCH_PROTECT {
lti->operation = this_op.next;
dfsch_set_current_package(saved_package);
} DFSCH_PROTECT_END;
if (dfsch_parser_get_level(parser)!=0){
dfsch_error("Syntax error at end of input",
dfsch_make_string_cstr(fname));
}
}
static dfsch_object_t* decoded_time_apply(decoded_time_t* time,
dfsch_object_t* args,
dfsch_tail_escape_t* esc){
dfsch_object_t* selector;
DFSCH_OBJECT_ARG(args, selector);
DFSCH_ARG_END(args);
if (dfsch_compare_keyword(selector, "sec")){
return dfsch_make_number_from_long(time->tm.tm_sec);
} else if (dfsch_compare_keyword(selector, "min")){
return dfsch_make_number_from_long(time->tm.tm_min);
} else if (dfsch_compare_keyword(selector, "hour")){
return dfsch_make_number_from_long(time->tm.tm_hour);
} else if (dfsch_compare_keyword(selector, "date")){
return dfsch_make_number_from_long(time->tm.tm_mday);
} else if (dfsch_compare_keyword(selector, "month")){
return dfsch_make_number_from_long(time->tm.tm_mon + 1);
} else if (dfsch_compare_keyword(selector, "year")){
return dfsch_make_number_from_long(time->tm.tm_year + 1900);
} else if (dfsch_compare_keyword(selector, "day")){
return dfsch_make_number_from_long(time->tm.tm_wday);
} else if (dfsch_compare_keyword(selector, "year-day")){
return dfsch_make_number_from_long(time->tm.tm_yday + 1);
} else if (dfsch_compare_keyword(selector, "dst?")){
return dfsch_bool(time->tm.tm_isdst == 1);
}
dfsch_error("Unknown field requested", selector);
}
static interpreter_t* interpreter(dfsch_object_t* obj){
interpreter_t* i = DFSCH_ASSERT_TYPE(obj, DFSCH_TCL_INTERPRETER_TYPE);
if (!i->active){
dfsch_error("Interpreter already destroyed", obj);
}
check_apartment(i);
return i;
}
static void file_port_seek(file_port_t* port, int64_t offset, int whence){
if (!port->open){
dfsch_error("Port is already closed", (dfsch_object_t*)port);
}
if (fseek(port->file, offset, whence) != 0){
dfsch_operating_system_error("fseek");
}
}
void dfsch_port_batch_read_end(dfsch_object_t* port){
if (DFSCH_TYPE_OF(port)->type == DFSCH_PORT_TYPE_TYPE){
if (((dfsch_port_type_t*)(DFSCH_TYPE_OF(port)))->batch_read_end){
((dfsch_port_type_t*)(DFSCH_TYPE_OF(port)))->batch_read_end(port);
}
} else {
dfsch_error("Not a port", port);
}
}
static void regex_compile(regex_t* regex, char* expression, int flags){
int err;
err = regcomp(regex, expression, flags);
if (err != 0){
dfsch_error("regex:error",
dfsch_make_string_cstr(regex_get_error(err, regex)));
}
}
int64_t dfsch_port_tell(dfsch_object_t* port){
if (DFSCH_TYPE_OF(port)->type == DFSCH_PORT_TYPE_TYPE){
if (((dfsch_port_type_t*)(DFSCH_TYPE_OF(port)))->tell){
return ((dfsch_port_type_t*)(DFSCH_TYPE_OF(port)))->tell(port);
} else {
return -1;
}
} else {
dfsch_error("Not a port", port);
}
}
static void default_initialize_instance(dfsch_object_t* obj,
class_t* klass,
dfsch_object_t* args){
dfsch_object_t* i = klass->initvalues;
while (DFSCH_PAIR_P(i)){
dfsch_object_t* j = DFSCH_FAST_CAR(i);
dfsch_object_t* value;
dfsch_object_t* slot;
DFSCH_OBJECT_ARG(j, value);
DFSCH_OBJECT_ARG(j, slot);
dfsch_slot_set(obj, slot, value, 1);
i = DFSCH_FAST_CDR(i);
}
while (DFSCH_PAIR_P(args)){
dfsch_object_t* keyword;
dfsch_object_t* value;
dfsch_object_t* slot;
keyword = DFSCH_FAST_CAR(args);
args = DFSCH_FAST_CDR(args);
if (!DFSCH_PAIR_P(args)){
dfsch_error("Value expected for keyword", keyword);
}
value = DFSCH_FAST_CAR(args);
args = DFSCH_FAST_CDR(args);
slot = dfsch_assq(keyword, klass->initargs);
if (!slot){
dfsch_error("Unknown keyword", keyword);
}
dfsch_slot_set(obj, dfsch_list_item(slot, 1), value, 1);
}
}
dfsch_object_t* dfsch_process_close_port(dfsch_object_t* port){
process_port_t* p = DFSCH_ASSERT_INSTANCE(port, DFSCH_PROCESS_PORT_TYPE);
int r;
if (p->open){
p->open = 0;
r = pclose(p->file);
if (r == -1){
dfsch_error("Error while closing process port",
dfsch_make_string_cstr(strerror(errno)));
}
return DFSCH_MAKE_FIXNUM(r);
}
return NULL;
}
static dfsch_slot_t* find_direct_slot(class_t* type,
char* name){
dfsch_slot_t* i = type->standard_type.slots;
if (i){
while (i->type){
if (strcmp(i->name, name)==0){
return i;
}
i++;
}
}
dfsch_error("No such slot", dfsch_make_symbol(name));
}
static int64_t file_port_tell(file_port_t* port){
off_t ret;
if (!port->open){
dfsch_error("Port is already closed", (dfsch_object_t*)port);
}
ret = ftell(port->file);
if (ret == -1){
dfsch_operating_system_error("ftell");
}
return ret;
}
static void file_port_write_buf(file_port_t* port,
char*buf, size_t len){
size_t ret;
if (!port->open){
dfsch_error("Port is closed", (dfsch_object_t*)port);
}
if (len != 0){
ret = fwrite(buf, len, 1, port->file);
if (ret == 0){
dfsch_operating_system_error("fwrite");
}
}
}
static void port_write_buf(process_port_t* port,
char*buf, size_t len){
size_t ret;
if (!port->open){
dfsch_error("Port is already closed", port);
}
if (len != 0){
ret = fwrite(buf, len, 1, port->file);
if (ret == 0){
dfsch_operating_system_error("Error writing to process port");
}
}
}
int dfsch_port_batch_read(dfsch_object_t* port){
if (DFSCH_TYPE_OF(port)->type == DFSCH_PORT_TYPE_TYPE){
if (((dfsch_port_type_t*)(DFSCH_TYPE_OF(port)))->batch_read){
return ((dfsch_port_type_t*)(DFSCH_TYPE_OF(port)))->batch_read(port);
} else {
char buf;
if (dfsch_port_read_buf(port, &buf, 1) != 1){
return -1;
} else {
return buf;
}
}
} else {
dfsch_error("Not a port", port);
}
}
static ssize_t port_read_buf(process_port_t* port,
char* buf, size_t len){
size_t ret;
if (!port->open){
dfsch_error("Port is already closed", port);
}
ret = fread(buf, 1, len, port->file);
if (ret == 0){
if (feof(port->file)){
return 0;
} else {
dfsch_operating_system_error("Error reading from process port");
}
}
return ret;
}
static ssize_t file_port_read_buf(file_port_t* port,
char* buf, size_t len){
size_t ret;
if (!port->open){
dfsch_error("Port is closed", (dfsch_object_t*)port);
}
ret = fread(buf, 1, len, port->file);
if (ret == 0){
if (feof(port->file)){
return 0;
} else {
dfsch_operating_system_error("fread");
}
}
return ret;
}
static dfsch_object_t* result_next(sqlite3_result_t* res){
char* err;
int ret;
char**values;
ret = sqlite3_step(res->stmt);
if (ret == SQLITE_ROW){
res->last_res = get_row_as_vector(res->stmt);
return res;
} else if (ret == SQLITE_BUSY) {
dfsch_error("Database is busy", (dfsch_object_t*)res->db);
} else if (ret == SQLITE_ERROR){
finalize_result(res);
return NULL;
} else {
return NULL;
}
}
static int file_port_batch_read(file_port_t* port){
int ch;
if (!port->open){
dfsch_error("Port is already closed", (dfsch_object_t*)port);
}
ch = getc_unlocked(port->file);
if (ch == EOF){
if (feof(port->file)){
return EOF;
} else {
dfsch_operating_system_error("getc_unlocked");
}
}
return ch;
}
void dfsch_provide(dfsch_object_t* env, char* name){
dfsch_object_t* modules = dfsch_env_get_cstr(env, "*load-modules*");
if (modules == DFSCH_INVALID_OBJECT){
modules = NULL;
}
if (search_modules(modules, name)){
dfsch_error("Module already provided", dfsch_make_string_cstr(name));
}
/*
* there should be define - module list is related to environment, but
* this distinction is in most cases totally irrelevant, because modules
* are mostly loaded into toplevel environment.
*/
dfsch_define_cstr(env, "*load-modules*",
dfsch_cons(dfsch_make_string_cstr(name),
modules));
}
dfsch_object_t* dfsch_tcl_split_list(char* list){
int argc;
char** argv;
int i;
dfsch_object_t* vec;
if (Tcl_SplitList(NULL, list, &argc, &argv) == TCL_ERROR){
dfsch_error("Syntax error", dfsch_make_string_cstr(list));
}
vec = dfsch_make_vector(argc, NULL);
for (i = 0; i < argc; i++){
dfsch_vector_set(vec, i, dfsch_make_string_cstr(argv[i]));
}
Tcl_Free(argv); /* both array and it's strings are in one chunk of heap */
return vec;
}
static dfsch_object_t* result_next(sqlite_result_t* res){
char* err;
int ret;
char**values;
pthread_mutex_lock(res->mutex);
ret = sqlite_step(res->vm, &res->n_columns, &values, &res->names);
if (ret == SQLITE_ROW){
res->last_res = get_row_as_vector(res->n_columns, values);
pthread_mutex_unlock(res->mutex);
return res;
} else {
pthread_mutex_unlock(res->mutex);
if (ret == SQLITE_BUSY) {
dfsch_error("Database is busy", (dfsch_object_t*)res->db);
} else if (ret == SQLITE_ERROR){
finalize_result(res);
return NULL;
} else {
return NULL;
}
}
}
static dfsch_object_t* spawn_port(dfsch_object_t* klass,
char* cmd_line){
process_port_t* p = dfsch_make_object(klass);
p->cmd_line = cmd_line;
if (klass == DFSCH_PROCESS_INPUT_PORT_TYPE){
p->file = popen(cmd_line, "r");
} else {
p->file = popen(cmd_line, "w");
}
if (!p->file){
dfsch_error("Cannot spawn process",
dfsch_make_string_cstr(strerror(errno)));
}
GC_REGISTER_FINALIZER(p, (GC_finalization_proc)port_finalizer,
NULL, NULL, NULL);
p->open = 1;
return (dfsch_object_t*)p;
}
int dfsch_regex_match_p(dfsch_object_t* regex, char* string, int flags){
if (DFSCH_TYPE_OF(regex) != ®ex_type)
dfsch_error("regex:not-a-regex", regex);
return regex_match(&(((dfsch_regex_t*)regex)->regex), string, flags);
}
static void finalize_slots_definition(class_t* klass,
dfsch_object_t* env,
dfsch_object_t* slot_definitions){
dfsch_object_t* i = slot_definitions;
while (DFSCH_PAIR_P(i)){
dfsch_object_t* slot_def = DFSCH_FAST_CAR(i);
if (DFSCH_PAIR_P(slot_def)){
dfsch_slot_t* slot =
find_direct_slot(klass,
dfsch_symbol(DFSCH_FAST_CAR(slot_def)));
slot_def = DFSCH_FAST_CDR(slot_def);
while (DFSCH_PAIR_P((slot_def))){
dfsch_object_t* keyword;
dfsch_object_t* value;
keyword = DFSCH_FAST_CAR(slot_def);
slot_def = DFSCH_FAST_CDR(slot_def);
if (!DFSCH_PAIR_P(slot_def)){
dfsch_error("Value expected for slot option", keyword);
}
value = DFSCH_FAST_CAR(slot_def);
slot_def = DFSCH_FAST_CDR(slot_def);
if(dfsch_compare_keyword(keyword, "accessor")){
dfsch_object_t* accessor =
dfsch__make_slot_accessor_for_slot(klass, slot);
dfsch_method_t* method =
dfsch_make_method(accessor, NULL, dfsch_cons(klass, NULL),
accessor);
dfsch_define_method(env, value, method);
} else if(dfsch_compare_keyword(keyword, "reader")){
dfsch_object_t* accessor =
dfsch__make_slot_reader_for_slot(klass, slot);
dfsch_method_t* method =
dfsch_make_method(accessor, NULL, dfsch_cons(klass, NULL),
accessor);
dfsch_define_method(env, value, method);
} else if(dfsch_compare_keyword(keyword, "write")){
dfsch_object_t* accessor =
dfsch__make_slot_writer_for_slot(klass, slot);
dfsch_method_t* method =
dfsch_make_method(accessor, NULL, dfsch_cons(klass, NULL),
accessor);
dfsch_define_method(env, value, method);
} else if(dfsch_compare_keyword(keyword, "initform")){
klass->initvalues = dfsch_cons(dfsch_list(2,
dfsch_eval(value, env),
slot),
klass->initvalues);
} else if(dfsch_compare_keyword(keyword, "initarg")){
klass->initargs = dfsch_cons(dfsch_list(2, value, slot),
klass->initargs);
} else if(dfsch_compare_keyword(keyword, "documentation")){
slot->documentation = dfsch_string_to_cstr(value);
}
}
}
i = DFSCH_FAST_CDR(i);
}
}
static char* read_dsz(FILE* f){
size_t len;
size_t clen;
uint32_t cksum;
unsigned char header_buf[20];
unsigned char trailer_buf[12];
unsigned char trailer_read[12];
char* cbuf;
char* payload;
if (fread(header_buf, 20, 1, f) != 1){
fclose(f);
dfsch_operating_system_error("fread");
}
if (memcmp(header_buf, "DsZ0\r\n\xff\n\0\r\x80\x7f", 12) != 0){
fclose(f);
dfsch_error("Invalid DSZ header", NULL);
}
len = (((size_t)header_buf[12]) << 24)
| (((size_t)header_buf[13]) << 16)
| (((size_t)header_buf[14]) << 8)
| (((size_t)header_buf[15]) << 0);
clen = (((size_t)header_buf[16]) << 24)
| (((size_t)header_buf[17]) << 16)
| (((size_t)header_buf[18]) << 8)
| (((size_t)header_buf[19]) << 0);
cbuf = GC_MALLOC_ATOMIC(clen);
payload = GC_MALLOC_ATOMIC(len);
if (fread(cbuf, clen, 1, f) != 1){
fclose(f);
dfsch_operating_system_error("fread");
}
if (fread(trailer_read, 12, 1, f) != 1){
fclose(f);
dfsch_operating_system_error("fread");
}
fclose(f);
if (uncompress(payload, &len, cbuf, clen) != Z_OK){
dfsch_error("Invalid DSZ payload", NULL);
}
memcpy(trailer_buf, "DsZ!", 4);
cksum = crc32(crc32(0, NULL, 0), payload, len);
trailer_buf[4] = cksum >> 24;
trailer_buf[5] = cksum >> 16;
trailer_buf[6] = cksum >> 8;
trailer_buf[7] = cksum >> 0;
cksum = crc32(crc32(0, NULL, 0), cbuf, clen);
trailer_buf[8] = cksum >> 24;
trailer_buf[9] = cksum >> 16;
trailer_buf[10] = cksum >> 8;
trailer_buf[11] = cksum >> 0;
if (memcmp(trailer_buf, trailer_read, 12) != 0){
dfsch_error("Invalid DSZ trailer", NULL);
}
return payload;
}
/**
Initialize the AES (Rijndael) block cipher
@param key The symmetric key you wish to pass
@param keylen The key length in bytes
@param num_rounds The number of rounds desired (0 for default)
@param skey The key in as scheduled by this function.
@return CRYPT_OK if successful
*/
static int aes_setup(aes_key_t* ctx,
uint8_t* key,
int keylen)
{
int i, j;
ulong32 temp, *rk;
ulong32 *rrk;
int num_rounds = 0;
if (keylen != 16 && keylen != 24 && keylen != 32) {
dfsch_error("Invalid key length", DFSCH_MAKE_FIXNUM(keylen));
}
ctx->Nr = 10 + ((keylen/8)-2)*2;
/* setup the forward key */
i = 0;
rk = ctx->eK;
LOAD32H(rk[0], key );
LOAD32H(rk[1], key + 4);
LOAD32H(rk[2], key + 8);
LOAD32H(rk[3], key + 12);
if (keylen == 16) {
j = 44;
for (;;) {
temp = rk[3];
rk[4] = rk[0] ^ setup_mix(temp) ^ rcon[i];
rk[5] = rk[1] ^ rk[4];
rk[6] = rk[2] ^ rk[5];
rk[7] = rk[3] ^ rk[6];
if (++i == 10) {
break;
}
rk += 4;
}
} else if (keylen == 24) {
j = 52;
LOAD32H(rk[4], key + 16);
LOAD32H(rk[5], key + 20);
for (;;) {
temp = rk[5];
rk[ 6] = rk[ 0] ^ setup_mix(temp) ^ rcon[i];
rk[ 7] = rk[ 1] ^ rk[ 6];
rk[ 8] = rk[ 2] ^ rk[ 7];
rk[ 9] = rk[ 3] ^ rk[ 8];
if (++i == 8) {
break;
}
rk[10] = rk[ 4] ^ rk[ 9];
rk[11] = rk[ 5] ^ rk[10];
rk += 6;
}
} else if (keylen == 32) {
j = 60;
LOAD32H(rk[4], key + 16);
LOAD32H(rk[5], key + 20);
LOAD32H(rk[6], key + 24);
LOAD32H(rk[7], key + 28);
for (;;) {
temp = rk[7];
rk[ 8] = rk[ 0] ^ setup_mix(temp) ^ rcon[i];
rk[ 9] = rk[ 1] ^ rk[ 8];
rk[10] = rk[ 2] ^ rk[ 9];
rk[11] = rk[ 3] ^ rk[10];
if (++i == 7) {
break;
}
temp = rk[11];
rk[12] = rk[ 4] ^ setup_mix(RORc(temp, 8));
rk[13] = rk[ 5] ^ rk[12];
rk[14] = rk[ 6] ^ rk[13];
rk[15] = rk[ 7] ^ rk[14];
rk += 8;
}
}
/* setup the inverse key now */
rk = ctx->dK;
rrk = ctx->eK + j - 4;
/* apply the inverse MixColumn transform to all round keys but the first and the last: */
/* copy first */
*rk++ = *rrk++;
*rk++ = *rrk++;
*rk++ = *rrk++;
*rk = *rrk;
rk -= 3; rrk -= 3;
for (i = 1; i < ctx->Nr; i++) {
rrk -= 4;
rk += 4;
temp = rrk[0];
rk[0] =
Tks0[byte(temp, 3)] ^
Tks1[byte(temp, 2)] ^
Tks2[byte(temp, 1)] ^
Tks3[byte(temp, 0)];
temp = rrk[1];
rk[1] =
Tks0[byte(temp, 3)] ^
Tks1[byte(temp, 2)] ^
Tks2[byte(temp, 1)] ^
Tks3[byte(temp, 0)];
temp = rrk[2];
rk[2] =
Tks0[byte(temp, 3)] ^
Tks1[byte(temp, 2)] ^
Tks2[byte(temp, 1)] ^
Tks3[byte(temp, 0)];
temp = rrk[3];
rk[3] =
Tks0[byte(temp, 3)] ^
Tks1[byte(temp, 2)] ^
Tks2[byte(temp, 1)] ^
Tks3[byte(temp, 0)];
}
/* copy last */
rrk -= 4;
rk += 4;
*rk++ = *rrk++;
*rk++ = *rrk++;
*rk++ = *rrk++;
*rk = *rrk;
}
void dfsch_load(dfsch_object_t* env, char* name,
dfsch_object_t* path_list,
int as_toplevel){
struct stat st;
dfsch_object_t* path;
char *pathpart;
char *fname;
str_list_t* l;
int i;
for (i = 0; i < sizeof(builtin_modules) / sizeof(builtin_module_t); i++){
if (strcmp(builtin_modules[i].name, name) == 0){
builtin_modules[i].register_proc(env);
return;
}
}
if (path_list){
path = path_list;
} else {
path = dfsch_env_get_cstr(env, "*load-path*");
if (path == DFSCH_INVALID_OBJECT){
path = NULL;
}
}
while (DFSCH_PAIR_P(path)){
dfsch_object_t* pp = DFSCH_FAST_CAR(path);
if (!dfsch_string_p(pp)){
if (dfsch_apply(pp, dfsch_list(2,
env,
dfsch_make_string_cstr(name)))){
return;
}
path = DFSCH_FAST_CDR(path);
continue;
}
l = sl_create();
sl_append(l, dfsch_string_to_cstr(DFSCH_FAST_CAR(path)));
sl_append(l, "/");
sl_append(l, name);
pathpart = sl_value(l);
if (stat(pathpart, &st) == 0){
if (S_ISREG(st.st_mode) || S_ISLNK(st.st_mode)){
for (i = 0; i < sizeof(loaders) / sizeof(module_loader_t); i++){
if (strcmp(pathpart + strlen(pathpart) - strlen(loaders[i].path_ext),
loaders[i].path_ext) == 0){
loaders[i].load(pathpart, env, as_toplevel);
return;
}
}
dfsch_load_scm(env, pathpart, 0);
return;
}
}
for (i = 0; i < sizeof(loaders) / sizeof(module_loader_t); i++){
fname = stracat(pathpart, loaders[i].path_ext);
if (stat(fname, &st) == 0 && (S_ISREG(st.st_mode) ||
S_ISLNK(st.st_mode))){
loaders[i].load(fname, env, as_toplevel);
return;
}
}
path = dfsch_cdr(path);
}
dfsch_error("Module not found", dfsch_make_string_cstr(name));
}
