mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-19 05:39:17 +02:00
7738 lines
232 KiB
C
7738 lines
232 KiB
C
/**
|
|
* Cyclone Scheme
|
|
* https://github.com/justinethier/cyclone
|
|
*
|
|
* Copyright (c) 2014-2016, Justin Ethier
|
|
* All rights reserved.
|
|
*
|
|
* This file contains the C runtime used by compiled programs.
|
|
*/
|
|
|
|
#include <ck_hs.h>
|
|
#include <ck_pr.h>
|
|
#include "cyclone/types.h"
|
|
#include "cyclone/runtime.h"
|
|
#include "cyclone/ck_ht_hash.h"
|
|
#include <errno.h>
|
|
#include <limits.h>
|
|
#include <ctype.h>
|
|
//#include <signal.h> // only used for debugging!
|
|
|
|
static uint32_t Cyc_utf8_decode(uint32_t* state, uint32_t* codep, uint32_t byte);
|
|
static int Cyc_utf8_count_code_points_and_bytes(uint8_t* s, char_type *codepoint, int *cpts, int *bytes);
|
|
|
|
object Cyc_global_set(void *thd, object * glo, object value)
|
|
{
|
|
gc_mut_update((gc_thread_data *) thd, *glo, value);
|
|
*(glo) = value;
|
|
((gc_thread_data *) thd)->globals_changed = 1;
|
|
return value;
|
|
}
|
|
|
|
/* Error checking section - type mismatch, num args, etc */
|
|
/* Type names to use for error messages */
|
|
const char *tag_names[] = {
|
|
/*closure0_tag */ "procedure"
|
|
/*closure1_tag */ , "procedure"
|
|
/*closureN_tag */ , "procedure"
|
|
/*macro_tag */ , "macro"
|
|
/*boolean_tag */ , "boolean"
|
|
/*bytevector_tag */ , "bytevector"
|
|
/*c_opaque_tag */ , "opaque"
|
|
/*cond_var_tag */ , "condition variable"
|
|
/*cvar_tag */ , "C primitive"
|
|
/*double_tag */ , "number"
|
|
/*eof_tag */ , "eof"
|
|
/*forward_tag */ , ""
|
|
/*integer_tag */ , "number"
|
|
/*bignum_tag */ , "bignum"
|
|
/*mutex_tag */ , "mutex"
|
|
/*pair_tag */ , "pair"
|
|
/*port_tag */ , "port"
|
|
/*primitive_tag */ , "primitive"
|
|
/*string_tag */ , "string"
|
|
/*symbol_tag */ , "symbol"
|
|
/*vector_tag */ , "vector"
|
|
/*complex_num_tag*/ , "complex number"
|
|
/*atomic_tag*/ , "atomic"
|
|
, "Reserved for future use"
|
|
};
|
|
|
|
void Cyc_invalid_type_error(void *data, int tag, object found)
|
|
{
|
|
char buf[256];
|
|
#if GC_DEBUG_TRACE
|
|
// Object address can be very useful for GC debugging
|
|
snprintf(buf, 255, "Invalid type: expected %s, found (%p) ", tag_names[tag], found);
|
|
#else
|
|
snprintf(buf, 255, "Invalid type: expected %s, found ", tag_names[tag]);
|
|
#endif
|
|
Cyc_rt_raise2(data, buf, found);
|
|
}
|
|
|
|
void Cyc_immutable_obj_error(void *data, object obj)
|
|
{
|
|
Cyc_rt_raise2(data, "Unable to modify immutable object ", obj);
|
|
}
|
|
|
|
void Cyc_mutable_obj_error(void *data, object obj)
|
|
{
|
|
Cyc_rt_raise2(data, "Expected immutable object ", obj);
|
|
}
|
|
|
|
void Cyc_check_obj(void *data, int tag, object obj)
|
|
{
|
|
if (!is_object_type(obj)) {
|
|
Cyc_invalid_type_error(data, tag, obj);
|
|
}
|
|
}
|
|
|
|
void Cyc_check_bounds(void *data, const char *label, int len, int index)
|
|
{
|
|
if (index < 0 || index >= len) {
|
|
char buf[128];
|
|
snprintf(buf, 127, "%s - invalid index %d", label, index);
|
|
Cyc_rt_raise_msg(data, buf);
|
|
}
|
|
}
|
|
|
|
/* END error checking */
|
|
|
|
/* These macros are hardcoded here to support functions in this module. */
|
|
#define closcall1(td, clo, a1) \
|
|
if (obj_is_not_closure(clo)) { \
|
|
Cyc_apply(td, 0, (closure)(a1), clo); \
|
|
} else { \
|
|
((clo)->fn)(td, 1, clo, a1);\
|
|
}
|
|
#define return_closcall1(td, clo, a1) { \
|
|
char top; \
|
|
if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \
|
|
object buf[1]; buf[0] = a1;\
|
|
GC(td, clo, buf, 1); \
|
|
return; \
|
|
} else {\
|
|
closcall1(td, (closure) (clo), a1); \
|
|
return;\
|
|
} \
|
|
}
|
|
#define _return_closcall1(td, clo, a1) { \
|
|
char top; \
|
|
if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \
|
|
object buf[1]; buf[0] = a1;\
|
|
GC(td, clo, buf, 1); \
|
|
return NULL; \
|
|
} else {\
|
|
closcall1(td, (closure) (clo), a1); \
|
|
return NULL;\
|
|
} \
|
|
}
|
|
#define closcall2(td, clo, a1, a2) \
|
|
if (obj_is_not_closure(clo)) { \
|
|
Cyc_apply(td, 1, (closure)(a1), clo,a2); \
|
|
} else { \
|
|
((clo)->fn)(td, 2, clo, a1, a2);\
|
|
}
|
|
#define return_closcall2(td, clo, a1, a2) { \
|
|
char top; \
|
|
if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \
|
|
object buf[2]; buf[0] = a1;buf[1] = a2;\
|
|
GC(td, clo, buf, 2); \
|
|
return; \
|
|
} else {\
|
|
closcall2(td, (closure) (clo), a1, a2); \
|
|
return;\
|
|
} \
|
|
}
|
|
#define _return_closcall2(td, clo, a1, a2) { \
|
|
char top; \
|
|
if (stack_overflow(&top, (((gc_thread_data *)data)->stack_limit))) { \
|
|
object buf[2]; buf[0] = a1;buf[1] = a2;\
|
|
GC(td, clo, buf, 2); \
|
|
return NULL; \
|
|
} else {\
|
|
closcall2(td, (closure) (clo), a1, a2); \
|
|
return NULL;\
|
|
} \
|
|
}
|
|
/*END closcall section */
|
|
|
|
/* Global variables. */
|
|
object Cyc_global_variables = NULL;
|
|
int _cyc_argc = 0;
|
|
char **_cyc_argv = NULL;
|
|
|
|
static symbol_type __EOF = { {0}, eof_tag, ""}; // symbol_type in lieu of custom type
|
|
|
|
const object Cyc_EOF = &__EOF;
|
|
static ck_hs_t lib_table;
|
|
static ck_hs_t symbol_table;
|
|
static int symbol_table_initial_size = 4096;
|
|
static pthread_mutex_t symbol_table_lock;
|
|
|
|
char **env_variables = NULL;
|
|
char **get_env_variables()
|
|
{
|
|
return env_variables;
|
|
}
|
|
|
|
void pack_env_variables(void *data, object k)
|
|
{
|
|
char **env = env_variables;
|
|
object tail;
|
|
object head = NULL;
|
|
tail = head;
|
|
for (; *env != NULL; env++) {
|
|
char *e = *env,
|
|
*eqpos = strchr(e, '=');
|
|
pair_type *p = alloca(sizeof(pair_type));
|
|
pair_type *tmp = alloca(sizeof(pair_type));
|
|
string_type *sval = alloca(sizeof(string_type));
|
|
string_type *svar = alloca(sizeof(string_type));
|
|
|
|
svar->hdr.mark = gc_color_red;
|
|
svar->hdr.grayed = 0;
|
|
svar->hdr.immutable = 0;
|
|
svar->tag = string_tag;
|
|
svar->len = eqpos - e;
|
|
svar->str = alloca(sizeof(char) * (svar->len));
|
|
strncpy(svar->str, e, svar->len);
|
|
(svar->str)[svar->len] = '\0';
|
|
svar->num_cp = Cyc_utf8_count_code_points((uint8_t *)svar->str);
|
|
|
|
if (eqpos) {
|
|
eqpos++;
|
|
}
|
|
sval->hdr.mark = gc_color_red;
|
|
sval->hdr.grayed = 0;
|
|
sval->hdr.immutable = 0;
|
|
sval->tag = string_tag;
|
|
sval->len = strlen(eqpos);
|
|
svar->num_cp = Cyc_utf8_count_code_points((uint8_t *)eqpos);
|
|
sval->str = eqpos;
|
|
set_pair(tmp, svar, sval);
|
|
set_pair(p, tmp, NULL);
|
|
if (head == NULL) {
|
|
tail = head = p;
|
|
} else {
|
|
cdr(tail) = p;
|
|
tail = p;
|
|
}
|
|
}
|
|
return_closcall1(data, k, head);
|
|
}
|
|
|
|
void set_env_variables(char **vars)
|
|
{
|
|
env_variables = vars;
|
|
}
|
|
|
|
// Functions to support concurrency kit hashset
|
|
// These are specifically for a table of symbols
|
|
static void *hs_malloc(size_t r)
|
|
{
|
|
return malloc(r);
|
|
}
|
|
|
|
static void hs_free(void *p, size_t b, bool r)
|
|
{
|
|
free(p);
|
|
}
|
|
|
|
static struct ck_malloc my_allocator = {
|
|
.malloc = hs_malloc,
|
|
.free = hs_free
|
|
};
|
|
|
|
static unsigned long hs_hash(const void *object, unsigned long seed)
|
|
{
|
|
const symbol_type *c = object;
|
|
unsigned long h;
|
|
|
|
h = (unsigned long)MurmurHash64A(c->desc, strlen(c->desc), seed);
|
|
return h;
|
|
}
|
|
|
|
static bool hs_compare(const void *previous, const void *compare)
|
|
{
|
|
return strcmp(symbol_desc(previous), symbol_desc(compare)) == 0;
|
|
}
|
|
|
|
static void *set_get(ck_hs_t * hs, const void *value)
|
|
{
|
|
unsigned long h;
|
|
void *v;
|
|
|
|
h = CK_HS_HASH(hs, hs_hash, value);
|
|
v = ck_hs_get(hs, h, value);
|
|
return v;
|
|
}
|
|
|
|
static bool set_insert(ck_hs_t * hs, const void *value)
|
|
{
|
|
unsigned long h;
|
|
|
|
h = CK_HS_HASH(hs, hs_hash, value);
|
|
return ck_hs_put(hs, h, value);
|
|
}
|
|
// End hashset supporting functions
|
|
|
|
/**
|
|
* @brief Perform one-time heap initializations for the program
|
|
* @param heap_size Unused
|
|
*/
|
|
void gc_init_heap(long heap_size)
|
|
{
|
|
if (!ck_hs_init(&lib_table,
|
|
CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
|
|
hs_hash, hs_compare,
|
|
&my_allocator, 32, 43423)) {
|
|
fprintf(stderr, "Unable to initialize library table\n");
|
|
exit(1);
|
|
}
|
|
if (!ck_hs_init(&symbol_table,
|
|
CK_HS_MODE_OBJECT | CK_HS_MODE_SPMC,
|
|
hs_hash, hs_compare,
|
|
&my_allocator, symbol_table_initial_size, 43423)) {
|
|
fprintf(stderr, "Unable to initialize symbol table\n");
|
|
exit(1);
|
|
}
|
|
if (pthread_mutex_init(&(symbol_table_lock), NULL) != 0) {
|
|
fprintf(stderr, "Unable to initialize symbol_table_lock mutex\n");
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
object cell_get(object cell)
|
|
{
|
|
// Always use unsafe car here, since cell_get calls are computed by compiler
|
|
return car(cell);
|
|
}
|
|
|
|
static boolean_type t_boolean = { {0}, boolean_tag, "t" };
|
|
static boolean_type f_boolean = { {0}, boolean_tag, "f" };
|
|
static symbol_type Cyc_void_symbol = { {0}, symbol_tag, ""};
|
|
|
|
const object boolean_t = &t_boolean;
|
|
const object boolean_f = &f_boolean;
|
|
const object quote_void = &Cyc_void_symbol;
|
|
|
|
/* Stack Traces */
|
|
|
|
/**
|
|
* @brief Print the contents of the given thread's stack trace buffer.
|
|
* @param data Thread data object
|
|
* @param out Output stream
|
|
*/
|
|
void Cyc_st_print(void *data, FILE * out)
|
|
{
|
|
/* print to stream, note it is possible that
|
|
some traces could be on the stack after a GC.
|
|
not sure what to do about it, may need to
|
|
detect that case and stop printing.
|
|
or, with the tbl being so small, maybe it will
|
|
not be an issue in practice? a bit risky to ignore though
|
|
*/
|
|
gc_thread_data *thd = (gc_thread_data *) data;
|
|
int i = (thd->stack_trace_idx + 1) % MAX_STACK_TRACES;
|
|
while (i != thd->stack_trace_idx) {
|
|
if (thd->stack_traces[i]) {
|
|
fprintf(out, "%s\n", thd->stack_traces[i]);
|
|
}
|
|
i = (i + 1) % MAX_STACK_TRACES;
|
|
}
|
|
}
|
|
|
|
/* END Stack Traces section */
|
|
|
|
/* Symbol Table */
|
|
|
|
/* Notes for the symbol table
|
|
|
|
string->symbol can:
|
|
- lookup symbol in the table
|
|
- if found, return that pointer
|
|
- otherwise, allocate symbol in table and return ptr to it
|
|
|
|
For now, GC of symbols is missing. long-term it probably would be desirable
|
|
*/
|
|
static char *_strdup(const char *s)
|
|
{
|
|
char *d = malloc(strlen(s) + 1);
|
|
if (d) {
|
|
strcpy(d, s);
|
|
}
|
|
return d;
|
|
}
|
|
|
|
static object find_symbol_by_name(const char *name)
|
|
{
|
|
symbol_type tmp = { {0}, symbol_tag, name};
|
|
object result = set_get(&symbol_table, &tmp);
|
|
return result;
|
|
}
|
|
|
|
object add_symbol(symbol_type * psym)
|
|
{
|
|
pthread_mutex_lock(&symbol_table_lock); // Only 1 "writer" allowed
|
|
set_insert(&symbol_table, psym);
|
|
pthread_mutex_unlock(&symbol_table_lock);
|
|
return psym;
|
|
}
|
|
|
|
static object add_symbol_by_name(const char *name)
|
|
{
|
|
symbol_type sym = { {0}, symbol_tag, _strdup(name)};
|
|
symbol_type *psym = malloc(sizeof(symbol_type));
|
|
memcpy(psym, &sym, sizeof(symbol_type));
|
|
return add_symbol(psym);
|
|
}
|
|
|
|
object find_or_add_symbol(const char *name)
|
|
{
|
|
object sym = find_symbol_by_name(name);
|
|
if (sym) {
|
|
return sym;
|
|
} else {
|
|
return add_symbol_by_name(name);
|
|
}
|
|
}
|
|
|
|
/* END symbol table */
|
|
|
|
/* Library table */
|
|
object is_library_loaded(const char *name)
|
|
{
|
|
symbol_type tmp = { {0}, symbol_tag, name};
|
|
object result = set_get(&lib_table, &tmp);
|
|
if (result)
|
|
return boolean_t;
|
|
return boolean_f;
|
|
}
|
|
|
|
object register_library(const char *name)
|
|
{
|
|
symbol_type sym = { {0}, symbol_tag, _strdup(name)};
|
|
symbol_type *psym = malloc(sizeof(symbol_type));
|
|
memcpy(psym, &sym, sizeof(symbol_type));
|
|
// Reuse mutex since lib inserts will be rare
|
|
pthread_mutex_lock(&symbol_table_lock); // Only 1 "writer" allowed
|
|
set_insert(&lib_table, psym);
|
|
pthread_mutex_unlock(&symbol_table_lock);
|
|
return boolean_t;
|
|
}
|
|
/* END Library table */
|
|
|
|
|
|
/* Global table */
|
|
list global_table = NULL;
|
|
|
|
void add_global(object * glo)
|
|
{
|
|
// It would probably be more efficient to allocate
|
|
// a contiguous block of memory for this... for now
|
|
// this is more expedient
|
|
global_table = malloc_make_pair(mcvar(glo), global_table);
|
|
}
|
|
|
|
void debug_dump_globals()
|
|
{
|
|
list l = global_table;
|
|
for (; l != NULL; l = cdr(l)) {
|
|
cvar_type *c = (cvar_type *) car(l);
|
|
//gc_mark(h, *(c->pvar)); // Mark actual object the global points to
|
|
printf("DEBUG %p ", c->pvar);
|
|
if (*c->pvar) {
|
|
printf("mark = %d ", mark(*c->pvar));
|
|
if (mark(*c->pvar) == gc_color_red) {
|
|
printf("obj = ");
|
|
// TODO: no data param: Cyc_display(*c->pvar, stdout);
|
|
}
|
|
printf("\n");
|
|
} else {
|
|
printf(" is NULL\n");
|
|
}
|
|
}
|
|
}
|
|
|
|
void Cyc_set_globals_changed(gc_thread_data *thd)
|
|
{
|
|
thd->globals_changed = 1;
|
|
}
|
|
|
|
/* END Global table */
|
|
|
|
/* Mutation table functions
|
|
*
|
|
* Keep track of mutations (EG: set-car!) so we can avoid having heap
|
|
* objects that point to old stack objects. We need to transport any
|
|
* such stack objects to the heap during minor GC.
|
|
*
|
|
* Note these functions and underlying data structure are only used by
|
|
* the calling thread, so locking is not required.
|
|
*/
|
|
void add_mutation(void *data, object var, int index, object value)
|
|
{
|
|
gc_thread_data *thd = (gc_thread_data *) data;
|
|
char tmp;
|
|
|
|
// No need to track for minor GC purposes unless we are mutating
|
|
// a heap variable to point to a stack var.
|
|
//
|
|
// If var is on stack we'll get it anyway in minor GC,
|
|
// and if value is on heap we don't care (no chance of heap pointing to nursery)
|
|
if (!gc_is_stack_obj(&tmp, data, var) && gc_is_stack_obj(&tmp, data, value)) {
|
|
thd->mutations = vpbuffer_add(thd->mutations,
|
|
&(thd->mutation_buflen),
|
|
thd->mutation_count,
|
|
var);
|
|
thd->mutation_count++;
|
|
if (index >= 0) {
|
|
// For vectors only, add index as another var. That way
|
|
// the write barrier only needs to inspect the mutated index.
|
|
thd->mutations = vpbuffer_add(thd->mutations,
|
|
&(thd->mutation_buflen),
|
|
thd->mutation_count,
|
|
obj_int2obj(index));
|
|
thd->mutation_count++;
|
|
}
|
|
}
|
|
}
|
|
|
|
void clear_mutations(void *data)
|
|
{
|
|
// Not clearing memory, just resetting count
|
|
gc_thread_data *thd = (gc_thread_data *) data;
|
|
thd->mutation_count = 0;
|
|
}
|
|
|
|
/* END mutation table */
|
|
|
|
/* Runtime globals */
|
|
object Cyc_glo_call_cc = NULL;
|
|
object Cyc_glo_eval_from_c = NULL;
|
|
|
|
/**
|
|
* @brief The default exception handler
|
|
* @param data Thread data object
|
|
* @return argc Unused, just here to maintain calling convention
|
|
* @return _ Unused, just here to maintain calling convention
|
|
* @return err Object containing data for the error
|
|
*/
|
|
object Cyc_default_exception_handler(void *data, int argc, closure _,
|
|
object err)
|
|
{
|
|
int is_msg = 1;
|
|
fprintf(stderr, "Error: ");
|
|
|
|
if ((err == NULL) || is_value_type(err) || type_of(err) != pair_tag) {
|
|
Cyc_display(data, err, stderr);
|
|
} else {
|
|
// Error is list of form (type arg1 ... argn)
|
|
err = cdr(err); // skip type field
|
|
for (; (err != NULL); err = cdr(err)) { // output with no enclosing parens
|
|
if (is_msg &&
|
|
is_object_type(car(err)) &&
|
|
type_of(car(err)) == string_tag) {
|
|
is_msg = 0;
|
|
Cyc_display(data, car(err), stderr);
|
|
if (cdr(err)) {
|
|
fprintf(stderr, ": ");
|
|
}
|
|
} else {
|
|
Cyc_write(data, car(err), stderr);
|
|
fprintf(stderr, " ");
|
|
}
|
|
}
|
|
}
|
|
|
|
fprintf(stderr, "\nCall history:\n");
|
|
Cyc_st_print(data, stderr);
|
|
fprintf(stderr, "\n");
|
|
//raise(SIGINT); // break into debugger, unix only
|
|
exit(1);
|
|
return NULL;
|
|
}
|
|
|
|
/**
|
|
* @brief Return the current exception handler
|
|
* @param data Thread data object
|
|
* @return Object registered as the exception handler, or the default if none.
|
|
*/
|
|
object Cyc_current_exception_handler(void *data)
|
|
{
|
|
gc_thread_data *thd = (gc_thread_data *) data;
|
|
if (thd->exception_handler_stack == NULL) {
|
|
return primitive_Cyc_91default_91exception_91handler;
|
|
} else {
|
|
return car(thd->exception_handler_stack);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Raise an exception from the runtime code
|
|
* @param data Thread data object
|
|
* @param err Data for the error
|
|
*/
|
|
void Cyc_rt_raise(void *data, object err)
|
|
{
|
|
make_pair(c2, err, NULL);
|
|
make_pair(c1, boolean_f, &c2);
|
|
make_pair(c0, &c1, NULL);
|
|
apply(data, NULL, Cyc_current_exception_handler(data), &c0);
|
|
// Should never get here
|
|
fprintf(stderr, "Internal error in Cyc_rt_raise\n");
|
|
exit(1);
|
|
}
|
|
|
|
/**
|
|
* @brief Raise an exception from the runtime code
|
|
* @param data Thread data object
|
|
* @param msg A message describing the error
|
|
* @param err Data for the error
|
|
*/
|
|
void Cyc_rt_raise2(void *data, const char *msg, object err)
|
|
{
|
|
make_utf8_string(data, s, msg);
|
|
make_pair(c3, err, NULL);
|
|
make_pair(c2, &s, &c3);
|
|
make_pair(c1, boolean_f, &c2);
|
|
make_pair(c0, &c1, NULL);
|
|
apply(data, NULL, Cyc_current_exception_handler(data), &c0);
|
|
// Should never get here
|
|
fprintf(stderr, "Internal error in Cyc_rt_raise2\n");
|
|
exit(1);
|
|
}
|
|
|
|
/**
|
|
* @brief Raise an exception from the runtime code
|
|
* @param data Thread data object
|
|
* @param err A message describing the error
|
|
*/
|
|
void Cyc_rt_raise_msg(void *data, const char *err)
|
|
{
|
|
make_utf8_string(data, s, err);
|
|
Cyc_rt_raise(data, &s);
|
|
}
|
|
|
|
/* END exception handler */
|
|
|
|
int equal(object x, object y)
|
|
{
|
|
if (x == y)
|
|
return 1;
|
|
if (x == NULL)
|
|
return (y == NULL);
|
|
if (y == NULL)
|
|
return (x == NULL);
|
|
if (obj_is_char(x))
|
|
return obj_is_char(y) && x == y;
|
|
if (obj_is_int(x))
|
|
return (obj_is_int(y) && x == y) ||
|
|
(is_object_type(y) &&
|
|
(
|
|
(type_of(y) == integer_tag && integer_value(y) == obj_obj2int(x)) ||
|
|
(type_of(y) == bignum_tag && Cyc_bignum_cmp(MP_EQ, x, -1, y, bignum_tag))
|
|
));
|
|
switch (type_of(x)) {
|
|
case string_tag:
|
|
return (is_object_type(y) &&
|
|
type_of(y) == string_tag &&
|
|
strcmp(((string_type *) x)->str, ((string_type *) y)->str) == 0);
|
|
case double_tag:
|
|
return (is_object_type(y) &&
|
|
type_of(y) == double_tag &&
|
|
((double_type *) x)->value == ((double_type *) y)->value);
|
|
case vector_tag:
|
|
if (is_object_type(y) &&
|
|
type_of(y) == vector_tag &&
|
|
((vector) x)->num_elements == ((vector) y)->num_elements) {
|
|
int i;
|
|
if (x == y) return 1;
|
|
for (i = 0; i < ((vector) x)->num_elements; i++) {
|
|
if (equalp(((vector) x)->elements[i], ((vector) y)->elements[i]) ==
|
|
boolean_f)
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
return 0;
|
|
case bytevector_tag:
|
|
if (is_object_type(y) &&
|
|
type_of(y) == bytevector_tag &&
|
|
((bytevector) x)->len == ((bytevector) y)->len) {
|
|
int i;
|
|
for (i = 0; i < ((bytevector) x)->len; i++) {
|
|
if (((bytevector)x)->data[i] != ((bytevector)y)->data[i]) {
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
return 0;
|
|
case bignum_tag: {
|
|
int ty = -1;
|
|
if (is_value_type(y)) {
|
|
if (!obj_is_int(y)) {
|
|
return 0;
|
|
}
|
|
} else {
|
|
ty = type_of(y);
|
|
}
|
|
|
|
return Cyc_bignum_cmp(MP_EQ, x, bignum_tag, y, ty);
|
|
// return (is_object_type(y) &&
|
|
// type_of(y) == bignum_tag &&
|
|
// MP_EQ == mp_cmp(&bignum_value(x), &bignum_value(y)));
|
|
}
|
|
//case integer_tag:
|
|
// return (obj_is_int(y) && obj_obj2int(y) == integer_value(x)) ||
|
|
// (is_object_type(y) &&
|
|
// type_of(y) == integer_tag &&
|
|
// ((integer_type *) x)->value == ((integer_type *) y)->value);
|
|
case complex_num_tag:
|
|
return (is_object_type(y) &&
|
|
type_of(y) == complex_num_tag &&
|
|
((complex_num_type *) x)->value == ((complex_num_type *) y)->value);
|
|
|
|
default:
|
|
return x == y;
|
|
}
|
|
}
|
|
|
|
//object Cyc_car(void *data, object lis)
|
|
//{
|
|
// Cyc_check_pair(data, lis);
|
|
// return car(lis);
|
|
//}
|
|
//
|
|
//object Cyc_cdr(void *data, object lis)
|
|
//{
|
|
// Cyc_check_pair(data, lis);
|
|
// return cdr(lis);
|
|
//}
|
|
|
|
object Cyc_get_global_variables()
|
|
{
|
|
return Cyc_global_variables;
|
|
}
|
|
|
|
object Cyc_get_cvar(object var)
|
|
{
|
|
if (is_object_type(var) && type_of(var) == cvar_tag) {
|
|
return *(((cvar_type *) var)->pvar);
|
|
}
|
|
return var;
|
|
}
|
|
|
|
object Cyc_set_cvar(object var, object value)
|
|
{
|
|
if (is_object_type(var) && type_of(var) == cvar_tag) {
|
|
*(((cvar_type *) var)->pvar) = value;
|
|
}
|
|
return var;
|
|
}
|
|
|
|
object Cyc_has_vector_cycle(object vec)
|
|
{
|
|
int i;
|
|
// TODO: this is not generic enough
|
|
for (i = 0; i < ((vector)vec)->num_elements; i++) {
|
|
if (((vector)vec)->elements[i] == vec) {
|
|
return boolean_t;
|
|
}
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
object Cyc_has_cycle(object lst)
|
|
{
|
|
object slow_lst, fast_lst;
|
|
if ((lst == NULL) || is_value_type(lst)) {
|
|
return boolean_f;
|
|
} else if (is_object_type(lst) && type_of(lst) == vector_tag) {
|
|
return Cyc_has_vector_cycle(lst);
|
|
} else if (is_object_type(lst) && type_of(lst) != pair_tag) {
|
|
return boolean_f;
|
|
}
|
|
slow_lst = lst;
|
|
fast_lst = cdr(lst);
|
|
while (1) {
|
|
if (fast_lst == NULL)
|
|
return boolean_f;
|
|
if (Cyc_is_pair(fast_lst) == boolean_f)
|
|
return boolean_f;
|
|
if ((cdr(fast_lst)) == NULL)
|
|
return boolean_f;
|
|
if (Cyc_is_pair(cdr(fast_lst)) == boolean_f)
|
|
return boolean_f;
|
|
if (slow_lst == fast_lst)
|
|
return boolean_t;
|
|
|
|
slow_lst = cdr(slow_lst);
|
|
fast_lst = cddr(fast_lst);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* Predicate - is the object a proper list?
|
|
* Based on `Cyc_has_cycle` so it is safe to call on circular lists.
|
|
*/
|
|
object Cyc_is_list(object lst)
|
|
{
|
|
object slow_lst, fast_lst;
|
|
if ((lst == NULL)){
|
|
return boolean_t;
|
|
} else if (is_value_type(lst)) {
|
|
return boolean_f;
|
|
} else if (is_object_type(lst) && type_of(lst) != pair_tag) {
|
|
return boolean_f;
|
|
}
|
|
slow_lst = lst;
|
|
fast_lst = cdr(lst);
|
|
while (1) {
|
|
if (fast_lst == NULL)
|
|
return boolean_t;
|
|
if (Cyc_is_pair(fast_lst) == boolean_f)
|
|
return boolean_f; // Improper list
|
|
if ((cdr(fast_lst)) == NULL)
|
|
return boolean_t;
|
|
if (Cyc_is_pair(cdr(fast_lst)) == boolean_f)
|
|
return boolean_f; // Improper
|
|
if (slow_lst == fast_lst)
|
|
return boolean_t; // Cycle; we have a list
|
|
|
|
slow_lst = cdr(slow_lst);
|
|
fast_lst = cddr(fast_lst);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* Write string representation of a double to a buffer.
|
|
* Added code from Chibi Scheme to print a ".0" if the
|
|
* double is a whole number (EG: 3.0) to avoid confusion
|
|
* in the output (EG: was "3").
|
|
*/
|
|
int double2buffer(char *buf, int buf_size, double num)
|
|
{
|
|
int i;
|
|
i = snprintf(buf, buf_size, "%.15g", num);
|
|
if (!strchr(buf, '.') && !strchr(buf, 'e')) {
|
|
buf[i++] = '.';
|
|
buf[i++] = '0';
|
|
buf[i++] = '\0';
|
|
}
|
|
return i;
|
|
}
|
|
|
|
// TODO: need to change I/O functions (including display/write below)
|
|
// to accept an optional port arg. also, if port is not specified, should
|
|
// use (current-output-port) instead of stdout. will need to expose the
|
|
// (current-*port) functions somehow (tricky since we do not have param
|
|
// object yet) then figure out how to use them.
|
|
//
|
|
// If port is omitted from any output procedure, it defaults
|
|
// to the value returned by (current-output-port). It is an
|
|
// error to attempt an output operation on a closed port
|
|
//
|
|
void dispatch_display_va(void *data, int argc, object clo, object cont,
|
|
object x, ...)
|
|
{
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_display_va_list(data, argc - 1, x, ap);
|
|
va_end(ap);
|
|
return_closcall1(data, cont, result);
|
|
}
|
|
|
|
object Cyc_display_va(void *data, int argc, object x, ...)
|
|
{
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_display_va_list(data, argc, x, ap);
|
|
va_end(ap);
|
|
return result;
|
|
}
|
|
|
|
object Cyc_display_va_list(void *data, int argc, object x, va_list ap)
|
|
{
|
|
FILE *fp = stdout; // TODO: just a placeholder, should use current-output-port
|
|
if (argc > 1) {
|
|
object tmp;
|
|
tmp = va_arg(ap, object);
|
|
Cyc_check_port(data, tmp);
|
|
fp = ((port_type *) tmp)->fp;
|
|
if (fp == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to write to closed port: ", tmp);
|
|
return quote_void;
|
|
}
|
|
}
|
|
return Cyc_display(data, x, fp);
|
|
}
|
|
|
|
object Cyc_display(void *data, object x, FILE * port)
|
|
{
|
|
object tmp = NULL;
|
|
object has_cycle = boolean_f;
|
|
int i = 0;
|
|
if (x == NULL) {
|
|
fprintf(port, "()");
|
|
return quote_void;
|
|
}
|
|
if (obj_is_char(x)) {
|
|
char cbuf[5];
|
|
char_type unbox = obj_obj2char(x);
|
|
Cyc_utf8_encode_char(cbuf, 5, unbox);
|
|
fprintf(port, "%s", cbuf);
|
|
return quote_void;
|
|
}
|
|
if (obj_is_int(x)) {
|
|
fprintf(port, "%ld", obj_obj2int(x));
|
|
return quote_void;
|
|
}
|
|
switch (type_of(x)) {
|
|
case macro_tag:
|
|
fprintf(port, "<macro %p>", (void *)((closure) x)->fn);
|
|
break;
|
|
case closure0_tag:
|
|
case closure1_tag:
|
|
case closureN_tag:
|
|
fprintf(port, "<procedure %p>", (void *)((closure) x)->fn);
|
|
break;
|
|
case eof_tag:
|
|
fprintf(port, "<EOF>");
|
|
break;
|
|
case port_tag:
|
|
fprintf(port, "<port %p>", ((port_type *) x)->fp);
|
|
break;
|
|
case primitive_tag:
|
|
fprintf(port, "<primitive %s>", prim_name(x));
|
|
break;
|
|
case cvar_tag:
|
|
fprintf(port, "<cvar %p>", Cyc_get_cvar(x));
|
|
break;
|
|
case c_opaque_tag:
|
|
fprintf(port, "<C opaque %p>", opaque_ptr(x));
|
|
break;
|
|
case mutex_tag:
|
|
fprintf(port, "<mutex %p>", x);
|
|
break;
|
|
case cond_var_tag:
|
|
fprintf(port, "<condition variable %p>", x);
|
|
break;
|
|
case atomic_tag:
|
|
fprintf(port, "<atom %p>", x);
|
|
break;
|
|
case boolean_tag:
|
|
fprintf(port, "#%s", ((boolean_type *) x)->desc);
|
|
break;
|
|
case symbol_tag:
|
|
fprintf(port, "%s", ((symbol_type *) x)->desc);
|
|
break;
|
|
case integer_tag:
|
|
fprintf(port, "%d", ((integer_type *) x)->value);
|
|
break;
|
|
case double_tag: {
|
|
char buf[33];
|
|
double2buffer(buf, 32, ((double_type *) x)->value);
|
|
fprintf(port, "%s", buf);
|
|
break;
|
|
}
|
|
case string_tag:
|
|
fprintf(port, "%s", ((string_type *) x)->str);
|
|
break;
|
|
case vector_tag:
|
|
has_cycle = Cyc_has_cycle(x);
|
|
fprintf(port, "#(");
|
|
if (has_cycle == boolean_t) {
|
|
fprintf(port, "...");
|
|
} else {
|
|
for (i = 0; i < ((vector) x)->num_elements; i++) {
|
|
if (i > 0) {
|
|
fprintf(port, " ");
|
|
}
|
|
Cyc_display(data, ((vector) x)->elements[i], port);
|
|
}
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
case bytevector_tag:
|
|
fprintf(port, "#u8(");
|
|
for (i = 0; i < ((bytevector) x)->len; i++) {
|
|
if (i > 0) {
|
|
fprintf(port, " ");
|
|
}
|
|
fprintf(port, "%u", (unsigned char)(((bytevector) x)->data[i]));
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
case pair_tag:
|
|
has_cycle = Cyc_has_cycle(x);
|
|
fprintf(port, "(");
|
|
Cyc_display(data, car(x), port);
|
|
|
|
// Experimenting with displaying lambda defs in REPL
|
|
// not good enough but this is a start. would probably need
|
|
// the same code in write()
|
|
if (Cyc_is_symbol(car(x)) == boolean_t &&
|
|
strncmp(((symbol) car(x))->desc, "procedure", 10) == 0) {
|
|
fprintf(port, " ");
|
|
Cyc_display(data, cadr(x), port);
|
|
fprintf(port, " ...)"); /* skip body and env for now */
|
|
break;
|
|
}
|
|
|
|
for (tmp = cdr(x); Cyc_is_pair(tmp) == boolean_t; tmp = cdr(tmp)) {
|
|
if (has_cycle == boolean_t) {
|
|
if (i++ > 20)
|
|
break; /* arbitrary number, for now */
|
|
}
|
|
fprintf(port, " ");
|
|
Cyc_display(data, car(tmp), port);
|
|
}
|
|
if (has_cycle == boolean_t) {
|
|
fprintf(port, " ...");
|
|
} else if (tmp) {
|
|
fprintf(port, " . ");
|
|
Cyc_display(data, tmp, port);
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
case bignum_tag: {
|
|
int bufsz;
|
|
char *buf;
|
|
|
|
// TODO: check return value
|
|
mp_radix_size(&bignum_value(x), 10, &bufsz);
|
|
|
|
buf = alloca(bufsz);
|
|
// TODO: check return value
|
|
mp_toradix_n(&bignum_value(x), buf, 10, bufsz);
|
|
fprintf(port, "%s", buf);
|
|
break;
|
|
}
|
|
case complex_num_tag: {
|
|
char rbuf[33], ibuf[33];
|
|
const char *plus="+", *empty="";
|
|
double dreal = creal(((complex_num_type *) x)->value);
|
|
double dimag = cimag(((complex_num_type *) x)->value);
|
|
double2buffer(rbuf, 32, dreal);
|
|
double2buffer(ibuf, 32, dimag);
|
|
if (dreal == 0.0) {
|
|
fprintf(port, "%si", ibuf);
|
|
} else {
|
|
fprintf(port, "%s%s%si",
|
|
rbuf,
|
|
(dimag < 0.0) ? empty : plus,
|
|
ibuf);
|
|
}
|
|
break;
|
|
}
|
|
default:
|
|
fprintf(port, "Cyc_display: bad tag x=%d\n", ((closure) x)->tag);
|
|
exit(1);
|
|
}
|
|
return quote_void;
|
|
}
|
|
|
|
void dispatch_write_va(void *data, int argc, object clo, object cont,
|
|
object x, ...)
|
|
{
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_write_va_list(data, argc - 1, x, ap);
|
|
va_end(ap);
|
|
return_closcall1(data, cont, result);
|
|
}
|
|
|
|
object Cyc_write_va(void *data, int argc, object x, ...)
|
|
{
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_write_va_list(data, argc, x, ap);
|
|
va_end(ap);
|
|
return result;
|
|
}
|
|
|
|
object Cyc_write_va_list(void *data, int argc, object x, va_list ap)
|
|
{
|
|
FILE *fp = stdout; // OK since this is the internal version of write
|
|
// Longer-term maybe we get rid of varargs for this one
|
|
if (argc > 1) {
|
|
object tmp;
|
|
tmp = va_arg(ap, object);
|
|
Cyc_check_port(data, tmp);
|
|
fp = ((port_type *) tmp)->fp;
|
|
if (fp == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to write to closed port: ", tmp);
|
|
return quote_void;
|
|
}
|
|
}
|
|
return Cyc_write(data, x, fp);
|
|
}
|
|
|
|
static object _Cyc_write(void *data, object x, FILE * port)
|
|
{
|
|
object tmp = NULL;
|
|
object has_cycle = boolean_f;
|
|
int i = 0;
|
|
if (x == NULL) {
|
|
fprintf(port, "()");
|
|
return quote_void;
|
|
}
|
|
if (obj_is_char(x)) {
|
|
char_type c = obj_obj2char(x);
|
|
switch (c) {
|
|
case 0: fprintf(port, "#\\null"); break;
|
|
case 7: fprintf(port, "#\\alarm"); break;
|
|
case 8: fprintf(port, "#\\backspace"); break;
|
|
case 9: fprintf(port, "#\\tab"); break;
|
|
case 10: fprintf(port, "#\\newline"); break;
|
|
case 13: fprintf(port, "#\\return"); break;
|
|
case 27: fprintf(port, "#\\escape"); break;
|
|
case 32: fprintf(port, "#\\space"); break;
|
|
case 127: fprintf(port, "#\\delete"); break;
|
|
default: {
|
|
char cbuf[5];
|
|
Cyc_utf8_encode_char(cbuf, 5, c);
|
|
fprintf(port, "#\\%s", cbuf);
|
|
break;
|
|
}
|
|
}
|
|
return quote_void;
|
|
}
|
|
if (obj_is_int(x)) {
|
|
Cyc_display(data, x, port);
|
|
return quote_void;
|
|
}
|
|
switch (type_of(x)) {
|
|
case string_tag: {
|
|
//fprintf(port, "\"%s\"", ((string_type *) x)->str);
|
|
char *s = string_str(x);
|
|
fputc('"', port);
|
|
while (*s){
|
|
switch(*s){
|
|
case '\a': fprintf(port, "\\a"); break;
|
|
case '\b': fprintf(port, "\\b"); break;
|
|
case '\f': fprintf(port, "\\f"); break;
|
|
case '\n': fprintf(port, "\\n"); break;
|
|
case '\r': fprintf(port, "\\r"); break;
|
|
case '\t': fprintf(port, "\\t"); break;
|
|
case '\v': fprintf(port, "\\v"); break;
|
|
case '\\': fprintf(port, "\\\\"); break;
|
|
case '\"': fprintf(port, "\\\""); break;
|
|
default:
|
|
fputc(*s, port);
|
|
break;
|
|
}
|
|
s++;
|
|
}
|
|
fputc('"', port);
|
|
break;
|
|
}
|
|
case vector_tag:
|
|
has_cycle = Cyc_has_cycle(x);
|
|
fprintf(port, "#(");
|
|
if (has_cycle == boolean_t) {
|
|
fprintf(port, "...");
|
|
} else {
|
|
for (i = 0; i < ((vector) x)->num_elements; i++) {
|
|
if (i > 0) {
|
|
fprintf(port, " ");
|
|
}
|
|
_Cyc_write(data, ((vector) x)->elements[i], port);
|
|
}
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
case pair_tag:
|
|
has_cycle = Cyc_has_cycle(x);
|
|
fprintf(port, "(");
|
|
_Cyc_write(data, car(x), port);
|
|
|
|
// Experimenting with displaying lambda defs in REPL
|
|
// not good enough but this is a start. would probably need
|
|
// the same code in write()
|
|
if (Cyc_is_symbol(car(x)) == boolean_t &&
|
|
strncmp(((symbol) car(x))->desc, "procedure", 10) == 0) {
|
|
fprintf(port, " ");
|
|
_Cyc_write(data, cadr(x), port);
|
|
fprintf(port, " ...)"); /* skip body and env for now */
|
|
break;
|
|
}
|
|
|
|
for (tmp = cdr(x); Cyc_is_pair(tmp) == boolean_t; tmp = cdr(tmp)) {
|
|
if (has_cycle == boolean_t) {
|
|
if (i++ > 20)
|
|
break; /* arbitrary number, for now */
|
|
}
|
|
fprintf(port, " ");
|
|
_Cyc_write(data, car(tmp), port);
|
|
}
|
|
if (has_cycle == boolean_t) {
|
|
fprintf(port, " ...");
|
|
} else if (tmp) {
|
|
fprintf(port, " . ");
|
|
_Cyc_write(data, tmp, port);
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
default:
|
|
Cyc_display(data, x, port);
|
|
}
|
|
return quote_void;
|
|
}
|
|
|
|
object Cyc_write(void *data, object x, FILE * port)
|
|
{
|
|
object y = _Cyc_write(data, x, port);
|
|
//fprintf(port, "\n");
|
|
return y;
|
|
}
|
|
|
|
object Cyc_write_char(void *data, object c, object port)
|
|
{
|
|
Cyc_check_port(data, port);
|
|
if (obj_is_char(c)) {
|
|
FILE *fp = ((port_type *) port)->fp;
|
|
if (fp){
|
|
char cbuf[5];
|
|
char_type unbox = obj_obj2char(c);
|
|
Cyc_utf8_encode_char(cbuf, 5, unbox);
|
|
fprintf(fp, "%s", cbuf);
|
|
}
|
|
} else {
|
|
Cyc_rt_raise2(data, "Argument is not a character", c);
|
|
}
|
|
return quote_void;
|
|
}
|
|
|
|
object Cyc_write_u8(void *data, object c, object port)
|
|
{
|
|
Cyc_check_port(data, port);
|
|
if (obj_is_int(c)) {
|
|
FILE *fp = ((port_type *) port)->fp;
|
|
if (fp){
|
|
int i = obj_obj2int(c);
|
|
putc(i, fp);
|
|
}
|
|
} else {
|
|
Cyc_rt_raise2(data, "Argument is not an integer", c);
|
|
}
|
|
return quote_void;
|
|
}
|
|
|
|
/* Fast versions of member and assoc */
|
|
object memberp(void *data, object x, list l)
|
|
{
|
|
for (; l != NULL; l = cdr(l)) {
|
|
Cyc_check_pair_or_null(data, l);
|
|
if (boolean_f != equalp(x, car(l)))
|
|
return l;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
object memqp(void *data, object x, list l)
|
|
{
|
|
for (; l != NULL; l = cdr(l)) {
|
|
Cyc_check_pair_or_null(data, l);
|
|
if ((x == car(l)))
|
|
return l;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
list assq(void *data, object x, list l)
|
|
{
|
|
if ((l == NULL) || is_value_type(l) || type_of(l) != pair_tag)
|
|
return boolean_f;
|
|
for (; (l != NULL); l = cdr(l)) {
|
|
Cyc_check_pair(data, l);
|
|
list la = car(l);
|
|
Cyc_check_pair(data, la);
|
|
if ((x == car(la)))
|
|
return la;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
list assoc(void *data, object x, list l)
|
|
{
|
|
if ((l == NULL) || is_value_type(l) || type_of(l) != pair_tag)
|
|
return boolean_f;
|
|
for (; (l != NULL); l = cdr(l)) {
|
|
Cyc_check_pair(data, l);
|
|
list la = car(l);
|
|
Cyc_check_pair(data, la);
|
|
if (boolean_f != equalp(x, car(la)))
|
|
return la;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
/**
|
|
* Same as assoc but check the cdr of each item for equality
|
|
*/
|
|
list assoc_cdr(void *data, object x, list l)
|
|
{
|
|
if ((l == NULL) || is_value_type(l) || type_of(l) != pair_tag)
|
|
return boolean_f;
|
|
for (; (l != NULL); l = cdr(l)) {
|
|
list la = car(l);
|
|
Cyc_check_pair(data, la);
|
|
if (boolean_f != equalp(x, cdr(la)))
|
|
return la;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
/* END member and assoc */
|
|
|
|
object Cyc_fast_list_2(object ptr, object a1, object a2)
|
|
{
|
|
list_2_type *l = (list_2_type *)ptr;
|
|
set_pair( ((pair)(&(l->b))), a2, NULL);
|
|
set_pair( ((pair)(&(l->a))), a1, ((pair)(&(l->b))));
|
|
return ptr;
|
|
}
|
|
|
|
object Cyc_fast_list_3(object ptr, object a1, object a2, object a3)
|
|
{
|
|
list_3_type *l = (list_3_type *)ptr;
|
|
set_pair( ((pair)(&(l->c))), a3, NULL);
|
|
set_pair( ((pair)(&(l->b))), a2, ((pair)(&(l->c))));
|
|
set_pair( ((pair)(&(l->a))), a1, ((pair)(&(l->b))));
|
|
return ptr;
|
|
}
|
|
|
|
object Cyc_fast_list_4(object ptr, object a1, object a2, object a3, object a4)
|
|
{
|
|
list_4_type *l = (list_4_type *)ptr;
|
|
set_pair( ((pair)(&(l->d))), a4, NULL);
|
|
set_pair( ((pair)(&(l->c))), a3, ((pair)(&(l->d))));
|
|
set_pair( ((pair)(&(l->b))), a2, ((pair)(&(l->c))));
|
|
set_pair( ((pair)(&(l->a))), a1, ((pair)(&(l->b))));
|
|
return ptr;
|
|
}
|
|
|
|
object Cyc_fast_vector_2(object ptr, object a1, object a2)
|
|
{
|
|
vector_2_type *v = (vector_2_type *)ptr;
|
|
v->v.hdr.mark = gc_color_red;
|
|
v->v.hdr.grayed = 0;
|
|
v->v.hdr.immutable = 0;
|
|
v->v.tag = vector_tag;
|
|
v->v.num_elements = 2;
|
|
v->v.elements = v->arr;
|
|
v->v.elements[0] = a1;
|
|
v->v.elements[1] = a2;
|
|
return ptr;
|
|
}
|
|
|
|
object Cyc_fast_vector_3(object ptr, object a1, object a2, object a3)
|
|
{
|
|
vector_3_type *v = (vector_3_type *)ptr;
|
|
v->v.hdr.mark = gc_color_red;
|
|
v->v.hdr.grayed = 0;
|
|
v->v.hdr.immutable = 0;
|
|
v->v.tag = vector_tag;
|
|
v->v.num_elements = 3;
|
|
v->v.elements = v->arr;
|
|
v->v.elements[0] = a1;
|
|
v->v.elements[1] = a2;
|
|
v->v.elements[2] = a3;
|
|
return ptr;
|
|
}
|
|
|
|
object Cyc_fast_vector_4(object ptr, object a1, object a2, object a3, object a4)
|
|
{
|
|
vector_4_type *v = (vector_4_type *)ptr;
|
|
v->v.hdr.mark = gc_color_red;
|
|
v->v.hdr.grayed = 0;
|
|
v->v.hdr.immutable = 0;
|
|
v->v.tag = vector_tag;
|
|
v->v.num_elements = 4;
|
|
v->v.elements = v->arr;
|
|
v->v.elements[0] = a1;
|
|
v->v.elements[1] = a2;
|
|
v->v.elements[2] = a3;
|
|
v->v.elements[3] = a4;
|
|
return ptr;
|
|
}
|
|
|
|
object Cyc_fast_vector_5(object ptr, object a1, object a2, object a3, object a4, object a5)
|
|
{
|
|
vector_5_type *v = (vector_5_type *)ptr;
|
|
v->v.hdr.mark = gc_color_red;
|
|
v->v.hdr.grayed = 0;
|
|
v->v.hdr.immutable = 0;
|
|
v->v.tag = vector_tag;
|
|
v->v.num_elements = 5;
|
|
v->v.elements = v->arr;
|
|
v->v.elements[0] = a1;
|
|
v->v.elements[1] = a2;
|
|
v->v.elements[2] = a3;
|
|
v->v.elements[3] = a4;
|
|
v->v.elements[4] = a5;
|
|
return ptr;
|
|
}
|
|
|
|
// Internal function, do not use this anywhere outside the runtime
|
|
object Cyc_heap_alloc_port(void *data, port_type *stack_p)
|
|
{
|
|
object p = NULL;
|
|
int heap_grown;
|
|
p = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(port_type),
|
|
(char *)stack_p,
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
return p;
|
|
}
|
|
|
|
/**
|
|
* Check two objects for deep equality
|
|
*/
|
|
object equalp(object x, object y)
|
|
{
|
|
int second_cycle = 0;
|
|
object slow_lis = x, fast_lis = NULL;
|
|
object pcar_x = &second_cycle, pcar_y = &second_cycle; // never a car value
|
|
|
|
if (Cyc_is_pair(x) == boolean_t &&
|
|
Cyc_is_pair(cdr(x)) == boolean_t){
|
|
fast_lis = cdr(x);
|
|
}
|
|
|
|
for (;; x = cdr(x), y = cdr(y)) {
|
|
if (equal(x, y))
|
|
return boolean_t;
|
|
if (is_value_type(x) || is_value_type(y) ||
|
|
(x == NULL) || (y == NULL) ||
|
|
type_of(x) != pair_tag || type_of(y) != pair_tag)
|
|
return boolean_f;
|
|
|
|
// Both objects are lists at this point, compare cars
|
|
if (pcar_x == car(x) &&
|
|
pcar_y == car(y)) {
|
|
// do nothing, already equal
|
|
} else {
|
|
if (boolean_f == equalp(car(x), car(y)))
|
|
return boolean_f;
|
|
pcar_x = car(x);
|
|
pcar_y = car(y);
|
|
}
|
|
|
|
// If there is no cycle, keep checking equality
|
|
if (fast_lis == NULL ||
|
|
Cyc_is_pair(fast_lis) == boolean_f ||
|
|
cdr(fast_lis) == NULL ||
|
|
Cyc_is_pair(cdr(fast_lis)) == boolean_f ||
|
|
cddr(fast_lis) == NULL){
|
|
continue;
|
|
}
|
|
|
|
// If there is a cycle, handle it
|
|
if (slow_lis == fast_lis) {
|
|
// if this is y, both lists have cycles and are equal, return #t
|
|
if (second_cycle)
|
|
return boolean_t;
|
|
// if this is x, keep going and check for a cycle in y
|
|
second_cycle = 1;
|
|
slow_lis = y;
|
|
fast_lis = NULL;
|
|
if (Cyc_is_pair(y) == boolean_t) {
|
|
fast_lis = cdr(y);
|
|
}
|
|
continue;
|
|
}
|
|
slow_lis = cdr(slow_lis);
|
|
fast_lis = cddr(fast_lis);
|
|
}
|
|
}
|
|
|
|
object Cyc_num_cmp_va_list(void *data, int argc,
|
|
int (fn_op(void *, object, object)), object n,
|
|
va_list ns)
|
|
{
|
|
int i;
|
|
object next;
|
|
|
|
if (argc < 2) {
|
|
Cyc_rt_raise_msg(data, "Not enough arguments for boolean operator\n");
|
|
}
|
|
Cyc_check_num(data, n);
|
|
|
|
for (i = 1; i < argc; i++) {
|
|
next = va_arg(ns, object);
|
|
Cyc_check_num(data, next);
|
|
if (!fn_op(data, n, next)) {
|
|
return boolean_f;
|
|
}
|
|
n = next;
|
|
}
|
|
|
|
return boolean_t;
|
|
}
|
|
|
|
/**
|
|
* Convert from a bignum to a double
|
|
* Code is from: https://github.com/libtom/libtommath/issues/3
|
|
*/
|
|
#define PRECISION 53
|
|
double mp_get_double(const mp_int *a)
|
|
{
|
|
int i;
|
|
double d = 0.0, fac = 1.0;
|
|
for (i = 0; i < DIGIT_BIT; ++i) {
|
|
fac *= 2.0;
|
|
}
|
|
for (i = a->used; i --> 0;) {
|
|
d = (d * fac) + (double)DIGIT(a, i);
|
|
}
|
|
return (a->sign == MP_NEG) ? -d : d;
|
|
}
|
|
|
|
// Convert a bignum back to fixnum if possible
|
|
object Cyc_bignum_normalize(void *data, object n)
|
|
{
|
|
mp_int bn;
|
|
object result;
|
|
int i;
|
|
if (!is_object_type(n) || type_of(n) != bignum_tag) {
|
|
return n;
|
|
}
|
|
|
|
mp_init(&bn);
|
|
mp_set_int(&bn, CYC_FIXNUM_MAX);
|
|
if (mp_cmp_mag(&bignum_value(n), &bn) == MP_GT) {
|
|
result = n;
|
|
} else {
|
|
i = mp_get_int(&bignum_value(n));
|
|
if (SIGN(&bignum_value(n)) == MP_NEG) {
|
|
i = -i;
|
|
}
|
|
result = obj_int2obj(i);
|
|
}
|
|
mp_clear(&bn);
|
|
return result;
|
|
}
|
|
|
|
void Cyc_int2bignum(int n, mp_int *bn)
|
|
{
|
|
mp_set_int(bn, abs(n));
|
|
if (n < 0) {
|
|
mp_neg(bn, bn);
|
|
}
|
|
}
|
|
|
|
int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty)
|
|
{
|
|
mp_int tmp;
|
|
int cmp = 0;
|
|
|
|
if (tx == bignum_tag && ty == bignum_tag) {
|
|
cmp = mp_cmp(&bignum_value(x), &bignum_value(y));
|
|
} else if (tx == bignum_tag && ty == -1) { \
|
|
mp_init(&tmp);
|
|
Cyc_int2bignum(obj_obj2int(y), &tmp);
|
|
cmp = mp_cmp(&bignum_value(x), &tmp);
|
|
mp_clear(&tmp);
|
|
} else if (tx == -1 && ty == bignum_tag) { \
|
|
mp_init(&tmp);
|
|
Cyc_int2bignum(obj_obj2int(x), &tmp);
|
|
cmp = mp_cmp(&tmp, &bignum_value(y));
|
|
mp_clear(&tmp);
|
|
} else {
|
|
return 0;
|
|
}
|
|
|
|
return (cmp == type) ||
|
|
((type == CYC_BN_GTE && cmp > MP_LT) ||
|
|
(type == CYC_BN_LTE && cmp < MP_GT));
|
|
}
|
|
|
|
#define declare_num_cmp(FUNC, FUNC_OP, FUNC_FAST_OP, FUNC_APPLY, OP, BN_CMP) \
|
|
int FUNC_OP(void *data, object x, object y) { \
|
|
int result = 0, \
|
|
tx = (obj_is_int(x) ? -1 : type_of(x)), \
|
|
ty = (obj_is_int(y) ? -1 : type_of(y)); \
|
|
if (tx == -1 && ty == -1) { \
|
|
result = (obj_obj2int(x)) OP (obj_obj2int(y)); \
|
|
} else if (tx == -1 && ty == integer_tag) { \
|
|
result = (obj_obj2int(x)) OP (integer_value(y)); \
|
|
} else if (tx == -1 && ty == double_tag) { \
|
|
result = (obj_obj2int(x)) OP (double_value(y)); \
|
|
} else if (tx == integer_tag && ty == -1) { \
|
|
result = (integer_value(x)) OP (obj_obj2int(y)); \
|
|
} else if (tx == integer_tag && ty == integer_tag) { \
|
|
result = (integer_value(x)) OP (integer_value(y)); \
|
|
} else if (tx == integer_tag && ty == double_tag) { \
|
|
result = (integer_value(x)) OP (double_value(y)); \
|
|
} else if (tx == double_tag && ty == -1) { \
|
|
result = (double_value(x)) OP (obj_obj2int(y)); \
|
|
} else if (tx == double_tag && ty == integer_tag) { \
|
|
result = (double_value(x)) OP (integer_value(y)); \
|
|
} else if (tx == double_tag && ty == double_tag) { \
|
|
result = (double_value(x)) OP (double_value(y)); \
|
|
} else if (tx == bignum_tag && ty == -1) { \
|
|
result = Cyc_bignum_cmp(BN_CMP, x, tx, y, ty); \
|
|
} else if (tx == bignum_tag && ty == double_tag) { \
|
|
result = mp_get_double(&bignum_value(x)) OP (double_value(y)); \
|
|
} else if (tx == bignum_tag && ty == bignum_tag) { \
|
|
result = Cyc_bignum_cmp(BN_CMP, x, tx, y, ty); \
|
|
} else if (tx == -1 && ty == bignum_tag) { \
|
|
result = Cyc_bignum_cmp(BN_CMP, x, tx, y, ty); \
|
|
} else if (tx == double_tag && ty == bignum_tag) { \
|
|
result = (double_value(x)) OP mp_get_double(&bignum_value(y)); \
|
|
} else if (tx == complex_num_tag && ty == complex_num_tag) { \
|
|
result = (complex_num_value(x)) == (complex_num_value(y)); \
|
|
} else if (tx == complex_num_tag && ty != complex_num_tag) { \
|
|
} else if (tx != complex_num_tag && ty == complex_num_tag) { \
|
|
} else { \
|
|
make_string(s, "Bad argument type"); \
|
|
make_pair(c1, y, NULL); \
|
|
make_pair(c0, &s, &c1); \
|
|
Cyc_rt_raise(data, &c0); \
|
|
} \
|
|
return result; \
|
|
} \
|
|
object FUNC(void *data, object cont, int argc, object n, ...) { \
|
|
object result; \
|
|
va_list ap; \
|
|
va_start(ap, n); \
|
|
result = Cyc_num_cmp_va_list(data, argc, FUNC_OP, n, ap); \
|
|
va_end(ap); \
|
|
_return_closcall1(data, cont, result); \
|
|
} \
|
|
void FUNC_APPLY(void *data, int argc, object clo, object cont, object n, ...) { \
|
|
object result; \
|
|
va_list ap; \
|
|
va_start(ap, n); \
|
|
result = Cyc_num_cmp_va_list(data, argc - 1, FUNC_OP, n, ap); \
|
|
va_end(ap); \
|
|
return_closcall1(data, cont, result); \
|
|
} \
|
|
object FUNC_FAST_OP(void *data, object x, object y) { \
|
|
int tx, ty; \
|
|
if (obj_is_int(x)) { \
|
|
tx = -1; \
|
|
} else if (is_object_type(x)) { \
|
|
tx = type_of(x); \
|
|
} else { \
|
|
goto bad_arg_type_error; \
|
|
} \
|
|
if (obj_is_int(y)) { \
|
|
ty = -1; \
|
|
} else if (is_object_type(y)) { \
|
|
ty = type_of(y); \
|
|
} else { \
|
|
goto bad_arg_type_error; \
|
|
} \
|
|
if (tx == -1 && ty == -1) { \
|
|
return ((obj_obj2int(x)) OP (obj_obj2int(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == -1 && ty == integer_tag) { \
|
|
return ((obj_obj2int(x)) OP (integer_value(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == -1 && ty == double_tag) { \
|
|
return ((obj_obj2int(x)) OP (double_value(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == integer_tag && ty == -1) { \
|
|
return ((integer_value(x)) OP (obj_obj2int(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == integer_tag && ty == integer_tag) { \
|
|
return ((integer_value(x)) OP (integer_value(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == integer_tag && ty == double_tag) { \
|
|
return ((integer_value(x)) OP (double_value(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == double_tag && ty == -1) { \
|
|
return ((double_value(x)) OP (obj_obj2int(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == double_tag && ty == integer_tag) { \
|
|
return ((double_value(x)) OP (integer_value(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == double_tag && ty == double_tag) { \
|
|
return ((double_value(x)) OP (double_value(y))) \
|
|
? boolean_t : boolean_f; \
|
|
} else if (tx == bignum_tag && ty == -1) { \
|
|
return Cyc_bignum_cmp(BN_CMP, x, tx, y, ty) ? boolean_t : boolean_f; \
|
|
} else if (tx == bignum_tag && ty == double_tag) { \
|
|
return mp_get_double(&bignum_value(x)) OP (double_value(y)) ? boolean_t : boolean_f; \
|
|
} else if (tx == bignum_tag && ty == bignum_tag) { \
|
|
return Cyc_bignum_cmp(BN_CMP, x, tx, y, ty) ? boolean_t : boolean_f; \
|
|
} else if (tx == -1 && ty == bignum_tag) { \
|
|
return Cyc_bignum_cmp(BN_CMP, x, tx, y, ty) ? boolean_t : boolean_f; \
|
|
} else if (tx == double_tag && ty == bignum_tag) { \
|
|
return (double_value(x)) OP mp_get_double(&bignum_value(x)) ? boolean_t : boolean_f; \
|
|
} else if (tx == complex_num_tag && ty == complex_num_tag) { \
|
|
return ((complex_num_value(x)) == (complex_num_value(y))) ? boolean_t : boolean_f; \
|
|
} else if (tx == complex_num_tag && ty != complex_num_tag) { \
|
|
return boolean_f; \
|
|
} else if (tx != complex_num_tag && ty == complex_num_tag) { \
|
|
return boolean_f; \
|
|
} else { \
|
|
goto bad_arg_type_error; \
|
|
} \
|
|
return NULL; \
|
|
bad_arg_type_error: \
|
|
{ \
|
|
make_string(s, "Bad argument type"); \
|
|
make_pair(c2, y, NULL); \
|
|
make_pair(c1, x, &c2); \
|
|
make_pair(c0, &s, &c1); \
|
|
Cyc_rt_raise(data, &c0); \
|
|
return NULL; \
|
|
} \
|
|
}
|
|
|
|
declare_num_cmp(Cyc_num_eq, Cyc_num_eq_op, Cyc_num_fast_eq_op, dispatch_num_eq, ==, CYC_BN_EQ);
|
|
declare_num_cmp(Cyc_num_gt, Cyc_num_gt_op, Cyc_num_fast_gt_op, dispatch_num_gt, >, CYC_BN_GT);
|
|
declare_num_cmp(Cyc_num_lt, Cyc_num_lt_op, Cyc_num_fast_lt_op, dispatch_num_lt, <, CYC_BN_LT);
|
|
declare_num_cmp(Cyc_num_gte, Cyc_num_gte_op, Cyc_num_fast_gte_op, dispatch_num_gte, >=, CYC_BN_GTE);
|
|
declare_num_cmp(Cyc_num_lte, Cyc_num_lte_op, Cyc_num_fast_lte_op, dispatch_num_lte, <=, CYC_BN_LTE);
|
|
|
|
//object Cyc_is_boolean(object o)
|
|
//{
|
|
// if ((o != NULL) &&
|
|
// !is_value_type(o) &&
|
|
// ((list) o)->tag == boolean_tag && ((boolean_f == o) || (boolean_t == o)))
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_pair(object o)
|
|
//{
|
|
// if (is_object_type(o) && ((list) o)->tag == pair_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_null(object o)
|
|
//{
|
|
// if (o == NULL)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
|
|
object Cyc_is_number(object o)
|
|
{
|
|
if ((o != NULL) && (obj_is_int(o) || (!is_value_type(o)
|
|
&& (type_of(o) == integer_tag
|
|
|| type_of(o) == bignum_tag
|
|
|| type_of(o) == double_tag
|
|
|| type_of(o) == complex_num_tag))))
|
|
return boolean_t;
|
|
return boolean_f;
|
|
}
|
|
|
|
object Cyc_is_real(object o)
|
|
{
|
|
if ((o != NULL) && (obj_is_int(o) ||
|
|
(!is_value_type(o) && (type_of(o) == integer_tag
|
|
|| type_of(o) == bignum_tag
|
|
|| type_of(o) == double_tag
|
|
|| (type_of(o) == complex_num_tag &&
|
|
cimag(complex_num_value(o)) == 0.0))))) // Per R7RS
|
|
return boolean_t;
|
|
return boolean_f;
|
|
}
|
|
|
|
//object Cyc_is_complex(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == complex_num_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
|
|
//object Cyc_is_fixnum(object o)
|
|
//{
|
|
// if (obj_is_int(o))
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
|
|
object Cyc_is_integer(object o)
|
|
{
|
|
if ((o != NULL) && (obj_is_int(o) ||
|
|
(!is_value_type(o) && type_of(o) == integer_tag) ||
|
|
(!is_value_type(o) && type_of(o) == bignum_tag)
|
|
// || (!is_value_type(o) && type_of(o) == double_tag && double_value(o) == round(double_value(o)))
|
|
)) // Per R7RS
|
|
return boolean_t;
|
|
return boolean_f;
|
|
}
|
|
|
|
//object Cyc_is_bignum(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == bignum_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_symbol(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == symbol_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_vector(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == vector_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_bytevector(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == bytevector_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_port(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == port_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_mutex(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == mutex_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_cond_var(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == cond_var_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_string(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == string_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_char(object o)
|
|
//{
|
|
// if (obj_is_char(o))
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
|
|
object Cyc_is_procedure(void *data, object o)
|
|
{
|
|
int tag;
|
|
if ((o != NULL) && !is_value_type(o)) {
|
|
tag = type_of(o);
|
|
if (tag == closure0_tag ||
|
|
tag == closure1_tag || tag == closureN_tag || tag == primitive_tag) {
|
|
return boolean_t;
|
|
} else if (tag == pair_tag) {
|
|
int i = obj_obj2int(Cyc_length(data, o));
|
|
if (i > 0 && Cyc_is_symbol(car(o)) == boolean_t) {
|
|
if (strncmp(((symbol) car(o))->desc, "primitive", 10) == 0 ||
|
|
strncmp(((symbol) car(o))->desc, "procedure", 10) == 0) {
|
|
return boolean_t;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
//object Cyc_is_macro(object o)
|
|
//{
|
|
// int tag;
|
|
// if ((o != NULL) && !is_value_type(o)) {
|
|
// tag = type_of(o);
|
|
// if (tag == macro_tag) {
|
|
// return boolean_t;
|
|
// }
|
|
// }
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_eof_object(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && type_of(o) == eof_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_cvar(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && type_of(o) == cvar_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_is_opaque(object o)
|
|
//{
|
|
// if ((o != NULL) && !is_value_type(o) && ((list) o)->tag == c_opaque_tag)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
//
|
|
//object Cyc_eq(object x, object y)
|
|
//{
|
|
// if (x == y)
|
|
// return boolean_t;
|
|
// return boolean_f;
|
|
//}
|
|
|
|
object Cyc_is_immutable(object obj)
|
|
{
|
|
if (is_object_type(obj) &&
|
|
(type_of(obj) == pair_tag ||
|
|
type_of(obj) == vector_tag ||
|
|
type_of(obj) == bytevector_tag ||
|
|
type_of(obj) == string_tag
|
|
) &&
|
|
!immutable(obj) ) {
|
|
return boolean_f;
|
|
}
|
|
return boolean_t;
|
|
}
|
|
|
|
object Cyc_set_cell(void *data, object l, object val)
|
|
{
|
|
// FUTURE: always use "unsafe" car here, since set-cell is added by cyclone
|
|
gc_mut_update((gc_thread_data *) data, car(l), val);
|
|
car(l) = val;
|
|
add_mutation(data, l, -1, val);
|
|
return l;
|
|
}
|
|
|
|
object Cyc_set_car(void *data, object l, object val)
|
|
{
|
|
if (Cyc_is_pair(l) == boolean_f) {
|
|
Cyc_invalid_type_error(data, pair_tag, l);
|
|
}
|
|
Cyc_verify_mutable(data, l);
|
|
gc_mut_update((gc_thread_data *) data, car(l), val);
|
|
car(l) = val;
|
|
add_mutation(data, l, -1, val);
|
|
return l;
|
|
}
|
|
|
|
object Cyc_set_cdr(void *data, object l, object val)
|
|
{
|
|
if (Cyc_is_pair(l) == boolean_f) {
|
|
Cyc_invalid_type_error(data, pair_tag, l);
|
|
}
|
|
Cyc_verify_mutable(data, l);
|
|
gc_mut_update((gc_thread_data *) data, cdr(l), val);
|
|
cdr(l) = val;
|
|
add_mutation(data, l, -1, val);
|
|
return l;
|
|
}
|
|
|
|
object Cyc_vector_set(void *data, object v, object k, object obj)
|
|
{
|
|
int idx;
|
|
Cyc_check_vec(data, v);
|
|
Cyc_check_fixnum(data, k);
|
|
Cyc_verify_mutable(data, v);
|
|
idx = unbox_number(k);
|
|
|
|
if (idx < 0 || idx >= ((vector) v)->num_elements) {
|
|
Cyc_rt_raise2(data, "vector-set! - invalid index", k);
|
|
}
|
|
|
|
gc_mut_update((gc_thread_data *) data, ((vector) v)->elements[idx], obj);
|
|
|
|
((vector) v)->elements[idx] = obj;
|
|
add_mutation(data, v, idx, obj);
|
|
return v;
|
|
}
|
|
|
|
object Cyc_vector_ref(void *data, object v, object k)
|
|
{
|
|
int idx;
|
|
Cyc_check_vec(data, v);
|
|
Cyc_check_fixnum(data, k);
|
|
|
|
idx = unbox_number(k);
|
|
if (idx < 0 || idx >= ((vector) v)->num_elements) {
|
|
Cyc_rt_raise2(data, "vector-ref - invalid index", obj_int2obj(idx));
|
|
}
|
|
|
|
return ((vector) v)->elements[idx];
|
|
}
|
|
|
|
object _unsafe_Cyc_vector_ref(object v, object k)
|
|
{
|
|
int idx;
|
|
if (Cyc_is_vector(v) == boolean_f ||
|
|
Cyc_is_fixnum(k) == boolean_f)
|
|
{
|
|
return NULL;
|
|
}
|
|
|
|
idx = unbox_number(k);
|
|
if (idx < 0 || idx >= ((vector) v)->num_elements) {
|
|
return NULL;
|
|
}
|
|
|
|
return ((vector) v)->elements[idx];
|
|
}
|
|
|
|
object Cyc_vector_length(void *data, object v)
|
|
{
|
|
if ((v != NULL) && !is_value_type(v) && ((list) v)->tag == vector_tag) {
|
|
return obj_int2obj(((vector) v)->num_elements);
|
|
}
|
|
Cyc_rt_raise_msg(data,
|
|
"vector-length - invalid parameter, expected vector\n");
|
|
return NULL;
|
|
}
|
|
|
|
object Cyc_length(void *data, object l)
|
|
{
|
|
int len = 0;
|
|
while ((l != NULL)) {
|
|
if (is_value_type(l) || ((list) l)->tag != pair_tag) {
|
|
Cyc_rt_raise2(data, "length - invalid parameter, expected list", l);
|
|
}
|
|
l = cdr(l);
|
|
len++;
|
|
}
|
|
return obj_int2obj(len);
|
|
}
|
|
|
|
char *int_to_binary(char *b, int x)
|
|
{
|
|
unsigned int i = 0x80000000, leading_zeros = 1;
|
|
if (x == 0) {
|
|
*b++ = '0';
|
|
*b = '\0';
|
|
return b;
|
|
}
|
|
|
|
while (i){
|
|
if (x & i) {
|
|
*b++ = '1';
|
|
leading_zeros = 0;
|
|
} else if (!leading_zeros) {
|
|
*b++ = '0';
|
|
}
|
|
i >>= 1;
|
|
}
|
|
*b = '\0';
|
|
return b;
|
|
}
|
|
|
|
object Cyc_number2string2(void *data, object cont, int argc, object n, ...)
|
|
{
|
|
object base = NULL;
|
|
int base_num = 10, val, sz;
|
|
char buffer[1024];
|
|
va_list ap;
|
|
va_start(ap, n);
|
|
if (argc > 1) {
|
|
base = va_arg(ap, object);
|
|
Cyc_check_num(data, base);
|
|
}
|
|
va_end(ap);
|
|
Cyc_check_num(data, n);
|
|
if (base) {
|
|
base_num = unbox_number(base);
|
|
}
|
|
|
|
if (is_object_type(n) && type_of(n) == bignum_tag) {
|
|
if (base_num > 64 || base_num < 2) {
|
|
Cyc_rt_raise2(data, "number->string - invalid radix for bignum", base);
|
|
}
|
|
mp_radix_size(&bignum_value(n), base_num, &sz);
|
|
if (sz > 1024) {
|
|
// TODO: just temporary, need to handle this better
|
|
Cyc_rt_raise2(data, "number->string - bignum is too large to convert", n);
|
|
}
|
|
mp_toradix(&bignum_value(n), buffer, base_num);
|
|
} else {
|
|
if (base_num == 2) {
|
|
val = obj_is_int(n) ?
|
|
obj_obj2int(n) :
|
|
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
|
|
int_to_binary(buffer, val);
|
|
} else if (base_num == 8) {
|
|
val = obj_is_int(n) ?
|
|
obj_obj2int(n) :
|
|
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
|
|
snprintf(buffer, 1024, "%o", val);
|
|
} else if (base_num == 16) {
|
|
val = obj_is_int(n) ?
|
|
obj_obj2int(n) :
|
|
type_of(n) == integer_tag ? integer_value(n) : ((int)double_value(n));
|
|
snprintf(buffer, 1024, "%X", val);
|
|
} else {
|
|
if (obj_is_int(n)) {
|
|
snprintf(buffer, 1024, "%ld", obj_obj2int(n));
|
|
} else if (type_of(n) == integer_tag) {
|
|
snprintf(buffer, 1024, "%d", ((integer_type *) n)->value);
|
|
} else if (type_of(n) == double_tag) {
|
|
double2buffer(buffer, 1024, ((double_type *) n)->value);
|
|
} else if (type_of(n) == complex_num_tag) {
|
|
char rbuf[33], ibuf[33];
|
|
const char *plus="+", *empty="";
|
|
double dreal = creal(((complex_num_type *) n)->value);
|
|
double dimag = cimag(((complex_num_type *) n)->value);
|
|
double2buffer(rbuf, 32, dreal);
|
|
double2buffer(ibuf, 32, dimag);
|
|
if (dreal == 0.0) {
|
|
snprintf(buffer, 1024, "%si", ibuf);
|
|
} else {
|
|
snprintf(buffer, 1024, "%s%s%si",
|
|
rbuf,
|
|
(dimag < 0.0) ? empty : plus,
|
|
ibuf);
|
|
}
|
|
} else {
|
|
Cyc_rt_raise2(data, "number->string - Unexpected object", n);
|
|
}
|
|
}
|
|
}
|
|
make_string(str, buffer);
|
|
_return_closcall1(data, cont, &str);
|
|
}
|
|
|
|
object Cyc_symbol2string(void *data, object cont, object sym)
|
|
{
|
|
Cyc_check_sym(data, sym);
|
|
{
|
|
const char *desc = symbol_desc(sym);
|
|
make_utf8_string(data, str, desc);
|
|
_return_closcall1(data, cont, &str);
|
|
}}
|
|
|
|
object Cyc_string2symbol(void *data, object str)
|
|
{
|
|
object sym;
|
|
Cyc_check_str(data, str);
|
|
sym = find_symbol_by_name(string_str(str));
|
|
if (!sym) {
|
|
sym = add_symbol_by_name(string_str(str));
|
|
}
|
|
return sym;
|
|
}
|
|
|
|
object Cyc_list2string(void *data, object cont, object lst)
|
|
{
|
|
char *buf, cbuf[5];
|
|
int i = 0, len = 0, num_cp = 0;
|
|
object cbox, tmp = lst;
|
|
char_type ch;
|
|
|
|
Cyc_check_pair_or_null(data, lst);
|
|
|
|
// Need to walk the list of chars to compute multibyte length
|
|
while (tmp) {
|
|
if (is_value_type(tmp) || ((list) tmp)->tag != pair_tag) {
|
|
Cyc_rt_raise2(data, "length - invalid parameter, expected list", tmp);
|
|
}
|
|
cbox = car(tmp);
|
|
ch = obj_obj2char(cbox);
|
|
if (!obj_is_char(cbox)) {
|
|
Cyc_rt_raise2(data, "Expected character but received", cbox);
|
|
}
|
|
if (!ch) {
|
|
len++;
|
|
num_cp++; // Failsafe?
|
|
} else {
|
|
Cyc_utf8_encode_char(cbuf, 5, ch);
|
|
len += strlen(cbuf);
|
|
num_cp++;
|
|
}
|
|
tmp = cdr(tmp);
|
|
}
|
|
|
|
{
|
|
object str;
|
|
alloc_string(data, str, len, num_cp);
|
|
buf = ((string_type *)str)->str;
|
|
while ((lst != NULL)) {
|
|
cbox = car(lst);
|
|
ch = obj_obj2char(cbox); // Already validated, can assume chars now
|
|
if (!ch) {
|
|
i++;
|
|
} else {
|
|
Cyc_utf8_encode_char(&(buf[i]), 5, ch);
|
|
i += strlen(buf+i);
|
|
}
|
|
lst = cdr(lst);
|
|
}
|
|
buf[i] = '\0';
|
|
_return_closcall1(data, cont, str);
|
|
}
|
|
}
|
|
|
|
object Cyc_list(void *data, int argc, object cont, ...)
|
|
{
|
|
load_varargs(objs, cont, argc);
|
|
//Cyc_st_add(data, "Cyc-list");
|
|
_return_closcall1(data, cont, cdr(objs));
|
|
}
|
|
|
|
object Cyc_string2number2_(void *data, object cont, int argc, object str, ...)
|
|
{
|
|
object base = NULL;
|
|
int base_num, result;
|
|
va_list ap;
|
|
va_start(ap, str);
|
|
if (argc > 1) {
|
|
base = va_arg(ap, object);
|
|
Cyc_check_num(data, base);
|
|
}
|
|
va_end(ap);
|
|
if (base) {
|
|
base_num = unbox_number(base);
|
|
Cyc_check_str(data, str);
|
|
result = -1;
|
|
if (base_num == 2) {
|
|
result = (int)strtol(string_str(str), NULL, 2);
|
|
} else if (base_num == 8) {
|
|
result = (int)strtol(string_str(str), NULL, 8);
|
|
} else if (base_num == 10) {
|
|
Cyc_string2number_(data, cont, str); // Default processing
|
|
} else if (base_num == 16) {
|
|
result = (int)strtol(string_str(str), NULL, 16);
|
|
}
|
|
|
|
if (result <= 0 || result > CYC_FIXNUM_MAX) {
|
|
mp_int tmp;
|
|
alloc_bignum(data, bn);
|
|
if (MP_OKAY != mp_read_radix(&(bignum_value(bn)), string_str(str), base_num)) {
|
|
Cyc_rt_raise2(data, "Error converting string to bignum", str);
|
|
}
|
|
|
|
// If result is mp_zero and str does not contain a 0, then fail
|
|
mp_init(&tmp);
|
|
mp_zero(&tmp);
|
|
if (MP_EQ == mp_cmp(&(bignum_value(bn)), &tmp) &&
|
|
NULL == strchr(string_str(str), '0')) {
|
|
_return_closcall1(data, cont, boolean_f);
|
|
}
|
|
|
|
_return_closcall1(data, cont, Cyc_bignum_normalize(data, bn));
|
|
} else {
|
|
_return_closcall1(data, cont, obj_int2obj(result));
|
|
}
|
|
}
|
|
Cyc_string2number_(data, cont, str);
|
|
return NULL;
|
|
}
|
|
|
|
typedef enum {
|
|
STR2INT_SUCCESS,
|
|
STR2INT_OVERFLOW,
|
|
STR2INT_UNDERFLOW,
|
|
STR2INT_INCONVERTIBLE
|
|
} str2int_errno;
|
|
|
|
/*
|
|
Convert string s to int out.
|
|
|
|
@param[out] out The converted int. Cannot be NULL.
|
|
|
|
@param[in] s Input string to be converted.
|
|
|
|
The format is the same as strtol,
|
|
except that the following are inconvertible:
|
|
|
|
- empty string
|
|
- leading whitespace
|
|
- any trailing characters that are not part of the number
|
|
|
|
Cannot be NULL.
|
|
|
|
@param[in] base Base to interpret string in. Same range as strtol (2 to 36).
|
|
|
|
@return Indicates if the operation succeeded, or why it failed.
|
|
*/
|
|
static str2int_errno str2int(int *out, char *s, int base)
|
|
{
|
|
char *end;
|
|
if (s[0] == '\0' || isspace((unsigned char) s[0]))
|
|
return STR2INT_INCONVERTIBLE;
|
|
errno = 0;
|
|
long l = strtol(s, &end, base);
|
|
/* Both checks are needed because INT_MAX == LONG_MAX is possible. */
|
|
if (l > CYC_FIXNUM_MAX /*INT_MAX*/ || (errno == ERANGE && l == LONG_MAX))
|
|
return STR2INT_OVERFLOW;
|
|
if (l < CYC_FIXNUM_MIN /*INT_MIN*/ || (errno == ERANGE && l == LONG_MIN))
|
|
return STR2INT_UNDERFLOW;
|
|
if (*end != '\0')
|
|
return STR2INT_INCONVERTIBLE;
|
|
*out = l;
|
|
return STR2INT_SUCCESS;
|
|
}
|
|
|
|
int str_is_bignum(str2int_errno errnum, char *c)
|
|
{
|
|
if (errnum == STR2INT_INCONVERTIBLE) return 0; // Unexpected chars for int
|
|
|
|
for (;*c; c++) {
|
|
if (!isdigit(*c) && *c != '-') {
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
object Cyc_string2number_(void *data, object cont, object str)
|
|
{
|
|
int result, rv;
|
|
double n;
|
|
char *s;
|
|
Cyc_check_str(data, str);
|
|
if (type_of(str) == string_tag && ((string_type *) str)->str) {
|
|
s = ((string_type *) str)->str;
|
|
|
|
rv = str2int(&result, s, 10);
|
|
if (rv == STR2INT_SUCCESS) {
|
|
_return_closcall1(data, cont, obj_int2obj(result));
|
|
} else if (str_is_bignum(rv, s)) {
|
|
alloc_bignum(data, bn);
|
|
if (MP_OKAY != mp_read_radix(&(bignum_value(bn)), s, 10)) {
|
|
Cyc_rt_raise2(data, "Error converting string to bignum", str);
|
|
}
|
|
_return_closcall1(data, cont, bn);
|
|
} else {
|
|
char *str_end;
|
|
n = strtold(s, &str_end);
|
|
if (s != str_end && (*str_end == '\0' || isspace(*str_end))) {
|
|
make_double(result, n);
|
|
_return_closcall1(data, cont, &result);
|
|
} else {
|
|
_return_closcall1(data, cont, boolean_f);
|
|
}
|
|
}
|
|
}
|
|
|
|
Cyc_rt_raise2(data, "Expected string but received", str);
|
|
return NULL;
|
|
}
|
|
|
|
int binstr2int(const char *str)
|
|
{
|
|
int num = 0;
|
|
while (*str) {
|
|
num <<= 1;
|
|
if (*str++ == '1')
|
|
num++;
|
|
}
|
|
return num;
|
|
}
|
|
|
|
int octstr2int(const char *str)
|
|
{
|
|
int num = 0;
|
|
while (*str) {
|
|
num <<= 3;
|
|
num += ((*str++) - '0');
|
|
}
|
|
return num;
|
|
}
|
|
|
|
object Cyc_string_cmp(void *data, object str1, object str2)
|
|
{
|
|
Cyc_check_str(data, str1);
|
|
Cyc_check_str(data, str2);
|
|
return obj_int2obj(strcmp(((string_type *) str1)->str,
|
|
((string_type *) str2)->str));
|
|
}
|
|
|
|
#define Cyc_string_append_va_list(data, argc) { \
|
|
int i = 0, total_cp = 0, total_len = 1; \
|
|
int *len = alloca(sizeof(int) * argc); \
|
|
char *buffer, *bufferp, **str = alloca(sizeof(char *) * argc); \
|
|
object tmp; \
|
|
if (argc > 0) { \
|
|
Cyc_check_str(data, str1); \
|
|
str[i] = ((string_type *)str1)->str; \
|
|
len[i] = string_len((str1)); \
|
|
total_len += len[i]; \
|
|
total_cp += string_num_cp((str1)); \
|
|
} \
|
|
for (i = 1; i < argc; i++) { \
|
|
tmp = va_arg(ap, object); \
|
|
Cyc_check_str(data, tmp); \
|
|
str[i] = ((string_type *)tmp)->str; \
|
|
len[i] = string_len((tmp)); \
|
|
total_len += len[i]; \
|
|
total_cp += string_num_cp((tmp)); \
|
|
} \
|
|
buffer = bufferp = alloca(sizeof(char) * total_len); \
|
|
for (i = 0; i < argc; i++) { \
|
|
memcpy(bufferp, str[i], len[i]); \
|
|
bufferp += len[i]; \
|
|
} \
|
|
*bufferp = '\0'; \
|
|
make_string(result, buffer); \
|
|
string_num_cp((&result)) = total_cp; \
|
|
va_end(ap); \
|
|
_return_closcall1(data, cont, &result); \
|
|
}
|
|
|
|
object dispatch_string_91append(void *data, int _argc, object clo, object cont,
|
|
object str1, ...)
|
|
{
|
|
va_list ap;
|
|
va_start(ap, str1);
|
|
Cyc_string_append_va_list(data, _argc - 1);
|
|
}
|
|
|
|
object Cyc_string_append(void *data, object cont, int _argc, object str1, ...)
|
|
{
|
|
va_list ap;
|
|
va_start(ap, str1);
|
|
Cyc_string_append_va_list(data, _argc);
|
|
}
|
|
|
|
object Cyc_string_length(void *data, object str)
|
|
{
|
|
Cyc_check_str(data, str);
|
|
return obj_int2obj(string_num_cp(str));
|
|
}
|
|
|
|
object Cyc_string_byte_length(void *data, object str)
|
|
{
|
|
Cyc_check_str(data, str);
|
|
return obj_int2obj(string_len(str));
|
|
}
|
|
|
|
object Cyc_string_set(void *data, object str, object k, object chr)
|
|
{
|
|
char buf[5];
|
|
char *raw;
|
|
int idx, len, buf_len;
|
|
char_type input_char;
|
|
|
|
Cyc_check_str(data, str);
|
|
Cyc_check_fixnum(data, k);
|
|
Cyc_verify_mutable(data, str);
|
|
|
|
if (boolean_t != Cyc_is_char(chr)) {
|
|
Cyc_rt_raise2(data, "Expected char but received", chr);
|
|
}
|
|
|
|
input_char = obj_obj2char(chr);
|
|
if (!input_char) {
|
|
buf_len = 1;
|
|
} else {
|
|
Cyc_utf8_encode_char(buf, 5, input_char);
|
|
buf_len = strlen(buf);
|
|
}
|
|
|
|
raw = string_str(str);
|
|
idx = unbox_number(k);
|
|
len = string_len(str);
|
|
|
|
Cyc_check_bounds(data, "string-set!", len, idx);
|
|
|
|
if (string_num_cp(str) == string_len(str) && buf_len == 1) {
|
|
// Take fast path if all chars are just 1 byte
|
|
raw[idx] = obj_obj2char(chr);
|
|
} else {
|
|
// Slower path for UTF-8, need to handle replacement differently
|
|
// depending upon how the new char affects length of the string
|
|
char *tmp = raw, *this_cp = raw;
|
|
char_type codepoint;
|
|
uint32_t state = 0;
|
|
int i = 0, count, prev_cp_bytes = 0, cp_idx;
|
|
|
|
// Find index to change, and how many bytes it is
|
|
for (count = 0; *tmp; ++tmp){
|
|
prev_cp_bytes++;
|
|
if (!Cyc_utf8_decode(&state, &codepoint, (uint8_t)*tmp)){
|
|
if (count == idx) {
|
|
break;
|
|
}
|
|
this_cp = tmp + 1;
|
|
count += 1;
|
|
prev_cp_bytes = 0;
|
|
}
|
|
i++;
|
|
}
|
|
cp_idx = i;
|
|
if (state != CYC_UTF8_ACCEPT) {
|
|
Cyc_rt_raise2(data, "string-set! - invalid character at index", k);
|
|
}
|
|
|
|
// Perform actual mutation
|
|
//
|
|
// Now we know length of start (both in codepoints and bytes),
|
|
// and we know the codepoint to be replaced. by calculating its length
|
|
// we can compute where the end portion starts, and by using str we can
|
|
// figure out how many remaining bytes/codepoints are in end
|
|
//
|
|
// 3 cases:
|
|
// - 1) buf_len = prev_cp_bytes, just straight replace
|
|
if (buf_len == prev_cp_bytes) {
|
|
for (i = 0; i < buf_len; i++) {
|
|
this_cp[i] = buf[i];
|
|
}
|
|
}
|
|
// - 2) buf_len < prev_cp_bytes, replace and shift chars down
|
|
else if (buf_len < prev_cp_bytes) {
|
|
// Replace code point with shorter one
|
|
for (i = 0; i < buf_len; i++) {
|
|
this_cp[i] = buf[i];
|
|
}
|
|
// Move string down to eliminate unneeded chars
|
|
memmove(this_cp + buf_len, this_cp + prev_cp_bytes, len - cp_idx);
|
|
// Null terminate the shorter string.
|
|
// Ensure string_len is not reduced because original
|
|
// value still matters for GC purposes
|
|
raw[len - (prev_cp_bytes - buf_len)] = '\0';
|
|
}
|
|
// - 3) TODO: buf_len > prev_cp_bytes, will need to allocate more memory (!!)
|
|
else {
|
|
// TODO: maybe we can try a little harder here, at least in some cases
|
|
Cyc_rt_raise2(data, "string-set! - Unable to allocate memory to store multibyte character", chr);
|
|
}
|
|
}
|
|
return str;
|
|
}
|
|
|
|
object Cyc_string_ref(void *data, object str, object k)
|
|
{
|
|
const char *raw;
|
|
int idx, len;
|
|
|
|
Cyc_check_str(data, str);
|
|
Cyc_check_fixnum(data, k);
|
|
|
|
raw = string_str(str);
|
|
idx = unbox_number(k);
|
|
len = string_num_cp(str);
|
|
|
|
if (idx < 0 || idx >= len) {
|
|
Cyc_rt_raise2(data, "string-ref - invalid index", k);
|
|
}
|
|
|
|
// Take fast path if all chars are just 1 byte
|
|
if (string_num_cp(str) == string_len(str)) {
|
|
return obj_char2obj(raw[idx]);
|
|
} else {
|
|
char_type codepoint = 0;
|
|
uint32_t state = 0;
|
|
int count;
|
|
|
|
for (count = 0; *raw; ++raw){
|
|
if (!Cyc_utf8_decode(&state, &codepoint, (uint8_t)*raw)){
|
|
if (count == idx) break; // Reached requested index
|
|
count += 1;
|
|
}
|
|
}
|
|
if (state != CYC_UTF8_ACCEPT)
|
|
Cyc_rt_raise2(data, "string-ref - invalid character at index", k);
|
|
return obj_char2obj(codepoint);
|
|
}
|
|
}
|
|
|
|
object Cyc_substring(void *data, object cont, object str, object start,
|
|
object end)
|
|
{
|
|
const char *raw;
|
|
int s, e, len;
|
|
|
|
Cyc_check_str(data, str);
|
|
Cyc_check_fixnum(data, start);
|
|
Cyc_check_fixnum(data, end);
|
|
|
|
raw = string_str(str);
|
|
s = unbox_number(start);
|
|
e = unbox_number(end);
|
|
len = string_num_cp(str);
|
|
|
|
if (s > e) {
|
|
Cyc_rt_raise2(data, "substring - start cannot be greater than end", start);
|
|
}
|
|
if (s > len) {
|
|
Cyc_rt_raise2(data,
|
|
"substring - start cannot be greater than string length",
|
|
start);
|
|
}
|
|
if (e > len) {
|
|
e = len;
|
|
}
|
|
|
|
if (string_num_cp(str) == string_len(str)){ // Fast path for ASCII
|
|
make_string_with_len(sub, raw + s, e - s);
|
|
_return_closcall1(data, cont, &sub);
|
|
} else {
|
|
const char *tmp = raw;
|
|
char_type codepoint;
|
|
uint32_t state = 0;
|
|
int num_ch, cur_ch_bytes = 0, start_i = 0, end_i = 0;
|
|
for (num_ch = 0; *tmp; ++tmp){
|
|
cur_ch_bytes++;
|
|
if (!Cyc_utf8_decode(&state, &codepoint, (uint8_t)*tmp)){
|
|
end_i += cur_ch_bytes;
|
|
num_ch += 1;
|
|
cur_ch_bytes = 0;
|
|
|
|
if (num_ch == s) {
|
|
start_i = end_i;
|
|
}
|
|
if (num_ch == e) {
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
if (state != CYC_UTF8_ACCEPT)
|
|
Cyc_rt_raise2(data, "substring - invalid character in string", str);
|
|
make_utf8_string_with_len(sub, raw + start_i, end_i - start_i, e - s);
|
|
_return_closcall1(data, cont, &sub);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* Return directory where cyclone is installed.
|
|
* This is configured via the makefile during a build.
|
|
*/
|
|
object Cyc_installation_dir(void *data, object cont, object type)
|
|
{
|
|
if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol) type)->desc, "sld", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_SLD);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol) type)->desc, "lib", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_LIB);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol) type)->desc, "bin", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_BIN);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol) type)->desc, "inc", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_INC);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else {
|
|
make_utf8_string(data, str, CYC_INSTALL_DIR);
|
|
_return_closcall1(data, cont, &str);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* Retrieve a value set during Cyclone compilation
|
|
*/
|
|
object Cyc_compilation_environment(void *data, object cont, object var)
|
|
{
|
|
if (Cyc_is_symbol(var) == boolean_t){
|
|
if (strncmp(((symbol) var)->desc, "cc-prog", 8) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_CC_PROG);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (strncmp(((symbol) var)->desc, "cc-exec", 8) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_CC_EXEC);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (strncmp(((symbol) var)->desc, "cc-lib", 7) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_CC_LIB);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (strncmp(((symbol) var)->desc, "cc-so", 6) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_CC_SO);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
} else if (strncmp(((symbol) var)->desc, "platform", 9) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_PLATFORM);
|
|
make_utf8_string(data, str, buf);
|
|
_return_closcall1(data, cont, &str);
|
|
}
|
|
}
|
|
Cyc_rt_raise2(data,
|
|
"Cyc-compilation-environment - unrecognized symbol",
|
|
var);
|
|
return NULL;
|
|
}
|
|
|
|
/**
|
|
* Perform same role as the CHICKEN function:
|
|
*
|
|
* Contains the list of arguments passed to this program, with the name
|
|
* of the program and any runtime options (all options starting with -:)
|
|
* removed.
|
|
*
|
|
* For now, runtime options are not removed.
|
|
*/
|
|
object Cyc_command_line_arguments(void *data, object cont)
|
|
{
|
|
int i;
|
|
object lis = NULL;
|
|
for (i = _cyc_argc; i > 1; i--) { // skip program name
|
|
object ps = alloca(sizeof(string_type));
|
|
object pl = alloca(sizeof(pair_type));
|
|
make_utf8_string(data, s, _cyc_argv[i - 1]);
|
|
memcpy(ps, &s, sizeof(string_type));
|
|
((list) pl)->hdr.mark = gc_color_red;
|
|
((list) pl)->hdr.grayed = 0;
|
|
((list) pl)->hdr.immutable = 0;
|
|
((list) pl)->tag = pair_tag;
|
|
((list) pl)->pair_car = ps;
|
|
((list) pl)->pair_cdr = lis;
|
|
lis = pl;
|
|
}
|
|
_return_closcall1(data, cont, lis);
|
|
}
|
|
|
|
object Cyc_make_vector(void *data, object cont, int argc, object len, ...)
|
|
{
|
|
object v = NULL;
|
|
object fill = boolean_f;
|
|
int i, ulen;
|
|
size_t element_vec_size;
|
|
va_list ap;
|
|
make_pair(tmp_pair, NULL, NULL);
|
|
make_c_opaque(opq, NULL);
|
|
va_start(ap, len);
|
|
if (argc > 1) {
|
|
fill = va_arg(ap, object);
|
|
}
|
|
va_end(ap);
|
|
Cyc_check_num(data, len);
|
|
ulen = unbox_number(len);
|
|
element_vec_size = sizeof(object) * ulen;
|
|
|
|
if (element_vec_size >= MAX_STACK_OBJ) {
|
|
// If vector is too large to allocate on the stack, allocate on heap
|
|
//
|
|
// TODO: mark this thread as potentially blocking before doing
|
|
// the allocation????
|
|
int heap_grown;
|
|
v = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(vector_type) + element_vec_size,
|
|
boolean_f, // OK to populate manually over here
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
((vector) v)->hdr.mark = ((gc_thread_data *)data)->gc_alloc_color;
|
|
((vector) v)->hdr.grayed = 0;
|
|
((vector) v)->hdr.immutable = 0;
|
|
((vector) v)->tag = vector_tag;
|
|
((vector) v)->num_elements = ulen;
|
|
((vector) v)->elements = (object *)(((char *)v) + sizeof(vector_type));
|
|
// Use write barrier to ensure fill is moved to heap if it is on the stack
|
|
// Otherwise if next minor GC misses fill it could be catastrophic
|
|
car(&tmp_pair) = fill;
|
|
add_mutation(data, &tmp_pair, -1, fill);
|
|
// Add a special object to indicate full vector must be scanned by GC
|
|
opaque_ptr(&opq) = v;
|
|
add_mutation(data, &opq, -1, v);
|
|
} else {
|
|
v = alloca(sizeof(vector_type));
|
|
((vector) v)->hdr.mark = gc_color_red;
|
|
((vector) v)->hdr.grayed = 0;
|
|
((vector) v)->hdr.immutable = 0;
|
|
((vector) v)->tag = vector_tag;
|
|
((vector) v)->num_elements = ulen;
|
|
((vector) v)->elements = NULL;
|
|
|
|
if (ulen > 0) {
|
|
((vector) v)->elements =
|
|
(object *) alloca(sizeof(object) * ((vector) v)->num_elements);
|
|
}
|
|
}
|
|
|
|
for (i = 0; i < ((vector) v)->num_elements; i++) {
|
|
((vector) v)->elements[i] = fill;
|
|
}
|
|
_return_closcall1(data, cont, v);
|
|
}
|
|
|
|
object Cyc_make_bytevector(void *data, object cont, int argc, object len, ...)
|
|
{
|
|
object bv = NULL;
|
|
object fill = obj_int2obj(0);
|
|
int length, fill_val;
|
|
va_list ap;
|
|
va_start(ap, len);
|
|
if (argc > 1) {
|
|
fill = va_arg(ap, object);
|
|
}
|
|
va_end(ap);
|
|
Cyc_check_num(data, len);
|
|
length = unbox_number(len);
|
|
|
|
if (length >= MAX_STACK_OBJ) {
|
|
int heap_grown;
|
|
bv = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(bytevector_type) + length,
|
|
boolean_f, // OK to populate manually over here
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
((bytevector) bv)->hdr.mark = ((gc_thread_data *)data)->gc_alloc_color;
|
|
((bytevector) bv)->hdr.grayed = 0;
|
|
((bytevector) bv)->hdr.immutable = 0;
|
|
((bytevector) bv)->tag = bytevector_tag;
|
|
((bytevector) bv)->len = length;
|
|
((bytevector) bv)->data = (char *)(((char *)bv) + sizeof(bytevector_type));
|
|
} else {
|
|
bv = alloca(sizeof(bytevector_type));
|
|
((bytevector) bv)->hdr.mark = gc_color_red;
|
|
((bytevector) bv)->hdr.grayed = 0;
|
|
((bytevector) bv)->hdr.immutable = 0;
|
|
((bytevector) bv)->tag = bytevector_tag;
|
|
((bytevector) bv)->len = length;
|
|
((bytevector) bv)->data = alloca(sizeof(char) * length);
|
|
}
|
|
|
|
if (argc > 1) {
|
|
Cyc_check_num(data, fill);
|
|
fill_val = unbox_number(fill);
|
|
memset(((bytevector) bv)->data, (unsigned char)fill_val, length);
|
|
}
|
|
_return_closcall1(data, cont, bv);
|
|
}
|
|
|
|
#define Cyc_bytevector_va_list(argc) { \
|
|
int i = 0, val; \
|
|
va_list ap; \
|
|
object tmp; \
|
|
char *buffer; \
|
|
make_empty_bytevector(bv); \
|
|
if (argc > 0) { \
|
|
Cyc_check_num(data, bval); \
|
|
buffer = alloca(sizeof(char) * argc); \
|
|
val = unbox_number(bval); \
|
|
buffer[i] = val; \
|
|
va_start(ap, bval); \
|
|
for(i = 1; i < argc; i++) { \
|
|
tmp = va_arg(ap, object); \
|
|
Cyc_check_num(data, tmp); \
|
|
val = unbox_number(tmp); \
|
|
buffer[i] = (unsigned char)val; \
|
|
} \
|
|
va_end(ap); \
|
|
bv.len = argc; \
|
|
bv.data = buffer; \
|
|
} \
|
|
_return_closcall1(data, cont, &bv); \
|
|
}
|
|
|
|
object dispatch_bytevector(void *data, int _argc, object clo, object cont,
|
|
object bval, ...)
|
|
{
|
|
Cyc_bytevector_va_list((_argc - 1));
|
|
}
|
|
|
|
object Cyc_bytevector(void *data, object cont, int _argc, object bval, ...)
|
|
{
|
|
Cyc_bytevector_va_list(_argc);
|
|
}
|
|
|
|
#define Cyc_bytevector_append_va_list(argc) { \
|
|
int i = 0, buf_idx = 0, total_length = 0; \
|
|
va_list ap; \
|
|
object tmp; \
|
|
char *buffer; \
|
|
char **buffers = NULL; \
|
|
int *lengths = NULL; \
|
|
make_empty_bytevector(result); \
|
|
if (argc > 0) { \
|
|
buffers = alloca(sizeof(char *) * argc); \
|
|
lengths = alloca(sizeof(int) * argc); \
|
|
Cyc_check_bvec(data, bv); \
|
|
total_length = ((bytevector)bv)->len; \
|
|
lengths[0] = ((bytevector)bv)->len; \
|
|
buffers[0] = ((bytevector)bv)->data; \
|
|
va_start(ap, bv); \
|
|
for(i = 1; i < argc; i++) { \
|
|
tmp = va_arg(ap, object); \
|
|
Cyc_check_bvec(data, tmp); \
|
|
total_length += ((bytevector)tmp)->len; \
|
|
lengths[i] = ((bytevector)tmp)->len; \
|
|
buffers[i] = ((bytevector)tmp)->data; \
|
|
} \
|
|
va_end(ap); \
|
|
buffer = alloca(sizeof(char) * total_length); \
|
|
for (i = 0; i < argc; i++) { \
|
|
memcpy(&buffer[buf_idx], buffers[i], lengths[i]); \
|
|
buf_idx += lengths[i]; \
|
|
} \
|
|
result.len = total_length; \
|
|
result.data = buffer; \
|
|
} \
|
|
_return_closcall1(data, cont, &result); \
|
|
}
|
|
|
|
object dispatch_bytevector_91append(void *data, int _argc, object clo,
|
|
object cont, object bv, ...)
|
|
{
|
|
Cyc_bytevector_append_va_list((_argc - 1));
|
|
}
|
|
|
|
object Cyc_bytevector_append(void *data, object cont, int _argc, object bv, ...)
|
|
{
|
|
Cyc_bytevector_append_va_list(_argc);
|
|
}
|
|
|
|
object Cyc_bytevector_copy(void *data, object cont, object bv, object start,
|
|
object end)
|
|
{
|
|
int s, e;
|
|
int len;
|
|
|
|
Cyc_check_bvec(data, bv);
|
|
Cyc_check_num(data, start);
|
|
Cyc_check_num(data, end);
|
|
|
|
s = unbox_number(start);
|
|
e = unbox_number(end);
|
|
len = e - s;
|
|
|
|
if (s < 0 || s >= ((bytevector) bv)->len) {
|
|
Cyc_rt_raise2(data, "bytevector-copy - invalid start", start);
|
|
}
|
|
|
|
if (e < 0 || e < s || e > ((bytevector) bv)->len) {
|
|
Cyc_rt_raise2(data, "bytevector-copy - invalid end", end);
|
|
}
|
|
|
|
if (len >= MAX_STACK_OBJ) {
|
|
int heap_grown;
|
|
object result = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(bytevector_type) + len,
|
|
boolean_f, // OK to populate manually over here
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
((bytevector) result)->hdr.mark = ((gc_thread_data *)data)->gc_alloc_color;
|
|
((bytevector) result)->hdr.grayed = 0;
|
|
((bytevector) result)->hdr.immutable = 0;
|
|
((bytevector) result)->tag = bytevector_tag;
|
|
((bytevector) result)->len = len;
|
|
((bytevector) result)->data = (char *)(((char *)result) + sizeof(bytevector_type));
|
|
memcpy(&(((bytevector) result)->data[0]), &(((bytevector) bv)->data)[s], len);
|
|
_return_closcall1(data, cont, result);
|
|
} else {
|
|
make_empty_bytevector(result);
|
|
result.len = len;
|
|
result.data = alloca(sizeof(char) * len);
|
|
memcpy(&result.data[0], &(((bytevector) bv)->data)[s], len);
|
|
_return_closcall1(data, cont, &result);
|
|
}
|
|
}
|
|
|
|
object Cyc_utf82string(void *data, object cont, object bv, object start,
|
|
object end)
|
|
{
|
|
const char *buf;
|
|
int s, e;
|
|
int len;
|
|
|
|
Cyc_check_bvec(data, bv);
|
|
Cyc_check_num(data, start);
|
|
Cyc_check_num(data, end);
|
|
|
|
buf = ((bytevector) bv)->data;
|
|
s = unbox_number(start);
|
|
e = unbox_number(end);
|
|
len = e - s;
|
|
|
|
if (s < 0 || (s >= ((bytevector) bv)->len && len > 0)) {
|
|
Cyc_rt_raise2(data, "utf8->string - invalid start", start);
|
|
}
|
|
|
|
if (e < 0 || e < s || e > ((bytevector) bv)->len) {
|
|
Cyc_rt_raise2(data, "utf8->string - invalid end", end);
|
|
}
|
|
|
|
{
|
|
object st;
|
|
alloc_string(data, st, len, len);
|
|
memcpy(((string_type *)st)->str, &buf[s], len);
|
|
((string_type *)st)->str[len] = '\0';
|
|
((string_type *)st)->num_cp = Cyc_utf8_count_code_points((uint8_t *)(((string_type *)st)->str));
|
|
_return_closcall1(data, cont, st);
|
|
}
|
|
}
|
|
|
|
object Cyc_string2utf8(void *data, object cont, object str, object start,
|
|
object end)
|
|
{
|
|
int s, e;
|
|
int len;
|
|
|
|
Cyc_check_str(data, str);
|
|
Cyc_check_fixnum(data, start);
|
|
Cyc_check_fixnum(data, end);
|
|
|
|
s = unbox_number(start);
|
|
e = unbox_number(end);
|
|
len = e - s;
|
|
|
|
if (s < 0 || (s >= string_num_cp(str) && len > 0)) {
|
|
Cyc_rt_raise2(data, "string->utf8 - invalid start", start);
|
|
}
|
|
|
|
if (e < 0 || e < s || e > string_num_cp(str)) {
|
|
Cyc_rt_raise2(data, "string->utf8 - invalid end", end);
|
|
}
|
|
|
|
// Fast path
|
|
if (string_num_cp(str) == string_len(str)) {
|
|
if (len >= MAX_STACK_OBJ) {
|
|
int heap_grown;
|
|
object bv = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(bytevector_type) + len,
|
|
boolean_f, // OK to populate manually over here
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
((bytevector) bv)->hdr.mark = ((gc_thread_data *)data)->gc_alloc_color;
|
|
((bytevector) bv)->hdr.grayed = 0;
|
|
((bytevector) bv)->hdr.immutable = 0;
|
|
((bytevector) bv)->tag = bytevector_tag;
|
|
((bytevector) bv)->len = len;
|
|
((bytevector) bv)->data = (char *)(((char *)bv) + sizeof(bytevector_type));
|
|
memcpy(&(((bytevector) bv)->data[0]), &(string_str(str))[s], len);
|
|
_return_closcall1(data, cont, bv);
|
|
} else {
|
|
make_empty_bytevector(result);
|
|
result.len = len;
|
|
result.data = alloca(sizeof(char) * len);
|
|
memcpy(&result.data[0], &(string_str(str))[s], len);
|
|
_return_closcall1(data, cont, &result);
|
|
}
|
|
} else {
|
|
const char *tmp = string_str(str);
|
|
char_type codepoint;
|
|
uint32_t state = 0;
|
|
int num_ch, cur_ch_bytes = 0, start_i = 0, end_i = 0;
|
|
// Figure out start / end indices
|
|
for (num_ch = 0; *tmp; ++tmp){
|
|
cur_ch_bytes++;
|
|
if (!Cyc_utf8_decode(&state, &codepoint, (uint8_t)*tmp)){
|
|
end_i += cur_ch_bytes;
|
|
num_ch += 1;
|
|
cur_ch_bytes = 0;
|
|
|
|
if (num_ch == s) {
|
|
start_i = end_i;
|
|
}
|
|
if (num_ch == e) {
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
len = end_i - start_i;
|
|
if (len >= MAX_STACK_OBJ) {
|
|
int heap_grown;
|
|
object bv = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(bytevector_type) + len,
|
|
boolean_f, // OK to populate manually over here
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
((bytevector) bv)->hdr.mark = ((gc_thread_data *)data)->gc_alloc_color;
|
|
((bytevector) bv)->hdr.grayed = 0;
|
|
((bytevector) bv)->hdr.immutable = 0;
|
|
((bytevector) bv)->tag = bytevector_tag;
|
|
((bytevector) bv)->len = len;
|
|
((bytevector) bv)->data = (char *)(((char *)bv) + sizeof(bytevector_type));
|
|
memcpy(&(((bytevector) bv)->data[0]), &(string_str(str))[start_i], len);
|
|
_return_closcall1(data, cont, bv);
|
|
} else {
|
|
make_empty_bytevector(result);
|
|
result.len = len;
|
|
result.data = alloca(sizeof(char) * result.len);
|
|
memcpy(&result.data[0], &(string_str(str))[start_i], result.len);
|
|
_return_closcall1(data, cont, &result);
|
|
}
|
|
}
|
|
}
|
|
|
|
object Cyc_bytevector_u8_ref(void *data, object bv, object k)
|
|
{
|
|
const char *buf;
|
|
int idx;
|
|
int val;
|
|
|
|
Cyc_check_bvec(data, bv);
|
|
Cyc_check_fixnum(data, k);
|
|
|
|
buf = ((bytevector) bv)->data;
|
|
idx = unbox_number(k);
|
|
|
|
if (idx < 0 || idx >= ((bytevector) bv)->len) {
|
|
Cyc_rt_raise2(data, "bytevector-u8-ref - invalid index", k);
|
|
}
|
|
|
|
val = (unsigned char)(buf[idx]);
|
|
return obj_int2obj(val);
|
|
}
|
|
|
|
object Cyc_bytevector_u8_set(void *data, object bv, object k, object b)
|
|
{
|
|
char *buf;
|
|
int idx, len, val;
|
|
|
|
Cyc_check_bvec(data, bv);
|
|
Cyc_check_fixnum(data, k);
|
|
Cyc_check_fixnum(data, b);
|
|
Cyc_verify_mutable(data, bv);
|
|
|
|
buf = ((bytevector) bv)->data;
|
|
idx = unbox_number(k);
|
|
val = unbox_number(b);
|
|
len = ((bytevector) bv)->len;
|
|
|
|
Cyc_check_bounds(data, "bytevector-u8-set!", len, idx);
|
|
buf[idx] = (unsigned char)val;
|
|
return bv;
|
|
}
|
|
|
|
object Cyc_bytevector_length(void *data, object bv)
|
|
{
|
|
if ((bv != NULL) && !is_value_type(bv) && ((list) bv)->tag == bytevector_tag) {
|
|
return obj_int2obj(((bytevector) bv)->len);
|
|
}
|
|
Cyc_rt_raise_msg(data,
|
|
"bytevector-length - invalid parameter, expected bytevector\n");
|
|
return NULL;
|
|
}
|
|
|
|
object Cyc_list2vector(void *data, object cont, object l)
|
|
{
|
|
object v = NULL;
|
|
object len_obj;
|
|
object lst = l;
|
|
int len, i = 0;
|
|
size_t element_vec_size;
|
|
|
|
make_c_opaque(opq, NULL);
|
|
Cyc_check_pair_or_null(data, l);
|
|
len_obj = Cyc_length(data, l);
|
|
len = obj_obj2int(len_obj);
|
|
element_vec_size = sizeof(object) * len;
|
|
if (element_vec_size >= MAX_STACK_OBJ) {
|
|
int heap_grown;
|
|
v = gc_alloc(((gc_thread_data *)data)->heap,
|
|
sizeof(vector_type) + element_vec_size,
|
|
boolean_f, // OK to populate manually over here
|
|
(gc_thread_data *)data,
|
|
&heap_grown);
|
|
((vector) v)->hdr.mark = ((gc_thread_data *)data)->gc_alloc_color;
|
|
((vector) v)->hdr.grayed = 0;
|
|
((vector) v)->hdr.immutable = 0;
|
|
((vector) v)->tag = vector_tag;
|
|
((vector) v)->num_elements = len;
|
|
((vector) v)->elements = (object *)(((char *)v) + sizeof(vector_type));
|
|
// TODO: do we need to worry about stack object in the list????
|
|
//// Use write barrier to ensure fill is moved to heap if it is on the stack
|
|
//// Otherwise if next minor GC misses fill it could be catastrophic
|
|
//car(&tmp_pair) = fill;
|
|
//add_mutation(data, &tmp_pair, -1, fill);
|
|
// Add a special object to indicate full vector must be scanned by GC
|
|
opaque_ptr(&opq) = v;
|
|
add_mutation(data, &opq, -1, v);
|
|
} else {
|
|
v = alloca(sizeof(vector_type));
|
|
((vector) v)->hdr.mark = gc_color_red;
|
|
((vector) v)->hdr.grayed = 0;
|
|
((vector) v)->hdr.immutable = 0;
|
|
((vector) v)->tag = vector_tag;
|
|
((vector) v)->num_elements = len;
|
|
((vector) v)->elements =
|
|
(((vector) v)->num_elements > 0) ?
|
|
(object *) alloca(element_vec_size) : NULL;
|
|
}
|
|
while ((lst != NULL)) {
|
|
((vector) v)->elements[i++] = car(lst);
|
|
lst = cdr(lst);
|
|
}
|
|
_return_closcall1(data, cont, v);
|
|
}
|
|
|
|
object Cyc_system(object cmd)
|
|
{
|
|
if ((cmd == NULL) || is_value_type(cmd) || type_of(cmd) != string_tag) {
|
|
return obj_int2obj(-1);
|
|
}
|
|
return obj_int2obj(system(((string_type *) cmd)->str));
|
|
}
|
|
|
|
#define declare_char_comp(FUNC, OP) \
|
|
object FUNC(void *data, object a, object b) \
|
|
{ \
|
|
if (obj_obj2char(a) OP obj_obj2char(b)) \
|
|
return boolean_t; \
|
|
return boolean_f; \
|
|
}
|
|
declare_char_comp(Cyc_char_eq_op, ==);
|
|
declare_char_comp(Cyc_char_gt_op, > );
|
|
declare_char_comp(Cyc_char_lt_op, < );
|
|
declare_char_comp(Cyc_char_gte_op, >=);
|
|
declare_char_comp(Cyc_char_lte_op, <=);
|
|
|
|
object Cyc_char2integer(object chr)
|
|
{
|
|
return obj_int2obj(obj_obj2char(chr));
|
|
}
|
|
|
|
object Cyc_integer2char(void *data, object n)
|
|
{
|
|
char_type val = 0;
|
|
|
|
Cyc_check_num(data, n);
|
|
val = unbox_number(n);
|
|
return obj_char2obj(val);
|
|
}
|
|
|
|
void Cyc_halt(object obj)
|
|
{
|
|
#if DEBUG_SHOW_DIAG
|
|
gc_print_stats(Cyc_heap);
|
|
#endif
|
|
if (obj_is_int(obj)) {
|
|
exit(obj_obj2int(obj));
|
|
}
|
|
|
|
if (obj == boolean_f) {
|
|
exit(1);
|
|
}
|
|
|
|
exit(0);
|
|
}
|
|
|
|
object __halt(object obj)
|
|
{
|
|
Cyc_halt(obj);
|
|
return NULL;
|
|
}
|
|
|
|
// Signed arithmetic overflow checks, based on code from CHICKEN:
|
|
|
|
static int Cyc_checked_add(int x, int y, int *result)
|
|
{
|
|
*result = x + y;
|
|
return ((((*result ^ x) & (*result ^ y)) >> 30) != 0);
|
|
}
|
|
|
|
static int Cyc_checked_sub(int x, int y, int *result)
|
|
{
|
|
*result = x - y;
|
|
return ((((*result ^ x) & ~(*result ^ y)) >> 30) != 0);
|
|
}
|
|
|
|
static int Cyc_checked_mul(int x, int y, int *result)
|
|
{
|
|
// Avoid undefined behavior by detecting overflow prior to multiplication
|
|
// Based on code from Hacker's Delight and CHICKEN scheme
|
|
uint xu, yu, c;
|
|
c = (1UL<<30UL) - 1;
|
|
xu = x < 0 ? -x : x;
|
|
yu = y < 0 ? -y : y;
|
|
|
|
if (yu != 0 && xu > (c / yu)) return 1; // Overflow
|
|
|
|
*result = x * y;
|
|
|
|
return (*result > CYC_FIXNUM_MAX) ||
|
|
(*result < CYC_FIXNUM_MIN);
|
|
}
|
|
|
|
#define declare_num_op(FUNC, FUNC_OP, FUNC_APPLY, OP, INT_OP, BN_OP, NO_ARG, ONE_ARG, DIV) \
|
|
object FUNC_OP(void *data, common_type *x, object y) { \
|
|
mp_int bn_tmp, bn_tmp2; \
|
|
int tx, ty; \
|
|
tx = type_of(x); \
|
|
if (obj_is_int(y)) { \
|
|
ty = -1; \
|
|
} else if (is_object_type(y)) { \
|
|
ty = type_of(y); \
|
|
} else { \
|
|
goto bad_arg_type_error; \
|
|
} \
|
|
if (DIV && \
|
|
((ty == -1 && (obj_obj2int(y) == 0)) || \
|
|
(ty == integer_tag && integer_value(y) == 0) || \
|
|
(ty == double_tag && double_value(y) == 0.0))) { \
|
|
Cyc_rt_raise_msg(data, "Divide by zero"); \
|
|
} \
|
|
if (tx == integer_tag && ty == -1) { \
|
|
int result; \
|
|
if (INT_OP(x->integer_t.value, obj_obj2int(y), &result) == 0) { \
|
|
x->integer_t.value = result; \
|
|
} else { \
|
|
mp_init(&bn_tmp); \
|
|
mp_init(&bn_tmp2); \
|
|
Cyc_int2bignum(x->integer_t.value, &bn_tmp); \
|
|
Cyc_int2bignum(obj_obj2int(y), &bn_tmp2); \
|
|
x->bignum_t.hdr.mark = gc_color_red; \
|
|
x->bignum_t.hdr.grayed = 0; \
|
|
x->bignum_t.tag = bignum_tag; \
|
|
mp_init(&(x->bignum_t.bn)); \
|
|
BN_OP(&bn_tmp, &bn_tmp2, &(x->bignum_t.bn)); \
|
|
mp_clear(&bn_tmp); \
|
|
mp_clear(&bn_tmp2); \
|
|
} \
|
|
} else if (tx == double_tag && ty == -1) { \
|
|
x->double_t.value = x->double_t.value OP (obj_obj2int(y)); \
|
|
} else if (tx == integer_tag && ty == integer_tag) { \
|
|
x->integer_t.value = (x->integer_t.value) OP ((integer_type *)y)->value; \
|
|
} else if (tx == double_tag && ty == integer_tag) { \
|
|
x->double_t.value = x->double_t.value OP ((integer_type *)y)->value; \
|
|
} else if (tx == integer_tag && ty == double_tag) { \
|
|
x->double_t.hdr.mark = gc_color_red; \
|
|
x->double_t.hdr.grayed = 0; \
|
|
x->double_t.tag = double_tag; \
|
|
x->double_t.value = x->integer_t.value OP ((double_type *)y)->value; \
|
|
} else if (tx == double_tag && ty == double_tag) { \
|
|
x->double_t.value = x->double_t.value OP ((double_type *)y)->value; \
|
|
} else if (tx == integer_tag && ty == bignum_tag) { \
|
|
mp_init(&bn_tmp2); \
|
|
Cyc_int2bignum(x->integer_t.value, &bn_tmp2); \
|
|
x->bignum_t.hdr.mark = gc_color_red; \
|
|
x->bignum_t.hdr.grayed = 0; \
|
|
x->bignum_t.tag = bignum_tag; \
|
|
mp_init(&(x->bignum_t.bn)); \
|
|
BN_OP(&bn_tmp2, &bignum_value(y), &(x->bignum_t.bn)); \
|
|
mp_clear(&bn_tmp2); \
|
|
} else if (tx == double_tag && ty == bignum_tag) { \
|
|
x->double_t.value = x->double_t.value OP mp_get_double(&bignum_value(y)); \
|
|
} else if (tx == bignum_tag && ty == -1) { \
|
|
mp_init(&bn_tmp2); \
|
|
Cyc_int2bignum(obj_obj2int(y), &bn_tmp2); \
|
|
BN_OP(&(x->bignum_t.bn), &bn_tmp2, &(x->bignum_t.bn)); \
|
|
mp_clear(&bn_tmp2); \
|
|
} else if (tx == bignum_tag && ty == double_tag) { \
|
|
double d = mp_get_double(&(x->bignum_t.bn)); \
|
|
mp_clear(&(x->bignum_t.bn)); \
|
|
x->double_t.hdr.mark = gc_color_red; \
|
|
x->double_t.hdr.grayed = 0; \
|
|
x->double_t.tag = double_tag; \
|
|
x->double_t.value = d OP ((double_type *)y)->value; \
|
|
} else if (tx == bignum_tag && ty == bignum_tag) { \
|
|
BN_OP(&(x->bignum_t.bn), &bignum_value(y), &(x->bignum_t.bn)); \
|
|
} else if (tx == complex_num_tag && ty == complex_num_tag) { \
|
|
x->complex_num_t.value = x->complex_num_t.value OP ((complex_num_type *)y)->value; \
|
|
} else if (tx == complex_num_tag && ty == -1) { \
|
|
x->complex_num_t.value = x->complex_num_t.value OP (obj_obj2int(y)); \
|
|
} else if (tx == complex_num_tag && ty == integer_tag) { \
|
|
x->complex_num_t.value = x->complex_num_t.value OP ((integer_type *)y)->value; \
|
|
} else if (tx == complex_num_tag && ty == bignum_tag) { \
|
|
x->complex_num_t.value = x->complex_num_t.value OP mp_get_double(&bignum_value(y)); \
|
|
} else if (tx == complex_num_tag && ty == double_tag) { \
|
|
x->complex_num_t.value = x->complex_num_t.value OP complex_num_value(y); \
|
|
} else if (tx == integer_tag && ty == complex_num_tag) { \
|
|
x->complex_num_t.hdr.mark = gc_color_red; \
|
|
x->complex_num_t.hdr.grayed = 0; \
|
|
x->complex_num_t.tag = complex_num_tag; \
|
|
x->complex_num_t.value = x->integer_t.value OP ((complex_num_type *)y)->value; \
|
|
} else if (tx == bignum_tag && ty == complex_num_tag) { \
|
|
double d = mp_get_double(&(x->bignum_t.bn)); \
|
|
mp_clear(&(x->bignum_t.bn)); \
|
|
x->complex_num_t.hdr.mark = gc_color_red; \
|
|
x->complex_num_t.hdr.grayed = 0; \
|
|
x->complex_num_t.tag = complex_num_tag; \
|
|
x->complex_num_t.value = d OP ((complex_num_type *)y)->value; \
|
|
} else if (tx == double_tag && ty == complex_num_tag) { \
|
|
x->complex_num_t.hdr.mark = gc_color_red; \
|
|
x->complex_num_t.hdr.grayed = 0; \
|
|
x->complex_num_t.tag = complex_num_tag; \
|
|
x->complex_num_t.value = x->double_t.value OP complex_num_value(y); \
|
|
} else { \
|
|
goto bad_arg_type_error; \
|
|
} \
|
|
return x; \
|
|
bad_arg_type_error: \
|
|
{ \
|
|
make_string(s, "Bad argument type"); \
|
|
make_pair(c1, y, NULL); \
|
|
make_pair(c0, &s, &c1); \
|
|
Cyc_rt_raise(data, &c0); \
|
|
return NULL; \
|
|
} \
|
|
} \
|
|
object FUNC(void *data, object cont, int argc, object n, ...) { \
|
|
common_type buffer; \
|
|
object result; \
|
|
va_list ap; \
|
|
va_start(ap, n); \
|
|
result = Cyc_num_op_va_list(data, argc, FUNC_OP, NO_ARG, ONE_ARG, n, ap, &buffer); \
|
|
va_end(ap); \
|
|
_return_closcall1(data, cont, result); \
|
|
} \
|
|
void FUNC_APPLY(void *data, int argc, object clo, object cont, object n, ...) { \
|
|
common_type buffer; \
|
|
object result; \
|
|
va_list ap; \
|
|
va_start(ap, n); \
|
|
result = Cyc_num_op_va_list(data, argc - 1, FUNC_OP, NO_ARG, ONE_ARG, n, ap, &buffer); \
|
|
va_end(ap); \
|
|
return_closcall1(data, cont, result); \
|
|
}
|
|
|
|
object Cyc_fast_sum(void *data, object ptr, object x, object y) {
|
|
// x is int (assume value types for integers)
|
|
if (obj_is_int(x)){
|
|
if (obj_is_int(y)){
|
|
int xx = obj_obj2int(x),
|
|
yy = obj_obj2int(y),
|
|
z;
|
|
|
|
if (Cyc_checked_add(xx, yy, &z) == 0) {
|
|
return obj_int2obj(z);
|
|
} else {
|
|
mp_int bnx, bny;
|
|
mp_init(&bnx);
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(xx, &bnx);
|
|
Cyc_int2bignum(yy, &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_add(&bnx, &bny, &bignum_value(bn));
|
|
mp_clear(&bnx);
|
|
mp_clear(&bny);
|
|
return bn;
|
|
}
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, (double)(obj_obj2int(x)) + double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
mp_int bnx;
|
|
mp_init(&bnx);
|
|
Cyc_int2bignum(obj_obj2int(x), &bnx);
|
|
alloc_bignum(data, bn);
|
|
mp_add(&bnx, &bignum_value(y), &bignum_value(bn));
|
|
mp_clear(&bnx);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, ((obj_obj2int(x)) + complex_num_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is double
|
|
if (is_object_type(x) && type_of(x) == double_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_double(ptr, double_value(x) + (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, double_value(x) + double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_double(ptr, double_value(x) + mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, double_value(x) + complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is bignum
|
|
if (is_object_type(x) && type_of(x) == bignum_tag) {
|
|
if (obj_is_int(y)){
|
|
mp_int bny;
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(obj_obj2int(y), &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_add(&bignum_value(x), &bny, &bignum_value(bn));
|
|
mp_clear(&bny);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, mp_get_double(&bignum_value(x)) + double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
alloc_bignum(data, bn);
|
|
mp_add(&bignum_value(x), &bignum_value(y), &bignum_value(bn));
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, mp_get_double(&bignum_value(x)) + complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is complex
|
|
if (is_object_type(x) && type_of(x) == complex_num_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_complex_num(ptr, complex_num_value(x) + (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) + double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) + complex_num_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) + mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// still here, raise an error
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c2, y, NULL);
|
|
make_pair(c1, x, &c2);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
return NULL;
|
|
}
|
|
|
|
object Cyc_fast_sub(void *data, object ptr, object x, object y) {
|
|
// x is int (assume value types for integers)
|
|
if (obj_is_int(x)){
|
|
if (obj_is_int(y)){
|
|
int xx = obj_obj2int(x),
|
|
yy = obj_obj2int(y),
|
|
z;
|
|
if (Cyc_checked_sub(xx, yy, &z) == 0) {
|
|
return obj_int2obj(z);
|
|
} else {
|
|
mp_int bnx, bny;
|
|
mp_init(&bnx);
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(xx, &bnx);
|
|
Cyc_int2bignum(yy, &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_sub(&bnx, &bny, &bignum_value(bn));
|
|
mp_clear(&bnx);
|
|
mp_clear(&bny);
|
|
return bn;
|
|
}
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, (double)(obj_obj2int(x)) - double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
mp_int bnx;
|
|
mp_init(&bnx);
|
|
Cyc_int2bignum(obj_obj2int(x), &bnx);
|
|
alloc_bignum(data, bn);
|
|
mp_sub(&bnx, &bignum_value(y), &bignum_value(bn));
|
|
mp_clear(&bnx);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, ((obj_obj2int(x)) - complex_num_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is double
|
|
if (is_object_type(x) && type_of(x) == double_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_double(ptr, double_value(x) - (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, double_value(x) - double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_double(ptr, double_value(x) - mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, double_value(x) - complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is bignum
|
|
if (is_object_type(x) && type_of(x) == bignum_tag) {
|
|
if (obj_is_int(y)){
|
|
mp_int bny;
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(obj_obj2int(y), &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_sub(&bignum_value(x), &bny, &bignum_value(bn));
|
|
mp_clear(&bny);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, mp_get_double(&bignum_value(x)) - double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
alloc_bignum(data, bn);
|
|
mp_sub(&bignum_value(x), &bignum_value(y), &bignum_value(bn));
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, mp_get_double(&bignum_value(x)) - complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is complex
|
|
if (is_object_type(x) && type_of(x) == complex_num_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_complex_num(ptr, complex_num_value(x) - (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) - double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) - complex_num_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) - mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// still here, raise an error
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c2, y, NULL);
|
|
make_pair(c1, x, &c2);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
return NULL;
|
|
}
|
|
|
|
object Cyc_fast_mul(void *data, object ptr, object x, object y) {
|
|
// x is int (assume value types for integers)
|
|
if (obj_is_int(x)){
|
|
if (obj_is_int(y)){
|
|
int xx = obj_obj2int(x),
|
|
yy = obj_obj2int(y),
|
|
z;
|
|
if (Cyc_checked_mul(xx, yy, &z) == 0) {
|
|
return obj_int2obj(z);
|
|
} else {
|
|
mp_int bnx, bny;
|
|
mp_init(&bnx);
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(xx, &bnx);
|
|
Cyc_int2bignum(yy, &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_mul(&bnx, &bny, &bignum_value(bn));
|
|
mp_clear(&bnx);
|
|
mp_clear(&bny);
|
|
return bn;
|
|
}
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, (double)(obj_obj2int(x)) * double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
mp_int bnx;
|
|
mp_init(&bnx);
|
|
Cyc_int2bignum(obj_obj2int(x), &bnx);
|
|
alloc_bignum(data, bn);
|
|
mp_mul(&bnx, &bignum_value(y), &bignum_value(bn));
|
|
mp_clear(&bnx);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, ((obj_obj2int(x)) * complex_num_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is double
|
|
if (is_object_type(x) && type_of(x) == double_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_double(ptr, double_value(x) * (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, double_value(x) * double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_double(ptr, double_value(x) * mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, double_value(x) * complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is bignum
|
|
if (is_object_type(x) && type_of(x) == bignum_tag) {
|
|
if (obj_is_int(y)){
|
|
mp_int bny;
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(obj_obj2int(y), &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_mul(&bignum_value(x), &bny, &bignum_value(bn));
|
|
mp_clear(&bny);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, mp_get_double(&bignum_value(x)) * double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
alloc_bignum(data, bn);
|
|
mp_mul(&bignum_value(x), &bignum_value(y), &bignum_value(bn));
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, mp_get_double(&bignum_value(x)) * complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is complex
|
|
if (is_object_type(x) && type_of(x) == complex_num_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_complex_num(ptr, complex_num_value(x) * (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) * double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) * complex_num_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) * mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// still here, raise an error
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c2, y, NULL);
|
|
make_pair(c1, x, &c2);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
return NULL;
|
|
}
|
|
|
|
object Cyc_fast_div(void *data, object ptr, object x, object y) {
|
|
int z;
|
|
// x is int (assume value types for integers)
|
|
if (obj_is_int(x)){
|
|
if (obj_is_int(y)){
|
|
if (obj_obj2int(y) == 0) { goto divbyzero; }
|
|
// Overflow can occur if y = 0 || (x = 0x80000000 && y = -1)
|
|
// We already check for 0 above and the value of x above is a
|
|
// bignum, so no futher checks are required.
|
|
z = obj_obj2int(x) / obj_obj2int(y);
|
|
return obj_int2obj(z);
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, (double)(obj_obj2int(x)) / double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
mp_int bnx;
|
|
mp_init(&bnx);
|
|
Cyc_int2bignum(obj_obj2int(x), &bnx);
|
|
alloc_bignum(data, bn);
|
|
mp_div(&bnx, &bignum_value(y), &bignum_value(bn), NULL);
|
|
mp_clear(&bnx);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, ((obj_obj2int(x)) / complex_num_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is double
|
|
if (is_object_type(x) && type_of(x) == double_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_double(ptr, double_value(x) / (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, double_value(x) / double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_double(ptr, double_value(x) / mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, double_value(x) / complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is bignum
|
|
if (is_object_type(x) && type_of(x) == bignum_tag) {
|
|
if (obj_is_int(y)){
|
|
mp_int bny;
|
|
mp_init(&bny);
|
|
Cyc_int2bignum(obj_obj2int(y), &bny);
|
|
alloc_bignum(data, bn);
|
|
mp_div(&bignum_value(x), &bny, &bignum_value(bn), NULL);
|
|
mp_clear(&bny);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_double(ptr, mp_get_double(&bignum_value(x)) / double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
alloc_bignum(data, bn);
|
|
mp_div(&bignum_value(x), &bignum_value(y), &bignum_value(bn), NULL);
|
|
return bn;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, mp_get_double(&bignum_value(x)) / complex_num_value(y));
|
|
return ptr;
|
|
}
|
|
}
|
|
// x is complex
|
|
if (is_object_type(x) && type_of(x) == complex_num_tag) {
|
|
if (obj_is_int(y)){
|
|
assign_complex_num(ptr, complex_num_value(x) / (double)(obj_obj2int(y)));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) / double_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == complex_num_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) / complex_num_value(y));
|
|
return ptr;
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
assign_complex_num(ptr, complex_num_value(x) / mp_get_double(&bignum_value(y)));
|
|
return ptr;
|
|
}
|
|
}
|
|
// still here, raise an error
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c2, y, NULL);
|
|
make_pair(c1, x, &c2);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
divbyzero:
|
|
Cyc_rt_raise_msg(data, "Divide by zero");
|
|
return NULL;
|
|
}
|
|
|
|
object Cyc_div_op(void *data, common_type * x, object y)
|
|
{
|
|
mp_int bn_tmp2;
|
|
int tx = type_of(x), ty;
|
|
if (obj_is_int(y)) {
|
|
ty = -1;
|
|
} else if (is_object_type(y)) {
|
|
ty = type_of(y);
|
|
} else {
|
|
goto bad_arg_type_error;
|
|
}
|
|
if (tx == integer_tag && ty == -1) {
|
|
if (obj_obj2int(y) == 0) {
|
|
Cyc_rt_raise_msg(data, "Divide by zero");
|
|
}
|
|
x->double_t.tag = double_tag;
|
|
x->double_t.value = ((double)x->integer_t.value) / (obj_obj2int(y));
|
|
} else if (tx == double_tag && ty == -1) {
|
|
x->double_t.value = x->double_t.value / (obj_obj2int(y));
|
|
} else if (tx == integer_tag && ty == integer_tag) {
|
|
x->double_t.tag = double_tag;
|
|
x->double_t.value =
|
|
((double)x->integer_t.value) / ((integer_type *) y)->value;
|
|
} else if (tx == double_tag && ty == integer_tag) {
|
|
x->double_t.value = x->double_t.value / ((integer_type *) y)->value;
|
|
} else if (tx == integer_tag && ty == double_tag) {
|
|
x->double_t.hdr.mark = gc_color_red;
|
|
x->double_t.hdr.grayed = 0;
|
|
x->double_t.tag = double_tag;
|
|
x->double_t.value = x->integer_t.value / ((double_type *) y)->value;
|
|
} else if (tx == double_tag && ty == double_tag) {
|
|
x->double_t.value = x->double_t.value / ((double_type *) y)->value;
|
|
} else if (tx == integer_tag && ty == bignum_tag) {
|
|
mp_init(&bn_tmp2);
|
|
Cyc_int2bignum(x->integer_t.value, &bn_tmp2);
|
|
x->bignum_t.hdr.mark = gc_color_red;
|
|
x->bignum_t.hdr.grayed = 0;
|
|
x->bignum_t.tag = bignum_tag;
|
|
mp_init(&(x->bignum_t.bn));
|
|
mp_div(&bn_tmp2, &bignum_value(y), &(x->bignum_t.bn), NULL);
|
|
mp_clear(&bn_tmp2);
|
|
} else if (tx == double_tag && ty == bignum_tag) {
|
|
x->double_t.value = x->double_t.value / mp_get_double(&bignum_value(y));
|
|
} else if (tx == bignum_tag && ty == -1) {
|
|
mp_init(&bn_tmp2);
|
|
Cyc_int2bignum(obj_obj2int(y), &bn_tmp2);
|
|
mp_div(&(x->bignum_t.bn), &bn_tmp2, &(x->bignum_t.bn), NULL);
|
|
mp_clear(&bn_tmp2);
|
|
} else if (tx == bignum_tag && ty == double_tag) {
|
|
double d = mp_get_double(&(x->bignum_t.bn));
|
|
mp_clear(&(x->bignum_t.bn));
|
|
x->double_t.hdr.mark = gc_color_red;
|
|
x->double_t.hdr.grayed = 0;
|
|
x->double_t.tag = double_tag;
|
|
x->double_t.value = d / ((double_type *)y)->value;
|
|
} else if (tx == bignum_tag && ty == bignum_tag) {
|
|
mp_div(&(x->bignum_t.bn), &bignum_value(y), &(x->bignum_t.bn), NULL);
|
|
} else if (tx == complex_num_tag && ty == complex_num_tag) {
|
|
x->complex_num_t.value = x->complex_num_t.value / ((complex_num_type *)y)->value;
|
|
} else if (tx == complex_num_tag && ty == -1) {
|
|
x->complex_num_t.value = x->complex_num_t.value / (obj_obj2int(y));
|
|
} else if (tx == complex_num_tag && ty == integer_tag) {
|
|
x->complex_num_t.value = x->complex_num_t.value / ((integer_type *)y)->value;
|
|
} else if (tx == complex_num_tag && ty == bignum_tag) {
|
|
x->complex_num_t.value = x->complex_num_t.value / mp_get_double(&bignum_value(y));
|
|
} else if (tx == complex_num_tag && ty == double_tag) {
|
|
x->complex_num_t.value = x->complex_num_t.value / complex_num_value(y);
|
|
} else if (tx == integer_tag && ty == complex_num_tag) {
|
|
x->complex_num_t.hdr.mark = gc_color_red;
|
|
x->complex_num_t.hdr.grayed = 0;
|
|
x->complex_num_t.tag = complex_num_tag;
|
|
x->complex_num_t.value = x->integer_t.value / ((complex_num_type *)y)->value;
|
|
} else if (tx == bignum_tag && ty == complex_num_tag) {
|
|
double d = mp_get_double(&(x->bignum_t.bn));
|
|
mp_clear(&(x->bignum_t.bn));
|
|
x->complex_num_t.hdr.mark = gc_color_red;
|
|
x->complex_num_t.hdr.grayed = 0;
|
|
x->complex_num_t.tag = complex_num_tag;
|
|
x->complex_num_t.value = d / ((complex_num_type *)y)->value;
|
|
} else if (tx == double_tag && ty == complex_num_tag) {
|
|
x->complex_num_t.hdr.mark = gc_color_red;
|
|
x->complex_num_t.hdr.grayed = 0;
|
|
x->complex_num_t.tag = complex_num_tag;
|
|
x->complex_num_t.value = x->double_t.value / complex_num_value(y);
|
|
} else {
|
|
goto bad_arg_type_error;
|
|
}
|
|
return x;
|
|
bad_arg_type_error:
|
|
{
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c1, y, NULL);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
object Cyc_div(void *data, object cont, int argc, object n, ...)
|
|
{
|
|
common_type buffer;
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, n);
|
|
result = Cyc_num_op_va_list(data, argc, Cyc_div_op, -1, 1, n, ap, &buffer);
|
|
va_end(ap);
|
|
_return_closcall1(data, cont, result);
|
|
}
|
|
|
|
void dispatch_div(void *data, int argc, object clo, object cont, object n, ...)
|
|
{
|
|
common_type buffer;
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, n);
|
|
result =
|
|
Cyc_num_op_va_list(data, argc - 1, Cyc_div_op, -1, 1, n, ap, &buffer);
|
|
va_end(ap);
|
|
return_closcall1(data, cont, result);
|
|
}
|
|
|
|
declare_num_op(Cyc_sum, Cyc_sum_op, dispatch_sum, +, Cyc_checked_add, mp_add, 0, 0, 0);
|
|
declare_num_op(Cyc_sub, Cyc_sub_op, dispatch_sub, -, Cyc_checked_sub, mp_sub, -1, 0, 0);
|
|
declare_num_op(Cyc_mul, Cyc_mul_op, dispatch_mul, *, Cyc_checked_mul, mp_mul, 1, 1, 0);
|
|
|
|
object Cyc_num_op_va_list(void *data, int argc,
|
|
object(fn_op(void *, common_type *, object)),
|
|
int default_no_args, int default_one_arg, object n,
|
|
va_list ns, common_type * buf)
|
|
{
|
|
int i;
|
|
if (argc == 0) {
|
|
if (default_no_args < 0) {
|
|
Cyc_rt_raise_msg(data, "No arguments for numeric operation");
|
|
}
|
|
buf->integer_t.hdr.mark = gc_color_red;
|
|
buf->integer_t.hdr.grayed = 0;
|
|
buf->integer_t.tag = integer_tag;
|
|
buf->integer_t.value = default_no_args;
|
|
return buf;
|
|
}
|
|
|
|
if (obj_is_int(n)) {
|
|
buf->integer_t.hdr.mark = gc_color_red;
|
|
buf->integer_t.hdr.grayed = 0;
|
|
buf->integer_t.tag = integer_tag;
|
|
buf->integer_t.value = obj_obj2int(n);
|
|
} else if (!is_object_type(n)) {
|
|
goto bad_arg_type_error;
|
|
} else if (type_of(n) == integer_tag) {
|
|
buf->integer_t.hdr.mark = gc_color_red;
|
|
buf->integer_t.hdr.grayed = 0;
|
|
buf->integer_t.tag = integer_tag;
|
|
buf->integer_t.value = ((integer_type *) n)->value;
|
|
} else if (type_of(n) == double_tag) {
|
|
buf->double_t.hdr.mark = gc_color_red;
|
|
buf->double_t.hdr.grayed = 0;
|
|
buf->double_t.tag = double_tag;
|
|
buf->double_t.value = ((double_type *) n)->value;
|
|
} else if (type_of(n) == bignum_tag) {
|
|
buf->bignum_t.hdr.mark = gc_color_red;
|
|
buf->bignum_t.hdr.grayed = 0;
|
|
buf->bignum_t.tag = bignum_tag;
|
|
mp_init_copy(&(buf->bignum_t.bn), &bignum_value(n));
|
|
} else if (type_of(n) == complex_num_tag) {
|
|
buf->complex_num_t.hdr.mark = gc_color_red;
|
|
buf->complex_num_t.hdr.grayed = 0;
|
|
buf->complex_num_t.tag = complex_num_tag;
|
|
buf->complex_num_t.value = ((complex_num_type *) n)->value;
|
|
} else {
|
|
goto bad_arg_type_error;
|
|
}
|
|
|
|
if (argc == 1) {
|
|
common_type tmp;
|
|
tmp.integer_t.hdr.mark = gc_color_red;
|
|
tmp.integer_t.hdr.grayed = 0;
|
|
tmp.integer_t.tag = integer_tag;
|
|
tmp.integer_t.value = default_one_arg;
|
|
|
|
fn_op(data, &tmp, (object) buf);
|
|
if (type_of(&tmp) == integer_tag) {
|
|
buf->integer_t.tag = integer_tag;
|
|
buf->integer_t.value = integer_value(&tmp);
|
|
} else if (type_of(&tmp) == double_tag){
|
|
buf->double_t.tag = double_tag;
|
|
buf->double_t.value = double_value(&tmp);
|
|
} else if (type_of(&tmp) == complex_num_tag){
|
|
buf->complex_num_t.tag = complex_num_tag;
|
|
buf->complex_num_t.value = complex_num_value(&tmp);
|
|
} else {
|
|
buf->bignum_t.tag = bignum_tag;
|
|
buf->bignum_t.bn.used = tmp.bignum_t.bn.used;
|
|
buf->bignum_t.bn.alloc = tmp.bignum_t.bn.alloc;
|
|
buf->bignum_t.bn.sign = tmp.bignum_t.bn.sign;
|
|
buf->bignum_t.bn.dp = tmp.bignum_t.bn.dp;
|
|
}
|
|
} else {
|
|
for (i = 1; i < argc; i++) {
|
|
fn_op(data, buf, va_arg(ns, object));
|
|
}
|
|
}
|
|
|
|
// Convert to immediate int
|
|
if (type_of(buf) == integer_tag) {
|
|
return obj_int2obj(buf->integer_t.value);
|
|
} else if (type_of(buf) == bignum_tag) {
|
|
buf = gc_alloc_from_bignum(data, &(buf->bignum_t));
|
|
}
|
|
|
|
return buf;
|
|
bad_arg_type_error:
|
|
{
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c1, n, NULL);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
return NULL;
|
|
}
|
|
}
|
|
|
|
void Cyc_expt_double(void *data, object cont, double x, double y)
|
|
{
|
|
make_double(d, pow(x, y));
|
|
return_closcall1(data, cont, &d);
|
|
}
|
|
|
|
void Cyc_expt(void *data, object cont, object x, object y)
|
|
{
|
|
if (obj_is_int(x)){
|
|
if (obj_is_int(y)){
|
|
if (obj_obj2int(y) < 0) {
|
|
Cyc_expt_double(data, cont, (double)obj_obj2int(x), (double)obj_obj2int(y));
|
|
} else {
|
|
alloc_bignum(data, bn);
|
|
Cyc_int2bignum(obj_obj2int(x), &(bn->bn));
|
|
mp_expt_d(&bignum_value(bn), obj_obj2int(y), &bignum_value(bn));
|
|
return_closcall1(data, cont, Cyc_bignum_normalize(data, bn));
|
|
}
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
Cyc_expt_double(data, cont, (double)obj_obj2int(x), double_value(y));
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
// Not handled at this time
|
|
}
|
|
}
|
|
if (is_object_type(x) && type_of(x) == double_tag) {
|
|
make_double(d, 0.0);
|
|
if (obj_is_int(y)){
|
|
d.value = (double)obj_obj2int(y);
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
d.value = double_value(y);
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
d.value = mp_get_double(&bignum_value(y));
|
|
}
|
|
d.value = pow(double_value(x), d.value);
|
|
return_closcall1(data, cont, &d);
|
|
}
|
|
if (is_object_type(x) && type_of(x) == bignum_tag) {
|
|
if (obj_is_int(y)){
|
|
if (obj_obj2int(y) < 0) {
|
|
Cyc_expt_double(data, cont, mp_get_double(&bignum_value(x)), (double)obj_obj2int(y));
|
|
} else {
|
|
alloc_bignum(data, bn);
|
|
mp_expt_d(&bignum_value(x), obj_obj2int(y), &bignum_value(bn));
|
|
return_closcall1(data, cont, Cyc_bignum_normalize(data, bn));
|
|
}
|
|
} else if (is_object_type(y) && type_of(y) == double_tag) {
|
|
Cyc_expt_double(data, cont, mp_get_double(&bignum_value(x)), double_value(y));
|
|
//make_double(d, 0.0);
|
|
//d.value = pow(mp_get_double(&bignum_value(x)), double_value(y));
|
|
//return_closcall1(data, cont, &d);
|
|
} else if (is_object_type(y) && type_of(y) == bignum_tag) {
|
|
// Not handled at this time
|
|
}
|
|
}
|
|
// still here, raise an error
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c2, y, NULL);
|
|
make_pair(c1, x, &c2);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
}
|
|
|
|
void Cyc_bignum_remainder(void *data, object cont, object num1, object num2, object rem)
|
|
{
|
|
mp_div(&bignum_value(num1), &bignum_value(num2), NULL, &bignum_value(rem));
|
|
return_closcall1(data, cont, Cyc_bignum_normalize(data, rem));
|
|
}
|
|
|
|
void Cyc_remainder(void *data, object cont, object num1, object num2)
|
|
{
|
|
int i = 0, j = 0;
|
|
object result;
|
|
if (obj_is_int(num1)) {
|
|
if (obj_is_int(num2)){
|
|
i = obj_obj2int(num1);
|
|
j = obj_obj2int(num2);
|
|
}
|
|
else if (is_object_type(num2) && type_of(num2) == bignum_tag){
|
|
alloc_bignum(data, bn);
|
|
Cyc_int2bignum(obj_obj2int(num1), &(bn->bn));
|
|
Cyc_bignum_remainder(data, cont, bn, num2, bn);
|
|
}
|
|
else if (is_object_type(num2) && type_of(num2) == double_tag){
|
|
i = obj_obj2int(num1);
|
|
j = ((double_type *)num2)->value;
|
|
}
|
|
else {
|
|
goto typeerror;
|
|
}
|
|
} else if (is_object_type(num1) && type_of(num1) == bignum_tag) {
|
|
if (obj_is_int(num2)){
|
|
alloc_bignum(data, bn);
|
|
Cyc_int2bignum(obj_obj2int(num2), &(bn->bn));
|
|
Cyc_bignum_remainder(data, cont, num1, bn, bn);
|
|
}
|
|
else if (is_object_type(num2) && type_of(num2) == bignum_tag){
|
|
alloc_bignum(data, rem);
|
|
Cyc_bignum_remainder(data, cont, num1, num2, rem);
|
|
}
|
|
else if (is_object_type(num2) && type_of(num2) == double_tag){
|
|
j = ((double_type *)num2)->value;
|
|
alloc_bignum(data, bn);
|
|
Cyc_int2bignum(obj_obj2int(j), &(bn->bn));
|
|
Cyc_bignum_remainder(data, cont, num1, bn, bn);
|
|
}
|
|
else {
|
|
goto typeerror;
|
|
}
|
|
} else if (is_object_type(num1) && type_of(num1) == double_tag){
|
|
if (obj_is_int(num2)){
|
|
i = ((double_type *)num1)->value;
|
|
j = obj_obj2int(num2);
|
|
}
|
|
else if (is_object_type(num2) && type_of(num2) == bignum_tag){
|
|
i = ((double_type *)num1)->value;
|
|
alloc_bignum(data, bn);
|
|
Cyc_int2bignum(obj_obj2int(i), &(bn->bn));
|
|
Cyc_bignum_remainder(data, cont, bn, num2, bn);
|
|
}
|
|
else if (is_object_type(num2) && type_of(num2) == double_tag){
|
|
i = ((double_type *)num1)->value;
|
|
j = ((double_type *)num2)->value;
|
|
}
|
|
else {
|
|
goto typeerror;
|
|
}
|
|
} else {
|
|
goto typeerror;
|
|
}
|
|
if (j == 0) { Cyc_rt_raise_msg(data, "Divide by zero"); }
|
|
result = obj_int2obj(i % j);
|
|
return_closcall1(data, cont, result);
|
|
typeerror:
|
|
{
|
|
make_string(s, "Bad argument type");
|
|
make_pair(c2, num2, NULL);
|
|
make_pair(c1, num1, &c2);
|
|
make_pair(c0, &s, &c1);
|
|
Cyc_rt_raise(data, &c0);
|
|
}
|
|
}
|
|
|
|
/* I/O functions */
|
|
|
|
port_type Cyc_stdout()
|
|
{
|
|
make_port(_stdout, stdout, 0);
|
|
return _stdout;
|
|
}
|
|
|
|
port_type Cyc_stdin()
|
|
{
|
|
make_input_port(p, stdin, 1);
|
|
return p;
|
|
}
|
|
|
|
port_type Cyc_stderr()
|
|
{
|
|
make_port(p, stderr, 0);
|
|
return p;
|
|
}
|
|
|
|
port_type _Cyc_io_open_input_file(void *data, object str, const char *mode)
|
|
{
|
|
const char *fname;
|
|
Cyc_check_str(data, str);
|
|
fname = ((string_type *) str)->str;
|
|
make_input_port(p, NULL, CYC_IO_BUF_LEN);
|
|
p.fp = fopen(fname, mode);
|
|
if (p.fp == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to open file", str);
|
|
}
|
|
return p;
|
|
}
|
|
|
|
port_type _Cyc_io_open_output_file(void *data, object str, const char *mode)
|
|
{
|
|
const char *fname;
|
|
Cyc_check_str(data, str);
|
|
fname = ((string_type *) str)->str;
|
|
make_port(p, NULL, 0);
|
|
p.fp = fopen(fname, mode);
|
|
if (p.fp == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to open file", str);
|
|
}
|
|
return p;
|
|
}
|
|
|
|
port_type Cyc_io_open_input_file(void *data, object str)
|
|
{
|
|
return _Cyc_io_open_input_file(data, str, "r");
|
|
}
|
|
|
|
port_type Cyc_io_open_output_file(void *data, object str)
|
|
{
|
|
return _Cyc_io_open_output_file(data, str, "w");
|
|
}
|
|
|
|
port_type Cyc_io_open_binary_input_file(void *data, object str)
|
|
{
|
|
return _Cyc_io_open_input_file(data, str, "rb");
|
|
}
|
|
|
|
port_type Cyc_io_open_binary_output_file(void *data, object str)
|
|
{
|
|
return _Cyc_io_open_output_file(data, str, "wb");
|
|
}
|
|
|
|
object Cyc_io_close_input_port(void *data, object port)
|
|
{
|
|
return Cyc_io_close_port(data, port);
|
|
}
|
|
|
|
object Cyc_io_close_output_port(void *data, object port)
|
|
{
|
|
return Cyc_io_close_port(data, port);
|
|
}
|
|
|
|
object Cyc_io_close_port(void *data, object port)
|
|
{
|
|
Cyc_check_port(data, port);
|
|
{
|
|
FILE *stream = ((port_type *) port)->fp;
|
|
if (stream)
|
|
fclose(stream);
|
|
((port_type *) port)->fp = NULL;
|
|
|
|
if (((port_type *)port)->mem_buf != NULL){
|
|
free( ((port_type *)port)->mem_buf );
|
|
((port_type *)port)->mem_buf = NULL;
|
|
((port_type *)port)->mem_buf_len = 0;
|
|
}
|
|
if (((port_type *)port)->str_bv_in_mem_buf != NULL){
|
|
free( ((port_type *)port)->str_bv_in_mem_buf );
|
|
((port_type *)port)->str_bv_in_mem_buf = NULL;
|
|
((port_type *)port)->str_bv_in_mem_buf_len = 0;
|
|
}
|
|
if (((port_type *)port)->tok_buf != NULL){
|
|
free( ((port_type *)port)->tok_buf );
|
|
((port_type *)port)->tok_buf = NULL;
|
|
((port_type *)port)->tok_buf_len = 0;
|
|
}
|
|
}
|
|
return port;
|
|
}
|
|
|
|
object Cyc_io_flush_output_port(void *data, object port)
|
|
{
|
|
Cyc_check_port(data, port);
|
|
{
|
|
FILE *stream = ((port_type *) port)->fp;
|
|
if (stream) {
|
|
//int rv =
|
|
fflush(stream);
|
|
// TODO: handle error if non-zero value returned
|
|
}
|
|
}
|
|
return port;
|
|
}
|
|
|
|
object Cyc_io_delete_file(void *data, object filename)
|
|
{
|
|
const char *fname;
|
|
Cyc_check_str(data, filename);
|
|
fname = ((string_type *) filename)->str;
|
|
if (remove(fname) == 0)
|
|
return boolean_t; // Success
|
|
return boolean_f;
|
|
}
|
|
|
|
object Cyc_io_file_exists(void *data, object filename)
|
|
{
|
|
const char *fname;
|
|
Cyc_check_str(data, filename);
|
|
fname = ((string_type *) filename)->str;
|
|
FILE *file;
|
|
// Possibly overkill, but portable
|
|
if ((file = fopen(fname, "r"))) {
|
|
fclose(file);
|
|
return boolean_t;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
// Functions internal to the runtime that use malloc
|
|
list malloc_make_pair(object a, object d)
|
|
{
|
|
pair_type *c = malloc(sizeof(pair_type));
|
|
c->hdr.mark = gc_color_red;
|
|
c->hdr.grayed = 0;
|
|
c->hdr.immutable = 0;
|
|
c->tag = pair_tag;
|
|
c->pair_car = a;
|
|
c->pair_cdr = d;
|
|
return c;
|
|
}
|
|
|
|
cvar_type *mcvar(object * var)
|
|
{
|
|
cvar_type *c = malloc(sizeof(cvar_type));
|
|
c->hdr.mark = gc_color_red;
|
|
c->hdr.grayed = 0;
|
|
c->hdr.immutable = 0;
|
|
c->tag = cvar_tag;
|
|
c->pvar = var;
|
|
return c;
|
|
}
|
|
|
|
void _Cyc_91global_91vars(void *data, object cont, object args)
|
|
{
|
|
return_closcall1(data, cont, Cyc_global_variables);
|
|
}
|
|
|
|
void _car(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "car", 1, args);
|
|
{
|
|
object var = car(args);
|
|
Cyc_check_pair(data, var);
|
|
return_closcall1(data, cont, car(var));
|
|
}}
|
|
|
|
void _cdr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, cdr(car(args)));
|
|
}
|
|
|
|
void _caar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caar(data, car(args)));
|
|
}
|
|
|
|
void _cadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cadr(data, car(args)));
|
|
}
|
|
|
|
void _cdar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdar(data, car(args)));
|
|
}
|
|
|
|
void _cddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cddr(data, car(args)));
|
|
}
|
|
|
|
void _caaar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caaar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caaar(data, car(args)));
|
|
}
|
|
|
|
void _caadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caadr(data, car(args)));
|
|
}
|
|
|
|
void _cadar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cadar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cadar(data, car(args)));
|
|
}
|
|
|
|
void _caddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caddr(data, car(args)));
|
|
}
|
|
|
|
void _cdaar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdaar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdaar(data, car(args)));
|
|
}
|
|
|
|
void _cdadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdadr(data, car(args)));
|
|
}
|
|
|
|
void _cddar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cddar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cddar(data, car(args)));
|
|
}
|
|
|
|
void _cdddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdddr(data, car(args)));
|
|
}
|
|
|
|
void _caaaar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caaaar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caaaar(data, car(args)));
|
|
}
|
|
|
|
void _caaadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caaadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caaadr(data, car(args)));
|
|
}
|
|
|
|
void _caadar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caadar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caadar(data, car(args)));
|
|
}
|
|
|
|
void _caaddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caaddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caaddr(data, car(args)));
|
|
}
|
|
|
|
void _cadaar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cadaar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cadaar(data, car(args)));
|
|
}
|
|
|
|
void _cadadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cadadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cadadr(data, car(args)));
|
|
}
|
|
|
|
void _caddar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "caddar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_caddar(data, car(args)));
|
|
}
|
|
|
|
void _cadddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cadddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cadddr(data, car(args)));
|
|
}
|
|
|
|
void _cdaaar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdaaar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdaaar(data, car(args)));
|
|
}
|
|
|
|
void _cdaadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdaadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdaadr(data, car(args)));
|
|
}
|
|
|
|
void _cdadar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdadar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdadar(data, car(args)));
|
|
}
|
|
|
|
void _cdaddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdaddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdaddr(data, car(args)));
|
|
}
|
|
|
|
void _cddaar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cddaar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cddaar(data, car(args)));
|
|
}
|
|
|
|
void _cddadr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cddadr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cddadr(data, car(args)));
|
|
}
|
|
|
|
void _cdddar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cdddar", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cdddar(data, car(args)));
|
|
}
|
|
|
|
void _cddddr(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cddddr", 1, args);
|
|
Cyc_check_pair(data, car(args));
|
|
return_closcall1(data, cont, Cyc_cddddr(data, car(args)));
|
|
}
|
|
|
|
void _cons(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "cons", 2, args);
|
|
{
|
|
make_pair(c, car(args), cadr(args));
|
|
return_closcall1(data, cont, &c);
|
|
}}
|
|
|
|
void _eq_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "eq?", 2, args);
|
|
return_closcall1(data, cont, Cyc_eq(car(args), cadr(args)));
|
|
}
|
|
|
|
void _eqv_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "eqv?", 2, args);
|
|
_eq_127(data, cont, args);
|
|
}
|
|
|
|
void _equal_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "equal?", 2, args);
|
|
return_closcall1(data, cont, equalp(car(args), cadr(args)));
|
|
}
|
|
|
|
void _length(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "length", 1, args);
|
|
{
|
|
object obj = Cyc_length(data, car(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _bytevector_91length(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "bytevector-length", 1, args);
|
|
{
|
|
object obj = Cyc_bytevector_length(data, car(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _bytevector_91u8_91ref(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "bytevector-u8-ref", 2, args);
|
|
{
|
|
object c = Cyc_bytevector_u8_ref(data, car(args), cadr(args));
|
|
return_closcall1(data, cont, c);
|
|
}}
|
|
|
|
void _bytevector_91u8_91set_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "bytevector-u8-set!", 3, args);
|
|
{
|
|
object bv = Cyc_bytevector_u8_set(data, car(args), cadr(args), caddr(args));
|
|
return_closcall1(data, cont, bv);
|
|
}}
|
|
|
|
void _bytevector(void *data, object cont, object args)
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
dispatch(data, obj_obj2int(argc), (function_type) dispatch_bytevector, cont,
|
|
cont, args);
|
|
}
|
|
|
|
void _bytevector_91append(void *data, object cont, object args)
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
dispatch(data, obj_obj2int(argc),
|
|
(function_type) dispatch_bytevector_91append, cont, cont, args);
|
|
}
|
|
|
|
void _Cyc_91bytevector_91copy(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-bytevector-copy", 3, args);
|
|
Cyc_bytevector_copy(data, cont, car(args), cadr(args), caddr(args));
|
|
}
|
|
|
|
void _Cyc_91string_91_125utf8(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-string->utf8", 3, args);
|
|
Cyc_string2utf8(data, cont, car(args), cadr(args), caddr(args));
|
|
}
|
|
|
|
void _Cyc_91utf8_91_125string(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-utf8->string", 3, args);
|
|
Cyc_utf82string(data, cont, car(args), cadr(args), caddr(args));
|
|
}
|
|
|
|
void _vector_91length(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "vector-length", 1, args);
|
|
{
|
|
object obj = Cyc_vector_length(data, car(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _null_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "null?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_null(car(args)));
|
|
}
|
|
|
|
void _set_91car_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "set-car!", 2, args);
|
|
return_closcall1(data, cont, Cyc_set_car(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _set_91cdr_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "set-cdr!", 2, args);
|
|
return_closcall1(data, cont, Cyc_set_cdr(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _Cyc_91has_91cycle_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-has-cycle?", 1, args);
|
|
return_closcall1(data, cont, Cyc_has_cycle(car(args)));
|
|
}
|
|
|
|
void _Cyc_91spawn_91thread_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-spawn-thread!", 1, args);
|
|
// TODO: validate argument type?
|
|
return_closcall1(data, cont, Cyc_spawn_thread(car(args)));
|
|
}
|
|
|
|
void _Cyc_91end_91thread_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_end_thread((gc_thread_data *) data);
|
|
return_closcall1(data, cont, boolean_f);
|
|
}
|
|
|
|
void __87(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_sum, cont, cont, args);
|
|
}
|
|
|
|
void __91(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "-", 1, args);
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_sub, cont, cont, args);
|
|
}}
|
|
|
|
void __85(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_mul, cont, cont, args);
|
|
}
|
|
|
|
void __95(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "/", 1, args);
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_div, cont, cont, args);
|
|
}}
|
|
|
|
void _Cyc_91cvar_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-cvar?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_cvar(car(args)));
|
|
}
|
|
|
|
void _Cyc_91opaque_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-opaque?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_opaque(car(args)));
|
|
}
|
|
|
|
void _boolean_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "boolean?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_boolean(car(args)));
|
|
}
|
|
|
|
void _char_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "char?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_char(car(args)));
|
|
}
|
|
|
|
void _eof_91object_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "eof_91object?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_eof_object(car(args)));
|
|
}
|
|
|
|
void _number_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "number?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_number(car(args)));
|
|
}
|
|
|
|
void _real_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "real?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_real(car(args)));
|
|
}
|
|
|
|
void _integer_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "integer?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_integer(car(args)));
|
|
}
|
|
|
|
void _pair_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "pair?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_pair(car(args)));
|
|
}
|
|
|
|
void _procedure_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "procedure?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_procedure(data, car(args)));
|
|
}
|
|
|
|
void _macro_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "macro?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_macro(car(args)));
|
|
}
|
|
|
|
void _Cyc_91macro_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-macro?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_macro(car(args)));
|
|
}
|
|
|
|
void _port_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "port?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_port(car(args)));
|
|
}
|
|
|
|
void _bytevector_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "bytevector?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_bytevector(car(args)));
|
|
}
|
|
|
|
void _vector_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "vector?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_vector(car(args)));
|
|
}
|
|
|
|
void _string_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_string(car(args)));
|
|
}
|
|
|
|
void _symbol_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "symbol?", 1, args);
|
|
return_closcall1(data, cont, Cyc_is_symbol(car(args)));
|
|
}
|
|
|
|
void _Cyc_91get_91cvar(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-get-cvar", 1, args);
|
|
return_closcall1(data, cont, Cyc_get_cvar((car(args))));
|
|
}
|
|
|
|
void _Cyc_91set_91cvar_67(void *data, object cont, object args)
|
|
{
|
|
printf("not implemented\n");
|
|
exit(1);
|
|
}
|
|
|
|
/* Note we cannot use _exit (per convention) because it is reserved by C */
|
|
void _cyc_exit(void *data, object cont, object args)
|
|
{
|
|
if (args == NULL)
|
|
__halt(NULL);
|
|
__halt(car(args));
|
|
}
|
|
|
|
void __75halt(void *data, object cont, object args)
|
|
{
|
|
#if DEBUG_SHOW_DIAG
|
|
gc_print_stats(Cyc_heap);
|
|
#endif
|
|
exit(0);
|
|
}
|
|
|
|
void _cell_91get(void *data, object cont, object args)
|
|
{
|
|
printf("not implemented\n");
|
|
exit(1);
|
|
}
|
|
|
|
void _set_91global_67(void *data, object cont, object args)
|
|
{
|
|
printf("not implemented\n");
|
|
exit(1);
|
|
}
|
|
|
|
void _set_91cell_67(void *data, object cont, object args)
|
|
{
|
|
printf("not implemented\n");
|
|
exit(1);
|
|
}
|
|
|
|
void _cell(void *data, object cont, object args)
|
|
{
|
|
printf("not implemented\n");
|
|
exit(1);
|
|
}
|
|
|
|
void __123(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_num_eq, cont, cont, args);
|
|
}
|
|
|
|
void __125(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_num_gt, cont, cont, args);
|
|
}
|
|
|
|
void __121(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_num_lt, cont, cont, args);
|
|
}
|
|
|
|
void __125_123(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_num_gte, cont, cont,
|
|
args);
|
|
}
|
|
|
|
void __121_123(void *data, object cont, object args)
|
|
{
|
|
int argc = obj_obj2int(Cyc_length(data, args));
|
|
dispatch(data, argc, (function_type) dispatch_num_lte, cont, cont,
|
|
args);
|
|
}
|
|
|
|
void _apply(void *data, object cont, object args)
|
|
{
|
|
// Cyc_check_num_args(data, "apply", 2, args);
|
|
// apply(data, cont, car(args), cadr(args));
|
|
object argc = Cyc_length(data, args);
|
|
|
|
//fprintf(stdout, "_apply received args: ");
|
|
//Cyc_display(data, args, stdout);
|
|
//fprintf(stdout, "\n");
|
|
dispatch(data, obj_obj2int(argc), (function_type)dispatch_apply_va, cont, cont, args);
|
|
}
|
|
|
|
void _assq(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "assq ", 2, args);
|
|
return_closcall1(data, cont, assq(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _assv(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "assv ", 2, args);
|
|
return_closcall1(data, cont, assq(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _memq(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "memq", 2, args);
|
|
return_closcall1(data, cont, memqp(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _memv(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "memv", 2, args);
|
|
return_closcall1(data, cont, memqp(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _char_91_125integer(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "char->integer", 1, args);
|
|
{
|
|
object obj = Cyc_char2integer(car(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _integer_91_125char(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "integer->char", 1, args);
|
|
return_closcall1(data, cont, Cyc_integer2char(data, car(args)));
|
|
}
|
|
|
|
void _string_91_125number(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string->number", 1, args);
|
|
{
|
|
object tail = cdr(args);
|
|
if (tail) {
|
|
Cyc_string2number2_(data, cont, 2, car(args), cadr(args));
|
|
} else {
|
|
Cyc_string2number_(data, cont, car(args));
|
|
}
|
|
}
|
|
}
|
|
|
|
void _string_91length(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string-length", 1, args);
|
|
{
|
|
object obj = Cyc_string_length(data, car(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _cyc_substring(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "substring", 3, args);
|
|
Cyc_substring(data, cont, car(args), cadr(args), caddr(args));
|
|
}
|
|
|
|
void _cyc_string_91set_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string-set!", 3, args);
|
|
{
|
|
object s = Cyc_string_set(data, car(args), cadr(args), caddr(args));
|
|
return_closcall1(data, cont, s);
|
|
}}
|
|
|
|
void _cyc_string_91ref(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string-ref", 2, args);
|
|
{
|
|
object c = Cyc_string_ref(data, car(args), cadr(args));
|
|
return_closcall1(data, cont, c);
|
|
}}
|
|
|
|
void _Cyc_91installation_91dir(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-installation-dir", 1, args);
|
|
Cyc_installation_dir(data, cont, car(args));
|
|
}
|
|
|
|
void _Cyc_91compilation_91environment(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-compilation-environment", 1, args);
|
|
Cyc_compilation_environment(data, cont, car(args));
|
|
}
|
|
|
|
void _command_91line_91arguments(void *data, object cont, object args)
|
|
{
|
|
object cmdline = Cyc_command_line_arguments(data, cont);
|
|
return_closcall1(data, cont, cmdline);
|
|
}
|
|
|
|
void _cyc_system(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "system", 1, args);
|
|
{
|
|
object obj = Cyc_system(car(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _Cyc_91current_91exception_91handler(void *data, object cont, object args)
|
|
{
|
|
object handler = Cyc_current_exception_handler(data);
|
|
return_closcall1(data, cont, handler);
|
|
}
|
|
|
|
void _Cyc_91default_91exception_91handler(void *data, object cont, object args)
|
|
{
|
|
// TODO: this is a quick-and-dirty implementation, may be a better way to write this
|
|
Cyc_default_exception_handler(data, 1, args, car(args));
|
|
}
|
|
|
|
void _string_91cmp(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string-cmp", 2, args);
|
|
{
|
|
object obj = Cyc_string_cmp(data, car(args), cadr(args));
|
|
return_closcall1(data, cont, obj);
|
|
}}
|
|
|
|
void _string_91append(void *data, object cont, object args)
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
dispatch(data, obj_obj2int(argc), (function_type) dispatch_string_91append,
|
|
cont, cont, args);
|
|
}
|
|
|
|
void _make_91vector(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "make-vector", 1, args);
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
if (obj_obj2int(argc) >= 2) {
|
|
Cyc_make_vector(data, cont, 2, car(args), cadr(args));
|
|
} else {
|
|
Cyc_make_vector(data, cont, 2, car(args), boolean_f);
|
|
}
|
|
}
|
|
}
|
|
|
|
void _make_91bytevector(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "make-bytevector", 1, args);
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
if (obj_obj2int(argc) >= 2) {
|
|
Cyc_make_bytevector(data, cont, 2, car(args), cadr(args));
|
|
} else {
|
|
Cyc_make_bytevector(data, cont, 1, car(args));
|
|
}
|
|
}
|
|
}
|
|
|
|
void _vector_91ref(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "vector-ref", 2, args);
|
|
{
|
|
object ref = Cyc_vector_ref(data, car(args), cadr(args));
|
|
return_closcall1(data, cont, ref);
|
|
}}
|
|
|
|
void _vector_91set_67(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "vector-set!", 3, args);
|
|
{
|
|
object ref = Cyc_vector_set(data, car(args), cadr(args), caddr(args));
|
|
return_closcall1(data, cont, ref);
|
|
}}
|
|
|
|
void _list_91_125vector(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "list->vector", 1, args);
|
|
Cyc_list2vector(data, cont, car(args));
|
|
}
|
|
|
|
void _list_91_125string(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "list->string", 1, args);
|
|
Cyc_list2string(data, cont, car(args));
|
|
}
|
|
|
|
void _string_91_125symbol(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "string->symbol", 1, args);
|
|
return_closcall1(data, cont, Cyc_string2symbol(data, car(args)));
|
|
}
|
|
|
|
void _symbol_91_125string(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "symbol->string", 1, args);
|
|
Cyc_symbol2string(data, cont, car(args));
|
|
}
|
|
|
|
void _number_91_125string(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "number->string", 1, args);
|
|
{
|
|
object tail = cdr(args);
|
|
if (tail) {
|
|
Cyc_number2string2(data, cont, 2, car(args), cadr(args));
|
|
} else {
|
|
Cyc_number2string2(data, cont, 1, car(args));
|
|
}
|
|
}
|
|
}
|
|
|
|
void _open_91input_91file(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "open-input-file", 1, args);
|
|
{
|
|
port_type p = Cyc_io_open_input_file(data, car(args));
|
|
return_closcall1(data, cont, &p);
|
|
}}
|
|
|
|
void _open_91output_91file(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "open-output-file", 1, args);
|
|
{
|
|
port_type p = Cyc_io_open_output_file(data, car(args));
|
|
return_closcall1(data, cont, &p);
|
|
}}
|
|
|
|
void _close_91port(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "close-port", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_close_port(data, car(args)));
|
|
}
|
|
|
|
void _close_91input_91port(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "close-input-port", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_close_input_port(data, car(args)));
|
|
}
|
|
|
|
void _close_91output_91port(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "close-output-port", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_close_output_port(data, car(args)));
|
|
}
|
|
|
|
void _Cyc_91flush_91output_91port(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-flush-output-port", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_flush_output_port(data, car(args)));
|
|
}
|
|
|
|
void _file_91exists_127(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "file-exists?", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_file_exists(data, car(args)));
|
|
}
|
|
|
|
void _delete_91file(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "delete-file", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_delete_file(data, car(args)));
|
|
}
|
|
|
|
void _read_91char(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "read-char", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_read_char(data, cont, car(args)));
|
|
}
|
|
|
|
void _peek_91char(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "peek-char", 1, args);
|
|
return_closcall1(data, cont, Cyc_io_peek_char(data, cont, car(args)));
|
|
}
|
|
|
|
void _Cyc_91read_91line(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "Cyc-read-line", 1, args);
|
|
Cyc_io_read_line(data, cont, car(args));
|
|
}
|
|
|
|
void _Cyc_91write_91char(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "write-char", 2, args);
|
|
return_closcall1(data, cont, Cyc_write_char(data, car(args), cadr(args)));
|
|
}
|
|
|
|
void _Cyc_91write(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "write", 1, args);
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
dispatch(data, obj_obj2int(argc), (function_type) dispatch_write_va, cont,
|
|
cont, args);
|
|
}}
|
|
|
|
void _display(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "display", 1, args);
|
|
{
|
|
object argc = Cyc_length(data, args);
|
|
dispatch(data, obj_obj2int(argc), (function_type) dispatch_display_va, cont,
|
|
cont, args);
|
|
}}
|
|
|
|
void _call_95cc(void *data, object cont, object args)
|
|
{
|
|
Cyc_check_num_args(data, "call/cc", 1, args);
|
|
if ((boolean_f == Cyc_is_procedure(data, car(args)))) {
|
|
Cyc_invalid_type_error(data, closure1_tag, car(args));
|
|
}
|
|
return_closcall2(data, __glo_call_95cc_scheme_base, cont, car(args));
|
|
}
|
|
|
|
// Front-end to apply
|
|
//
|
|
// Core of va processing is done here, because we need different
|
|
// functions for apply_va and dispatch_apply_va, and those functions
|
|
// need to start and end va. BUT, we need to allocate new objects
|
|
// so this stuff can't be returned, so a workaround is to put it in
|
|
// this macro.
|
|
//
|
|
// Fast path is just to take list, if we only have func and 1 arg.
|
|
// Otherwise append all args together into a single list, per r7rs.
|
|
#define do_apply_va \
|
|
va_start(ap, func); \
|
|
if (argc == 2) { \
|
|
lis = va_arg(ap, object); \
|
|
Cyc_check_pair_or_null(data, lis); \
|
|
} else { \
|
|
lis = alloca(sizeof(pair_type)); \
|
|
tmp = va_arg(ap, object); \
|
|
set_pair(lis, tmp, NULL); \
|
|
prev = lis; \
|
|
for (i = 2; i < argc - 1; i++) { \
|
|
pair_type *next = alloca(sizeof(pair_type)); \
|
|
tmp = va_arg(ap, object); \
|
|
set_pair(next, tmp, NULL); \
|
|
cdr(prev) = next; \
|
|
prev = next; \
|
|
} \
|
|
tmp = va_arg(ap, object); \
|
|
cdr(prev) = tmp; \
|
|
} \
|
|
va_end(ap);
|
|
|
|
void dispatch_apply_va(void *data, int argc, object clo, object cont, object func, ...)
|
|
{
|
|
list lis = NULL, prev = NULL;
|
|
object tmp;
|
|
int i;
|
|
va_list ap;
|
|
argc = argc - 1; // Required for "dispatch" function
|
|
do_apply_va
|
|
apply(data, cont, func, lis);
|
|
}
|
|
|
|
object apply_va(void *data, object cont, int argc, object func, ...)
|
|
{
|
|
list lis = NULL, prev = NULL;
|
|
object tmp;
|
|
int i;
|
|
va_list ap;
|
|
do_apply_va
|
|
return apply(data, cont, func, lis); // Never actually returns
|
|
}
|
|
|
|
/*
|
|
* @param cont - Continuation for the function to call into
|
|
* @param func - Function to execute
|
|
* @param args - A list of arguments to the function
|
|
*/
|
|
object apply(void *data, object cont, object func, object args)
|
|
{
|
|
object count;
|
|
|
|
//printf("DEBUG apply: ");
|
|
//Cyc_display(data, args);
|
|
//printf("\n");
|
|
if (!is_object_type(func)) {
|
|
Cyc_rt_raise2(data, "Call of non-procedure: ", func);
|
|
}
|
|
// Causes problems...
|
|
//Cyc_check_pair_or_null(args);
|
|
|
|
switch (type_of(func)) {
|
|
case primitive_tag:
|
|
// TODO: should probably check arg counts and error out if needed
|
|
((primitive_type *) func)->fn(data, cont, args);
|
|
break;
|
|
case macro_tag:
|
|
case closure0_tag:
|
|
case closure1_tag:
|
|
case closureN_tag:
|
|
if (func == Cyc_glo_call_cc) {
|
|
// make_pair(c, cont, args);
|
|
//Cyc_display(data, args, stderr);
|
|
// args = &c;
|
|
//Cyc_display(data, &c, stderr);
|
|
count = Cyc_length(data, args);
|
|
Cyc_check_num_args(data, "<procedure>", 1, args);
|
|
dispatch(data, obj_obj2int(count), ((closure) func)->fn, func, cont,
|
|
args);
|
|
}
|
|
count = Cyc_length(data, args);
|
|
// TODO: validate number of args provided:
|
|
Cyc_check_num_args(data, "<procedure>", ((closure) func)->num_args, args); // TODO: could be more efficient, eg: cyc_length(args) is called twice.
|
|
dispatch(data, obj_obj2int(count), ((closure) func)->fn, func, cont, args);
|
|
break;
|
|
|
|
case pair_tag:
|
|
{
|
|
// TODO: should add more error checking here, make sure car(func) is a symbol
|
|
object fobj = car(func);
|
|
|
|
if (!is_object_type(fobj) || type_of(fobj) != symbol_tag) {
|
|
Cyc_rt_raise2(data, "Call of non-procedure: ", func);
|
|
} else if (strncmp(((symbol) fobj)->desc, "lambda", 7) == 0) {
|
|
make_pair(c, func, args);
|
|
//printf("JAE DEBUG, sending to eval: ");
|
|
//Cyc_display(data, &c, stderr);
|
|
((closure) Cyc_glo_eval_from_c)->fn(data, 2, Cyc_glo_eval_from_c, cont,
|
|
&c, NULL);
|
|
|
|
// TODO: would be better to compare directly against symbols here,
|
|
// but need a way of looking them up ahead of time.
|
|
// maybe a libinit() or such is required.
|
|
} else if (strncmp(((symbol) fobj)->desc, "primitive", 10) == 0) {
|
|
make_pair(c, cadr(func), args);
|
|
((closure) Cyc_glo_eval_from_c)->fn(data, 3, Cyc_glo_eval_from_c, cont,
|
|
&c, NULL);
|
|
} else if (strncmp(((symbol) fobj)->desc, "procedure", 10) == 0) {
|
|
make_pair(c, func, args);
|
|
((closure) Cyc_glo_eval_from_c)->fn(data, 3, Cyc_glo_eval_from_c, cont,
|
|
&c, NULL);
|
|
} else {
|
|
make_pair(c, func, args);
|
|
Cyc_rt_raise2(data, "Unable to evaluate: ", &c);
|
|
}
|
|
}
|
|
|
|
default: {
|
|
Cyc_rt_raise2(data, "Call of non-procedure: ", func);
|
|
}
|
|
}
|
|
return NULL; // Never reached
|
|
}
|
|
|
|
// Version of apply meant to be called from within compiled code
|
|
void Cyc_apply(void *data, int argc, closure cont, object prim, ...)
|
|
{
|
|
va_list ap;
|
|
object tmp;
|
|
int i;
|
|
list args = alloca(sizeof(pair_type) * argc);
|
|
|
|
va_start(ap, prim);
|
|
|
|
for (i = 0; i < argc; i++) {
|
|
tmp = va_arg(ap, object);
|
|
args[i].hdr.mark = gc_color_red;
|
|
args[i].hdr.grayed = 0;
|
|
args[i].hdr.immutable = 0;
|
|
args[i].tag = pair_tag;
|
|
args[i].pair_car = tmp;
|
|
args[i].pair_cdr = (i == (argc - 1)) ? NULL : &args[i + 1];
|
|
}
|
|
//printf("DEBUG applying primitive to ");
|
|
//Cyc_display(data, (object)&args[0]);
|
|
//printf("\n");
|
|
|
|
va_end(ap);
|
|
apply(data, cont, prim, (argc > 0)
|
|
? (object) & args[0]
|
|
: NULL);
|
|
}
|
|
|
|
// END apply
|
|
|
|
/* Extract args from given array, assuming cont is the first arg in buf */
|
|
void Cyc_apply_from_buf(void *data, int argc, object prim, object * buf)
|
|
{
|
|
list args;
|
|
object cont;
|
|
int i;
|
|
|
|
if (argc == 0) {
|
|
printf("Internal error in Cyc_apply_from_buf, argc is 0\n");
|
|
exit(1);
|
|
}
|
|
|
|
args = alloca(sizeof(pair_type) * (argc - 1));
|
|
cont = buf[0];
|
|
|
|
for (i = 1; i < argc; i++) {
|
|
args[i - 1].hdr.mark = gc_color_red;
|
|
args[i - 1].hdr.grayed = 0;
|
|
args[i - 1].hdr.immutable = 0;
|
|
args[i - 1].tag = pair_tag;
|
|
args[i - 1].pair_car = buf[i];
|
|
args[i - 1].pair_cdr = (i == (argc - 1)) ? NULL : &args[i];
|
|
}
|
|
|
|
apply(data, cont, prim, (object) & args[0]);
|
|
}
|
|
|
|
/**
|
|
* Start a thread's trampoline
|
|
*/
|
|
void Cyc_start_trampoline(gc_thread_data * thd)
|
|
{
|
|
// Tank, load the jump program
|
|
setjmp(*(thd->jmp_start));
|
|
|
|
#if DEBUG_GC
|
|
printf("Done with GC\n");
|
|
#endif
|
|
|
|
if (obj_is_not_closure(thd->gc_cont)) {
|
|
Cyc_apply_from_buf(thd, thd->gc_num_args, thd->gc_cont, thd->gc_args);
|
|
} else {
|
|
do_dispatch(thd, thd->gc_num_args, ((closure) (thd->gc_cont))->fn,
|
|
thd->gc_cont, thd->gc_args);
|
|
}
|
|
|
|
fprintf(stderr, "Internal error: should never have reached this line\n");
|
|
exit(1);
|
|
}
|
|
|
|
/**
|
|
* @brief A helper function for calling `gc_mark_globals`.
|
|
*/
|
|
void gc_request_mark_globals(void)
|
|
{
|
|
gc_mark_globals(Cyc_global_variables, global_table);
|
|
}
|
|
|
|
/**
|
|
* @brief Add an object to the move buffer
|
|
* @param d Mutator data object containing the buffer
|
|
* @param alloci Pointer to the next open slot in the buffer
|
|
* @param obj Object to add
|
|
*/
|
|
static void gc_thr_add_to_move_buffer(gc_thread_data * d, int *alloci, object obj)
|
|
{
|
|
if (*alloci == d->moveBufLen) {
|
|
gc_thr_grow_move_buffer(d);
|
|
}
|
|
|
|
d->moveBuf[*alloci] = obj;
|
|
(*alloci)++;
|
|
}
|
|
|
|
static char *gc_fixup_moved_obj(gc_thread_data * thd, int *alloci, char *obj,
|
|
object hp)
|
|
{
|
|
int acquired_lock = 0;
|
|
if (grayed(obj)) {
|
|
// Try to acquire the lock, because we are already locked if
|
|
// the collector is cooperating on behalf of the mutator
|
|
if (pthread_mutex_trylock(&(thd->lock)) == 0) {
|
|
acquired_lock = 1;
|
|
}
|
|
gc_mark_gray2(thd, hp);
|
|
if (acquired_lock) {
|
|
pthread_mutex_unlock(&(thd->lock));
|
|
}
|
|
}
|
|
// hp ==> new heap object, point to it from old stack object
|
|
forward(obj) = hp;
|
|
type_of(obj) = forward_tag;
|
|
// keep track of each allocation so we can scan/move
|
|
// the whole live object 'tree'
|
|
gc_thr_add_to_move_buffer(thd, alloci, hp);
|
|
return (char *)hp;
|
|
}
|
|
|
|
static char *gc_move(char *obj, gc_thread_data * thd, int *alloci, int *heap_grown)
|
|
{
|
|
gc_heap_root *heap = thd->heap;
|
|
if (!is_object_type(obj))
|
|
return obj;
|
|
switch (type_of(obj)) {
|
|
case closureN_tag:{
|
|
closureN_type *hp = gc_alloc(heap,
|
|
sizeof(closureN_type) +
|
|
sizeof(object) *
|
|
(((closureN) obj)->num_elements),
|
|
obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case pair_tag:{
|
|
list hp = gc_alloc(heap, sizeof(pair_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case string_tag:{
|
|
string_type *hp = gc_alloc(heap,
|
|
sizeof(string_type) + ((string_len(obj) + 1)),
|
|
obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case double_tag:{
|
|
double_type *hp =
|
|
gc_alloc(heap, sizeof(double_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case vector_tag:{
|
|
vector_type *hp = gc_alloc(heap,
|
|
sizeof(vector_type) +
|
|
sizeof(object) *
|
|
(((vector) obj)->num_elements),
|
|
obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case bytevector_tag:{
|
|
bytevector_type *hp = gc_alloc(heap,
|
|
sizeof(bytevector_type) +
|
|
sizeof(char) * (((bytevector) obj)->len),
|
|
obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case port_tag:{
|
|
port_type *hp =
|
|
gc_alloc(heap, sizeof(port_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case bignum_tag:{
|
|
bignum_type *hp =
|
|
gc_alloc(heap, sizeof(bignum_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case cvar_tag:{
|
|
cvar_type *hp =
|
|
gc_alloc(heap, sizeof(cvar_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case macro_tag:{
|
|
macro_type *hp =
|
|
gc_alloc(heap, sizeof(macro_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case closure1_tag:{
|
|
closure1_type *hp =
|
|
gc_alloc(heap, sizeof(closure1_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case c_opaque_tag:{
|
|
c_opaque_type *hp =
|
|
gc_alloc(heap, sizeof(c_opaque_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case closure0_tag:
|
|
break;
|
|
case forward_tag:
|
|
return (char *)forward(obj);
|
|
case eof_tag:
|
|
break;
|
|
case primitive_tag:
|
|
break;
|
|
case boolean_tag:
|
|
break;
|
|
case symbol_tag:
|
|
break; // JAE TODO: raise an error here? Should not be possible in real code, though (IE, without GC DEBUG flag)
|
|
case integer_tag:{
|
|
integer_type *hp =
|
|
gc_alloc(heap, sizeof(integer_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
case complex_num_tag:{
|
|
complex_num_type *hp =
|
|
gc_alloc(heap, sizeof(complex_num_type), obj, thd, heap_grown);
|
|
return gc_fixup_moved_obj(thd, alloci, obj, hp);
|
|
}
|
|
default:
|
|
fprintf(stderr, "gc_move: bad tag obj=%p obj.tag=%d\n", (object) obj,
|
|
type_of(obj));
|
|
exit(1);
|
|
}
|
|
return (char *)obj;
|
|
}
|
|
|
|
#define gc_move2heap(obj) { \
|
|
temp = obj; \
|
|
if (stack_overflow(low_limit, temp) && \
|
|
stack_overflow(temp, high_limit)){ \
|
|
(obj) = (object) gc_move(temp, (gc_thread_data *)data, &alloci, &heap_grown); \
|
|
} \
|
|
}
|
|
|
|
/**
|
|
* @brief Trigger a minor GC for the calling thread.
|
|
* @param data Thread data object for the caller.
|
|
* @param cont Continuation to invoke after GC.
|
|
*/
|
|
object Cyc_trigger_minor_gc(void *data, object cont)
|
|
{
|
|
gc_thread_data *thd = (gc_thread_data *) data;
|
|
thd->gc_args[0] = boolean_t;
|
|
GC(data, cont, thd->gc_args, 1);
|
|
return NULL;
|
|
}
|
|
|
|
/**
|
|
* Do a minor GC, tracing all of the live objects from the calling thread's
|
|
* stack and moving them to the heap.
|
|
* \ingroup gc_minor
|
|
*/
|
|
int gc_minor(void *data, object low_limit, object high_limit, closure cont,
|
|
object * args, int num_args)
|
|
{
|
|
object temp;
|
|
int i;
|
|
int scani = 0, alloci = 0;
|
|
int heap_grown = 0;
|
|
|
|
#if GC_DEBUG_VERBOSE
|
|
fprintf(stderr, "started minor GC\n");
|
|
#endif
|
|
|
|
//fprintf(stdout, "DEBUG, started minor GC\n"); // JAE DEBUG
|
|
// Prevent overrunning buffer
|
|
if (num_args > NUM_GC_ARGS) {
|
|
printf("Fatal error - too many arguments (%d) to GC\n", num_args);
|
|
exit(1);
|
|
}
|
|
|
|
gc_move2heap(cont);
|
|
((gc_thread_data *) data)->gc_cont = cont;
|
|
((gc_thread_data *) data)->gc_num_args = num_args;
|
|
|
|
for (i = 0; i < num_args; i++) {
|
|
gc_move2heap(args[i]);
|
|
((gc_thread_data *) data)->gc_args[i] = args[i];
|
|
}
|
|
|
|
// Transport exception stack
|
|
gc_move2heap(((gc_thread_data *) data)->exception_handler_stack);
|
|
gc_move2heap(((gc_thread_data *) data)->param_objs);
|
|
gc_move2heap(((gc_thread_data *) data)->scm_thread_obj);
|
|
|
|
// Transport mutations
|
|
{
|
|
int l = 0;
|
|
while (l < ((gc_thread_data *) data)->mutation_count) {
|
|
object o = ((gc_thread_data *) data)->mutations[l++];
|
|
if (is_value_type(o)) {
|
|
// Can happen if a vector element was already
|
|
// moved and we found an index. Just ignore it
|
|
} else if (type_of(o) == pair_tag) {
|
|
gc_move2heap(car(o));
|
|
gc_move2heap(cdr(o));
|
|
} else if (type_of(o) == vector_tag) {
|
|
int i;
|
|
object idx;
|
|
// For vectors, index is encoded as the next mutation
|
|
idx = ((gc_thread_data *) data)->mutations[l++];
|
|
i = obj_obj2int(idx);
|
|
gc_move2heap(((vector) o)->elements[i]);
|
|
} else if (type_of(o) == forward_tag) {
|
|
// Already transported, skip
|
|
} else if (type_of(o) == c_opaque_tag) {
|
|
// Special case, pull out vector and inspect each element
|
|
vector_type *v = opaque_ptr(o);
|
|
int i;
|
|
for (i = 0; i < ((vector) v)->num_elements; i++) {
|
|
gc_move2heap(((vector) v)->elements[i]);
|
|
}
|
|
} else {
|
|
printf("Unexpected type %d transporting mutation\n", type_of(o));
|
|
exit(1);
|
|
}
|
|
}
|
|
}
|
|
clear_mutations(data); // Reset for next time
|
|
|
|
// Collect globals but only if a change was made. This avoids traversing a
|
|
// long list of objects unless absolutely necessary.
|
|
if (((gc_thread_data *) data)->globals_changed) {
|
|
((gc_thread_data *) data)->globals_changed = 0;
|
|
// Transport globals
|
|
gc_move2heap(Cyc_global_variables); // Internal global used by the runtime
|
|
{
|
|
list l = global_table;
|
|
for (; l != NULL; l = cdr(l)) {
|
|
cvar_type *c = (cvar_type *) car(l);
|
|
gc_move2heap(*(c->pvar)); // Transport underlying global, not the pvar
|
|
}
|
|
}
|
|
}
|
|
|
|
// Check allocated objects, moving additional objects as needed
|
|
while (scani < alloci) {
|
|
object obj = ((gc_thread_data *) data)->moveBuf[scani];
|
|
switch (type_of(obj)) {
|
|
case pair_tag:{
|
|
gc_move2heap(car(obj));
|
|
gc_move2heap(cdr(obj));
|
|
break;
|
|
}
|
|
case closure1_tag:
|
|
gc_move2heap(((closure1) obj)->element);
|
|
break;
|
|
case closureN_tag:{
|
|
int i, n = ((closureN) obj)->num_elements;
|
|
for (i = 0; i < n; i++) {
|
|
gc_move2heap(((closureN) obj)->elements[i]);
|
|
}
|
|
break;
|
|
}
|
|
case vector_tag:{
|
|
int i, n = ((vector) obj)->num_elements;
|
|
for (i = 0; i < n; i++) {
|
|
gc_move2heap(((vector) obj)->elements[i]);
|
|
}
|
|
break;
|
|
}
|
|
// No child objects to move
|
|
case macro_tag:
|
|
case bytevector_tag:
|
|
case string_tag:
|
|
case integer_tag:
|
|
case bignum_tag:
|
|
case double_tag:
|
|
case port_tag:
|
|
case cvar_tag:
|
|
case c_opaque_tag:
|
|
case complex_num_tag:
|
|
break;
|
|
// These types are not heap-allocated
|
|
case eof_tag:
|
|
case primitive_tag:
|
|
case symbol_tag:
|
|
case boolean_tag:
|
|
case closure0_tag:
|
|
default:
|
|
fprintf(stderr,
|
|
"GC: unexpected object type %d for object %p\n", type_of(obj),
|
|
obj);
|
|
exit(1);
|
|
}
|
|
scani++;
|
|
}
|
|
#if GC_DEBUG_VERBOSE
|
|
fprintf(stderr, "done with minor GC\n");
|
|
#endif
|
|
return alloci;
|
|
}
|
|
|
|
/**
|
|
* Run a minor GC from a mutator thread.
|
|
* This function runs the core GC algorithm, cooperates with
|
|
* the collector, and then calls its continuation.
|
|
*/
|
|
void GC(void *data, closure cont, object * args, int num_args)
|
|
{
|
|
char tmp;
|
|
object low_limit = &tmp; // This is one end of the stack...
|
|
object high_limit = ((gc_thread_data *) data)->stack_start;
|
|
int alloci = gc_minor(data, low_limit, high_limit, cont, args, num_args);
|
|
// Cooperate with the collector thread
|
|
gc_mut_cooperate((gc_thread_data *) data, alloci);
|
|
// Let it all go, Neo...
|
|
longjmp(*(((gc_thread_data *) data)->jmp_start), 1);
|
|
}
|
|
|
|
/**
|
|
* Move a thread-local object to the heap
|
|
*/
|
|
|
|
void Cyc_make_shared_object(void *data, object k, object obj)
|
|
{
|
|
gc_thread_data *thd = (gc_thread_data *)data;
|
|
gc_heap_root *heap = thd->heap;
|
|
object buf[1];
|
|
int tmp, *heap_grown = &tmp;
|
|
if (!is_object_type(obj) || // Immediates do not have to be moved
|
|
!gc_is_stack_obj(&tmp, data, obj)) { // Not thread-local, assume already on heap
|
|
return_closcall1(data, k, obj);
|
|
}
|
|
|
|
switch(type_of(obj)) {
|
|
// These are never on the stack, ignore them
|
|
// cond_var_tag = 6
|
|
// mutex_tag = 14
|
|
// atomic_tag = 22
|
|
// boolean_tag = 0
|
|
// bignum_tag = 12
|
|
// symbol_tag = 19
|
|
// closure0_tag = 3
|
|
// eof_tag = 9
|
|
// macro_tag = 13
|
|
// primitive_tag = 17
|
|
|
|
// Copy stack-allocated objects with no children to the heap:
|
|
case string_tag:
|
|
case double_tag:
|
|
case bytevector_tag:
|
|
case port_tag:
|
|
case c_opaque_tag:
|
|
case complex_num_tag: {
|
|
object hp = gc_alloc(heap, gc_allocated_bytes(obj, NULL, NULL), obj, thd, heap_grown);
|
|
return_closcall1(data, k, hp);
|
|
}
|
|
// Objs w/children force minor GC to guarantee everything is relocated:
|
|
case cvar_tag:
|
|
case closure1_tag:
|
|
case closureN_tag:
|
|
case pair_tag:
|
|
case vector_tag:
|
|
buf[0] = obj;
|
|
GC(data, k, buf, 1);
|
|
break;
|
|
default:
|
|
printf("Invalid shared object type %d\n", type_of(obj));
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* Receive a list of arguments and apply them to the given function
|
|
*/
|
|
void dispatch(void *data, int argc, function_type func, object clo, object cont,
|
|
object args)
|
|
{
|
|
object b[argc + 1]; // OK to do this? Is this portable?
|
|
int i;
|
|
|
|
argc++;
|
|
b[0] = cont;
|
|
for (i = 1; i < argc; i++) {
|
|
b[i] = car(args);
|
|
args = cdr(args);
|
|
}
|
|
|
|
do_dispatch(data, argc, func, clo, b);
|
|
}
|
|
|
|
/**
|
|
* Same as above but for a varargs C function
|
|
*/
|
|
void dispatch_va(void *data, int argc, function_type_va func, object clo,
|
|
object cont, object args)
|
|
{
|
|
object b[argc + 1]; // OK to do this? Is this portable?
|
|
int i;
|
|
|
|
argc++;
|
|
b[0] = cont;
|
|
for (i = 1; i < argc; i++) {
|
|
b[i] = car(args);
|
|
args = cdr(args);
|
|
}
|
|
|
|
do_dispatch(data, argc, (function_type) func, clo, b);
|
|
}
|
|
|
|
static primitive_type Cyc_91global_91vars_primitive =
|
|
{ {0}, primitive_tag, "Cyc-global-vars", &_Cyc_91global_91vars };
|
|
static primitive_type Cyc_91get_91cvar_primitive =
|
|
{ {0}, primitive_tag, "Cyc-get-cvar", &_Cyc_91get_91cvar };
|
|
static primitive_type Cyc_91set_91cvar_67_primitive =
|
|
{ {0}, primitive_tag, "Cyc-set-cvar!", &_Cyc_91set_91cvar_67 };
|
|
static primitive_type Cyc_91cvar_127_primitive =
|
|
{ {0}, primitive_tag, "Cyc-cvar?", &_Cyc_91cvar_127 };
|
|
static primitive_type Cyc_91opaque_127_primitive =
|
|
{ {0}, primitive_tag, "Cyc-opaque?", &_Cyc_91opaque_127 };
|
|
static primitive_type Cyc_91has_91cycle_127_primitive =
|
|
{ {0}, primitive_tag, "Cyc-has-cycle?", &_Cyc_91has_91cycle_127 };
|
|
static primitive_type Cyc_91spawn_91thread_67_primitive =
|
|
{ {0}, primitive_tag, "Cyc-spawn-thread!", &_Cyc_91spawn_91thread_67 };
|
|
static primitive_type Cyc_91end_91thread_67_primitive =
|
|
{ {0}, primitive_tag, "Cyc-end-thread!", &_Cyc_91end_91thread_67 };
|
|
static primitive_type _87_primitive = { {0}, primitive_tag, "+", &__87 };
|
|
static primitive_type _91_primitive = { {0}, primitive_tag, "-", &__91 };
|
|
static primitive_type _85_primitive = { {0}, primitive_tag, "*", &__85 };
|
|
static primitive_type _95_primitive = { {0}, primitive_tag, "/", &__95 };
|
|
static primitive_type _123_primitive = { {0}, primitive_tag, "=", &__123 };
|
|
static primitive_type _125_primitive = { {0}, primitive_tag, ">", &__125 };
|
|
static primitive_type _121_primitive = { {0}, primitive_tag, "<", &__121 };
|
|
static primitive_type _125_123_primitive =
|
|
{ {0}, primitive_tag, ">=", &__125_123 };
|
|
static primitive_type _121_123_primitive =
|
|
{ {0}, primitive_tag, "<=", &__121_123 };
|
|
static primitive_type apply_primitive =
|
|
{ {0}, primitive_tag, "apply", &_apply };
|
|
static primitive_type _75halt_primitive =
|
|
{ {0}, primitive_tag, "%halt", &__75halt };
|
|
static primitive_type exit_primitive =
|
|
{ {0}, primitive_tag, "exit", &_cyc_exit };
|
|
static primitive_type Cyc_91current_91exception_91handler_primitive =
|
|
{ {0}, primitive_tag, "Cyc_current_exception_handler",
|
|
&_Cyc_91current_91exception_91handler
|
|
};
|
|
static primitive_type Cyc_91default_91exception_91handler_primitive =
|
|
{ {0}, primitive_tag, "Cyc_default_exception_handler",
|
|
&_Cyc_91default_91exception_91handler
|
|
};
|
|
static primitive_type cons_primitive = { {0}, primitive_tag, "cons", &_cons };
|
|
static primitive_type cell_91get_primitive =
|
|
{ {0}, primitive_tag, "cell-get", &_cell_91get };
|
|
static primitive_type set_91global_67_primitive =
|
|
{ {0}, primitive_tag, "set-global!", &_set_91global_67 };
|
|
static primitive_type set_91cell_67_primitive =
|
|
{ {0}, primitive_tag, "set-cell!", &_set_91cell_67 };
|
|
static primitive_type cell_primitive = { {0}, primitive_tag, "cell", &_cell };
|
|
static primitive_type eq_127_primitive =
|
|
{ {0}, primitive_tag, "eq?", &_eq_127 };
|
|
static primitive_type eqv_127_primitive =
|
|
{ {0}, primitive_tag, "eqv?", &_eqv_127 };
|
|
static primitive_type equal_127_primitive =
|
|
{ {0}, primitive_tag, "equal?", &_equal_127 };
|
|
static primitive_type assq_primitive = { {0}, primitive_tag, "assq", &_assq };
|
|
static primitive_type assv_primitive = { {0}, primitive_tag, "assv", &_assv };
|
|
static primitive_type memq_primitive = { {0}, primitive_tag, "memq", &_memq };
|
|
static primitive_type memv_primitive = { {0}, primitive_tag, "memv", &_memv };
|
|
static primitive_type length_primitive =
|
|
{ {0}, primitive_tag, "length", &_length };
|
|
static primitive_type bytevector_91length_primitive =
|
|
{ {0}, primitive_tag, "bytevector-length", &_bytevector_91length };
|
|
static primitive_type vector_91length_primitive =
|
|
{ {0}, primitive_tag, "vector-length", &_vector_91length };
|
|
static primitive_type set_91car_67_primitive =
|
|
{ {0}, primitive_tag, "set-car!", &_set_91car_67 };
|
|
static primitive_type set_91cdr_67_primitive =
|
|
{ {0}, primitive_tag, "set-cdr!", &_set_91cdr_67 };
|
|
static primitive_type car_primitive = { {0}, primitive_tag, "car", &_car };
|
|
static primitive_type cdr_primitive = { {0}, primitive_tag, "cdr", &_cdr };
|
|
static primitive_type caar_primitive = { {0}, primitive_tag, "caar", &_caar };
|
|
static primitive_type cadr_primitive = { {0}, primitive_tag, "cadr", &_cadr };
|
|
static primitive_type cdar_primitive = { {0}, primitive_tag, "cdar", &_cdar };
|
|
static primitive_type cddr_primitive = { {0}, primitive_tag, "cddr", &_cddr };
|
|
static primitive_type caaar_primitive =
|
|
{ {0}, primitive_tag, "caaar", &_caaar };
|
|
static primitive_type caadr_primitive =
|
|
{ {0}, primitive_tag, "caadr", &_caadr };
|
|
static primitive_type cadar_primitive =
|
|
{ {0}, primitive_tag, "cadar", &_cadar };
|
|
static primitive_type caddr_primitive =
|
|
{ {0}, primitive_tag, "caddr", &_caddr };
|
|
static primitive_type cdaar_primitive =
|
|
{ {0}, primitive_tag, "cdaar", &_cdaar };
|
|
static primitive_type cdadr_primitive =
|
|
{ {0}, primitive_tag, "cdadr", &_cdadr };
|
|
static primitive_type cddar_primitive =
|
|
{ {0}, primitive_tag, "cddar", &_cddar };
|
|
static primitive_type cdddr_primitive =
|
|
{ {0}, primitive_tag, "cdddr", &_cdddr };
|
|
static primitive_type caaaar_primitive =
|
|
{ {0}, primitive_tag, "caaaar", &_caaaar };
|
|
static primitive_type caaadr_primitive =
|
|
{ {0}, primitive_tag, "caaadr", &_caaadr };
|
|
static primitive_type caadar_primitive =
|
|
{ {0}, primitive_tag, "caadar", &_caadar };
|
|
static primitive_type caaddr_primitive =
|
|
{ {0}, primitive_tag, "caaddr", &_caaddr };
|
|
static primitive_type cadaar_primitive =
|
|
{ {0}, primitive_tag, "cadaar", &_cadaar };
|
|
static primitive_type cadadr_primitive =
|
|
{ {0}, primitive_tag, "cadadr", &_cadadr };
|
|
static primitive_type caddar_primitive =
|
|
{ {0}, primitive_tag, "caddar", &_caddar };
|
|
static primitive_type cadddr_primitive =
|
|
{ {0}, primitive_tag, "cadddr", &_cadddr };
|
|
static primitive_type cdaaar_primitive =
|
|
{ {0}, primitive_tag, "cdaaar", &_cdaaar };
|
|
static primitive_type cdaadr_primitive =
|
|
{ {0}, primitive_tag, "cdaadr", &_cdaadr };
|
|
static primitive_type cdadar_primitive =
|
|
{ {0}, primitive_tag, "cdadar", &_cdadar };
|
|
static primitive_type cdaddr_primitive =
|
|
{ {0}, primitive_tag, "cdaddr", &_cdaddr };
|
|
static primitive_type cddaar_primitive =
|
|
{ {0}, primitive_tag, "cddaar", &_cddaar };
|
|
static primitive_type cddadr_primitive =
|
|
{ {0}, primitive_tag, "cddadr", &_cddadr };
|
|
static primitive_type cdddar_primitive =
|
|
{ {0}, primitive_tag, "cdddar", &_cdddar };
|
|
static primitive_type cddddr_primitive =
|
|
{ {0}, primitive_tag, "cddddr", &_cddddr };
|
|
static primitive_type char_91_125integer_primitive =
|
|
{ {0}, primitive_tag, "char->integer", &_char_91_125integer };
|
|
static primitive_type integer_91_125char_primitive =
|
|
{ {0}, primitive_tag, "integer->char", &_integer_91_125char };
|
|
static primitive_type string_91_125number_primitive =
|
|
{ {0}, primitive_tag, "string->number", &_string_91_125number };
|
|
static primitive_type string_91length_primitive =
|
|
{ {0}, primitive_tag, "string-length", &_string_91length };
|
|
static primitive_type substring_primitive =
|
|
{ {0}, primitive_tag, "substring", &_cyc_substring };
|
|
static primitive_type string_91ref_primitive =
|
|
{ {0}, primitive_tag, "string-ref", &_cyc_string_91ref };
|
|
static primitive_type string_91set_67_primitive =
|
|
{ {0}, primitive_tag, "string-set!", &_cyc_string_91set_67 };
|
|
static primitive_type Cyc_91installation_91dir_primitive =
|
|
{ {0}, primitive_tag, "Cyc-installation-dir", &_Cyc_91installation_91dir };
|
|
static primitive_type Cyc_91compilation_91environment_primitive =
|
|
{ {0}, primitive_tag, "Cyc-compilation-environment", &_Cyc_91compilation_91environment };
|
|
static primitive_type command_91line_91arguments_primitive =
|
|
{ {0}, primitive_tag, "command-line-arguments",
|
|
&_command_91line_91arguments
|
|
};
|
|
static primitive_type system_primitive =
|
|
{ {0}, primitive_tag, "system", &_cyc_system };
|
|
static primitive_type string_91cmp_primitive =
|
|
{ {0}, primitive_tag, "string-cmp", &_string_91cmp };
|
|
static primitive_type string_91append_primitive =
|
|
{ {0}, primitive_tag, "string-append", &_string_91append };
|
|
static primitive_type list_91_125string_primitive =
|
|
{ {0}, primitive_tag, "list->string", &_list_91_125string };
|
|
static primitive_type string_91_125symbol_primitive =
|
|
{ {0}, primitive_tag, "string->symbol", &_string_91_125symbol };
|
|
static primitive_type symbol_91_125string_primitive =
|
|
{ {0}, primitive_tag, "symbol->string", &_symbol_91_125string };
|
|
static primitive_type number_91_125string_primitive =
|
|
{ {0}, primitive_tag, "number->string", &_number_91_125string };
|
|
static primitive_type list_91_125vector_primitive =
|
|
{ {0}, primitive_tag, "list-vector", &_list_91_125vector };
|
|
static primitive_type make_91bytevector_primitive =
|
|
{ {0}, primitive_tag, "make-bytevector", &_make_91bytevector };
|
|
|
|
static primitive_type bytevector_primitive =
|
|
{ {0}, primitive_tag, "bytevector", &_bytevector };
|
|
static primitive_type bytevector_91append_primitive =
|
|
{ {0}, primitive_tag, "bytevector-append", &_bytevector_91append };
|
|
static primitive_type Cyc_91bytevector_91copy_primitive =
|
|
{ {0}, primitive_tag, "Cyc-bytevector-copy", &_Cyc_91bytevector_91copy };
|
|
static primitive_type bytevector_91u8_91ref_primitive =
|
|
{ {0}, primitive_tag, "bytevector-u8-ref", &_bytevector_91u8_91ref };
|
|
static primitive_type bytevector_91u8_91set_67_primitive =
|
|
{ {0}, primitive_tag, "bytevector-u8-set!", &_bytevector_91u8_91set_67 };
|
|
static primitive_type Cyc_91string_91_125utf8_primitive =
|
|
{ {0}, primitive_tag, "Cyc-string->utf8", &_Cyc_91string_91_125utf8 };
|
|
static primitive_type Cyc_91utf8_91_125string_primitive =
|
|
{ {0}, primitive_tag, "Cyc-utf8->string", &_Cyc_91utf8_91_125string };
|
|
static primitive_type make_91vector_primitive =
|
|
{ {0}, primitive_tag, "make-vector", &_make_91vector };
|
|
static primitive_type vector_91ref_primitive =
|
|
{ {0}, primitive_tag, "vector-ref", &_vector_91ref };
|
|
static primitive_type vector_91set_67_primitive =
|
|
{ {0}, primitive_tag, "vector-set!", &_vector_91set_67 };
|
|
static primitive_type boolean_127_primitive =
|
|
{ {0}, primitive_tag, "boolean?", &_boolean_127 };
|
|
static primitive_type char_127_primitive =
|
|
{ {0}, primitive_tag, "char?", &_char_127 };
|
|
static primitive_type eof_91object_127_primitive =
|
|
{ {0}, primitive_tag, "eof-object?", &_eof_91object_127 };
|
|
static primitive_type null_127_primitive =
|
|
{ {0}, primitive_tag, "null?", &_null_127 };
|
|
static primitive_type number_127_primitive =
|
|
{ {0}, primitive_tag, "number?", &_number_127 };
|
|
static primitive_type real_127_primitive =
|
|
{ {0}, primitive_tag, "real?", &_real_127 };
|
|
static primitive_type integer_127_primitive =
|
|
{ {0}, primitive_tag, "integer?", &_integer_127 };
|
|
static primitive_type pair_127_primitive =
|
|
{ {0}, primitive_tag, "pair?", &_pair_127 };
|
|
static primitive_type procedure_127_primitive =
|
|
{ {0}, primitive_tag, "procedure?", &_procedure_127 };
|
|
static primitive_type macro_127_primitive =
|
|
{ {0}, primitive_tag, "macro?", &_macro_127 };
|
|
static primitive_type Cyc_91macro_127_primitive =
|
|
{ {0}, primitive_tag, "Cyc-macro?", &_Cyc_91macro_127 };
|
|
static primitive_type port_127_primitive =
|
|
{ {0}, primitive_tag, "port?", &_port_127 };
|
|
static primitive_type bytevector_127_primitive =
|
|
{ {0}, primitive_tag, "bytevector?", &_vector_127 };
|
|
static primitive_type vector_127_primitive =
|
|
{ {0}, primitive_tag, "vector?", &_vector_127 };
|
|
static primitive_type string_127_primitive =
|
|
{ {0}, primitive_tag, "string?", &_string_127 };
|
|
static primitive_type symbol_127_primitive =
|
|
{ {0}, primitive_tag, "symbol?", &_symbol_127 };
|
|
static primitive_type open_91input_91file_primitive =
|
|
{ {0}, primitive_tag, "open-input-file", &_open_91input_91file };
|
|
static primitive_type open_91output_91file_primitive =
|
|
{ {0}, primitive_tag, "open-output-file", &_open_91output_91file };
|
|
static primitive_type close_91port_primitive =
|
|
{ {0}, primitive_tag, "close-port", &_close_91port };
|
|
static primitive_type close_91input_91port_primitive =
|
|
{ {0}, primitive_tag, "close-input-port", &_close_91input_91port };
|
|
static primitive_type close_91output_91port_primitive =
|
|
{ {0}, primitive_tag, "close-output-port", &_close_91output_91port };
|
|
static primitive_type Cyc_91flush_91output_91port_primitive =
|
|
{ {0}, primitive_tag, "Cyc-flush-output-port",
|
|
&_Cyc_91flush_91output_91port
|
|
};
|
|
static primitive_type file_91exists_127_primitive =
|
|
{ {0}, primitive_tag, "file-exists?", &_file_91exists_127 };
|
|
static primitive_type delete_91file_primitive =
|
|
{ {0}, primitive_tag, "delete-file", &_delete_91file };
|
|
static primitive_type read_91char_primitive =
|
|
{ {0}, primitive_tag, "read-char", &_read_91char };
|
|
static primitive_type peek_91char_primitive =
|
|
{ {0}, primitive_tag, "peek-char", &_peek_91char };
|
|
static primitive_type Cyc_91read_91line_primitive =
|
|
{ {0}, primitive_tag, "Cyc-read-line", &_Cyc_91read_91line };
|
|
static primitive_type Cyc_91write_primitive =
|
|
{ {0}, primitive_tag, "Cyc-write", &_Cyc_91write };
|
|
static primitive_type Cyc_91write_91char_primitive =
|
|
{ {0}, primitive_tag, "Cyc-write-char", &_Cyc_91write_91char };
|
|
static primitive_type Cyc_91display_primitive =
|
|
{ {0}, primitive_tag, "Cyc-display", &_display };
|
|
static primitive_type call_95cc_primitive =
|
|
{ {0}, primitive_tag, "call/cc", &_call_95cc };
|
|
|
|
const object primitive_Cyc_91global_91vars = &Cyc_91global_91vars_primitive;
|
|
const object primitive_Cyc_91get_91cvar = &Cyc_91get_91cvar_primitive;
|
|
const object primitive_Cyc_91set_91cvar_67 = &Cyc_91set_91cvar_67_primitive;
|
|
const object primitive_Cyc_91cvar_127 = &Cyc_91cvar_127_primitive;
|
|
const object primitive_Cyc_91opaque_127 = &Cyc_91opaque_127_primitive;
|
|
const object primitive_Cyc_91has_91cycle_127 = &Cyc_91has_91cycle_127_primitive;
|
|
const object primitive_Cyc_91spawn_91thread_67 =
|
|
&Cyc_91spawn_91thread_67_primitive;
|
|
const object primitive_Cyc_91end_91thread_67 = &Cyc_91end_91thread_67_primitive;
|
|
const object primitive__87 = &_87_primitive;
|
|
const object primitive__91 = &_91_primitive;
|
|
const object primitive__85 = &_85_primitive;
|
|
const object primitive__95 = &_95_primitive;
|
|
const object primitive__123 = &_123_primitive;
|
|
const object primitive__125 = &_125_primitive;
|
|
const object primitive__121 = &_121_primitive;
|
|
const object primitive__125_123 = &_125_123_primitive;
|
|
const object primitive__121_123 = &_121_123_primitive;
|
|
const object primitive_apply = &apply_primitive;
|
|
const object primitive__75halt = &_75halt_primitive;
|
|
const object primitive_exit = &exit_primitive;
|
|
const object primitive_Cyc_91current_91exception_91handler =
|
|
&Cyc_91current_91exception_91handler_primitive;
|
|
const object primitive_Cyc_91default_91exception_91handler =
|
|
&Cyc_91default_91exception_91handler_primitive;
|
|
const object primitive_cons = &cons_primitive;
|
|
const object primitive_cell_91get = &cell_91get_primitive;
|
|
const object primitive_set_91global_67 = &set_91global_67_primitive;
|
|
const object primitive_set_91cell_67 = &set_91cell_67_primitive;
|
|
const object primitive_cell = &cell_primitive;
|
|
const object primitive_eq_127 = &eq_127_primitive;
|
|
const object primitive_eqv_127 = &eqv_127_primitive;
|
|
const object primitive_equal_127 = &equal_127_primitive;
|
|
const object primitive_assq = &assq_primitive;
|
|
const object primitive_assv = &assv_primitive;
|
|
const object primitive_memq = &memq_primitive;
|
|
const object primitive_memv = &memv_primitive;
|
|
const object primitive_length = &length_primitive;
|
|
const object primitive_bytevector_91length = &bytevector_91length_primitive;
|
|
const object primitive_vector_91length = &vector_91length_primitive;
|
|
const object primitive_vector_91ref = &vector_91ref_primitive;
|
|
const object primitive_vector_91set_67 = &vector_91set_67_primitive;
|
|
const object primitive_set_91car_67 = &set_91car_67_primitive;
|
|
const object primitive_set_91cdr_67 = &set_91cdr_67_primitive;
|
|
const object primitive_car = &car_primitive;
|
|
const object primitive_cdr = &cdr_primitive;
|
|
const object primitive_caar = &caar_primitive;
|
|
const object primitive_cadr = &cadr_primitive;
|
|
const object primitive_cdar = &cdar_primitive;
|
|
const object primitive_cddr = &cddr_primitive;
|
|
const object primitive_caaar = &caaar_primitive;
|
|
const object primitive_caadr = &caadr_primitive;
|
|
const object primitive_cadar = &cadar_primitive;
|
|
const object primitive_caddr = &caddr_primitive;
|
|
const object primitive_cdaar = &cdaar_primitive;
|
|
const object primitive_cdadr = &cdadr_primitive;
|
|
const object primitive_cddar = &cddar_primitive;
|
|
const object primitive_cdddr = &cdddr_primitive;
|
|
const object primitive_caaaar = &caaaar_primitive;
|
|
const object primitive_caaadr = &caaadr_primitive;
|
|
const object primitive_caadar = &caadar_primitive;
|
|
const object primitive_caaddr = &caaddr_primitive;
|
|
const object primitive_cadaar = &cadaar_primitive;
|
|
const object primitive_cadadr = &cadadr_primitive;
|
|
const object primitive_caddar = &caddar_primitive;
|
|
const object primitive_cadddr = &cadddr_primitive;
|
|
const object primitive_cdaaar = &cdaaar_primitive;
|
|
const object primitive_cdaadr = &cdaadr_primitive;
|
|
const object primitive_cdadar = &cdadar_primitive;
|
|
const object primitive_cdaddr = &cdaddr_primitive;
|
|
const object primitive_cddaar = &cddaar_primitive;
|
|
const object primitive_cddadr = &cddadr_primitive;
|
|
const object primitive_cdddar = &cdddar_primitive;
|
|
const object primitive_cddddr = &cddddr_primitive;
|
|
const object primitive_char_91_125integer = &char_91_125integer_primitive;
|
|
const object primitive_integer_91_125char = &integer_91_125char_primitive;
|
|
const object primitive_string_91_125number = &string_91_125number_primitive;
|
|
const object primitive_string_91length = &string_91length_primitive;
|
|
const object primitive_substring = &substring_primitive;
|
|
const object primitive_string_91ref = &string_91ref_primitive;
|
|
const object primitive_string_91set_67 = &string_91set_67_primitive;
|
|
const object primitive_Cyc_91installation_91dir =
|
|
&Cyc_91installation_91dir_primitive;
|
|
const object primitive_Cyc_91compilation_91environment =
|
|
&Cyc_91compilation_91environment_primitive;
|
|
const object primitive_command_91line_91arguments =
|
|
&command_91line_91arguments_primitive;
|
|
const object primitive_system = &system_primitive;
|
|
const object primitive_string_91cmp = &string_91cmp_primitive;
|
|
const object primitive_string_91append = &string_91append_primitive;
|
|
const object primitive_list_91_125string = &list_91_125string_primitive;
|
|
const object primitive_string_91_125symbol = &string_91_125symbol_primitive;
|
|
const object primitive_symbol_91_125string = &symbol_91_125string_primitive;
|
|
const object primitive_number_91_125string = &number_91_125string_primitive;
|
|
const object primitive_make_91bytevector = &make_91bytevector_primitive;
|
|
const object primitive_make_91vector = &make_91vector_primitive;
|
|
const object primitive_bytevector = &bytevector_primitive;
|
|
const object primitive_bytevector_91append = &bytevector_91append_primitive;
|
|
const object primitive_Cyc_91bytevector_91copy =
|
|
&Cyc_91bytevector_91copy_primitive;
|
|
const object primitive_bytevector_91u8_91ref = &bytevector_91u8_91ref_primitive;
|
|
const object primitive_bytevector_91u8_91set_67 =
|
|
&bytevector_91u8_91set_67_primitive;
|
|
const object primitive_Cyc_91string_91_125utf8 =
|
|
&Cyc_91string_91_125utf8_primitive;
|
|
const object primitive_Cyc_91utf8_91_125string =
|
|
&Cyc_91utf8_91_125string_primitive;
|
|
const object primitive_list_91_125vector = &list_91_125vector_primitive;
|
|
const object primitive_boolean_127 = &boolean_127_primitive;
|
|
const object primitive_char_127 = &char_127_primitive;
|
|
const object primitive_eof_91object_127 = &eof_91object_127_primitive;
|
|
const object primitive_null_127 = &null_127_primitive;
|
|
const object primitive_number_127 = &number_127_primitive;
|
|
const object primitive_real_127 = &real_127_primitive;
|
|
const object primitive_integer_127 = &integer_127_primitive;
|
|
const object primitive_pair_127 = &pair_127_primitive;
|
|
const object primitive_procedure_127 = &procedure_127_primitive;
|
|
const object primitive_macro_127 = ¯o_127_primitive;
|
|
const object primitive_Cyc_91macro_127 = &Cyc_91macro_127_primitive;
|
|
const object primitive_string_127 = &string_127_primitive;
|
|
const object primitive_port_127 = &port_127_primitive;
|
|
const object primitive_vector_127 = &vector_127_primitive;
|
|
const object primitive_bytevector_127 = &bytevector_127_primitive;
|
|
const object primitive_symbol_127 = &symbol_127_primitive;
|
|
const object primitive_open_91input_91file = &open_91input_91file_primitive;
|
|
const object primitive_open_91output_91file = &open_91output_91file_primitive;
|
|
const object primitive_close_91port = &close_91port_primitive;
|
|
const object primitive_close_91input_91port = &close_91input_91port_primitive;
|
|
const object primitive_close_91output_91port = &close_91output_91port_primitive;
|
|
const object primitive_Cyc_91flush_91output_91port =
|
|
&Cyc_91flush_91output_91port_primitive;
|
|
const object primitive_file_91exists_127 = &file_91exists_127_primitive;
|
|
const object primitive_delete_91file = &delete_91file_primitive;
|
|
const object primitive_read_91char = &read_91char_primitive;
|
|
const object primitive_peek_91char = &peek_91char_primitive;
|
|
const object primitive_Cyc_91read_91line = &Cyc_91read_91line_primitive;
|
|
const object primitive_Cyc_91write_91char = &Cyc_91write_91char_primitive;
|
|
const object primitive_Cyc_91write = &Cyc_91write_primitive;
|
|
const object primitive_Cyc_91display = &Cyc_91display_primitive;
|
|
const object primitive_call_95cc = &call_95cc_primitive;
|
|
|
|
void *gc_alloc_pair(gc_thread_data *data, object head, object tail)
|
|
{
|
|
int heap_grown;
|
|
pair_type *p;
|
|
pair_type tmp;
|
|
tmp.hdr.mark = gc_color_red;
|
|
tmp.hdr.grayed = 0;
|
|
tmp.hdr.immutable = 0;
|
|
tmp.tag = pair_tag;
|
|
tmp.pair_car = head;
|
|
tmp.pair_cdr = tail;
|
|
p = gc_alloc(((gc_thread_data *)data)->heap, sizeof(pair_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
|
|
|
|
return p;
|
|
}
|
|
|
|
/**
|
|
* Thread initialization function only called from within the runtime
|
|
*/
|
|
void *Cyc_init_thread(object thread_and_thunk)
|
|
{
|
|
vector_type *t;
|
|
c_opaque_type *o;
|
|
object op, parent, child, tmp;
|
|
long stack_start;
|
|
gc_thread_data *thd;
|
|
|
|
// Extract passed-in thread data object
|
|
tmp = car(thread_and_thunk);
|
|
t = (vector_type *)tmp;
|
|
op = _unsafe_Cyc_vector_ref(t, obj_int2obj(2)); // Field set in thread-start!
|
|
if (op == NULL) {
|
|
// Should never happen
|
|
thd = malloc(sizeof(gc_thread_data));
|
|
} else {
|
|
o = (c_opaque_type *)op;
|
|
thd = (gc_thread_data *)(opaque_ptr(o));
|
|
}
|
|
gc_thread_data_init(thd, 0, (char *)&stack_start, global_stack_size);
|
|
thd->scm_thread_obj = car(thread_and_thunk);
|
|
thd->gc_cont = cdr(thread_and_thunk);
|
|
thd->gc_num_args = 1;
|
|
thd->gc_args[0] = &Cyc_91end_91thread_67_primitive;
|
|
thd->thread_id = pthread_self();
|
|
|
|
// Copy thread params from the calling thread
|
|
t = (vector_type *)thd->scm_thread_obj;
|
|
op = Cyc_vector_ref(thd, t, obj_int2obj(5)); // Field set in thread-start!
|
|
o = (c_opaque_type *)op;
|
|
parent = ((gc_thread_data *)o->ptr)->param_objs; // Unbox parent thread's data
|
|
child = NULL;
|
|
thd->param_objs = NULL;
|
|
while (parent) {
|
|
if (thd->param_objs == NULL) {
|
|
thd->param_objs = gc_alloc_pair(thd, NULL, NULL);
|
|
child = thd->param_objs;
|
|
} else {
|
|
pair_type *p = gc_alloc_pair(thd, NULL, NULL);
|
|
cdr(child) = p;
|
|
child = p;
|
|
}
|
|
car(child) = gc_alloc_pair(thd, car(car(parent)), cdr(car(parent)));
|
|
parent = cdr(parent);
|
|
}
|
|
// Done initializing parameter objects
|
|
|
|
gc_add_mutator(thd);
|
|
ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_NEW,
|
|
CYC_THREAD_STATE_RUNNABLE);
|
|
Cyc_start_trampoline(thd);
|
|
return NULL;
|
|
}
|
|
|
|
/**
|
|
* Spawn a new thread to execute the given thunk
|
|
*/
|
|
object Cyc_spawn_thread(object thread_and_thunk)
|
|
{
|
|
// TODO: if we want to return mutator number to the caller, we need
|
|
// to reserve a number here. need to figure out how we are going to
|
|
// synchronize access to GC mutator fields, and then reserve one
|
|
// here. will need to pass it, along with thunk, to Cyc_init_thread.
|
|
// Then can use a new function up there to add the mutator, since we
|
|
// already have the number.
|
|
/*
|
|
how to manage gc mutators. need to handle:
|
|
- need to be able to allocate a thread but not run it yet.
|
|
maybe have a run level, or status
|
|
- need to make mutators thread safe, ideally without major performance impacts
|
|
- thread terminates
|
|
- should mark mutator as 'done'
|
|
- at an opportune moment, free mutator and set it back
|
|
to null
|
|
|
|
what is the right data structure? is the array OK? or would it be better
|
|
to look at the lock-free structures provided by ck?
|
|
*/
|
|
pthread_t thread;
|
|
pthread_attr_t attr;
|
|
pthread_attr_init(&attr);
|
|
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
|
|
if (pthread_create(&thread, &attr, Cyc_init_thread, thread_and_thunk)) {
|
|
fprintf(stderr, "Error creating a new thread\n");
|
|
exit(1);
|
|
}
|
|
pthread_attr_destroy(&attr);
|
|
return boolean_t;
|
|
}
|
|
|
|
/**
|
|
* Terminate a thread
|
|
*/
|
|
void Cyc_end_thread(gc_thread_data * thd)
|
|
{
|
|
// TODO: should we consider passing the current continuation (and args)
|
|
// as an argument? if we don't, will objects be collected that are still
|
|
// being used by active threads??
|
|
mclosure0(clo, Cyc_exit_thread);
|
|
GC(thd, &clo, thd->gc_args, 0);
|
|
}
|
|
|
|
void Cyc_exit_thread(gc_thread_data * thd)
|
|
{
|
|
// alternatively could call longjmp with a null continuation, but that seems
|
|
// more complicated than necessary. or does it... see next comment:
|
|
|
|
// TODO: what if there are any locals from the thread's stack still being
|
|
// referenced? might want to do one more minor GC to clear the stack before
|
|
// terminating the thread
|
|
|
|
//printf("DEBUG - exiting thread\n");
|
|
// Remove thread from the list of mutators, and mark its data to be freed
|
|
gc_remove_mutator(thd);
|
|
ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_RUNNABLE,
|
|
CYC_THREAD_STATE_TERMINATED);
|
|
pthread_exit(NULL); // For now, just a proof of concept
|
|
}
|
|
|
|
/**
|
|
* @brief Accept a number of seconds to sleep according to SRFI-18
|
|
*/
|
|
object Cyc_thread_sleep(void *data, object timeout)
|
|
{
|
|
struct timespec tim;
|
|
double value;
|
|
Cyc_check_num(data, timeout);
|
|
value = unbox_number(timeout);
|
|
tim.tv_sec = (long)value;
|
|
tim.tv_nsec = (long)((value - tim.tv_sec) * 1000 * NANOSECONDS_PER_MILLISECOND);
|
|
nanosleep(&tim, NULL);
|
|
return boolean_t;
|
|
}
|
|
|
|
/**
|
|
* @brief Copy given object to the heap, if it is from the stack.
|
|
* This function is intended to be called directly from application code.
|
|
* Note that only a shallow-copy is performed! For example, a pair object
|
|
* would be copied to the heap but its `car` and `cdr` objects would not.
|
|
* @param data Thread data object for the caller.
|
|
* @param obj Object to copy.
|
|
*/
|
|
object copy2heap(void *data, object obj)
|
|
{
|
|
char stack_pos;
|
|
gc_thread_data *thd = (gc_thread_data *) data;
|
|
int on_stack = stack_overflow((object) (&stack_pos), obj) &&
|
|
stack_overflow(obj, (object) thd->stack_start);
|
|
if (!is_object_type(obj) || !on_stack) {
|
|
return obj;
|
|
}
|
|
|
|
return gc_alloc(((gc_thread_data *)data)->heap, gc_allocated_bytes(obj, NULL, NULL), obj, data,
|
|
&on_stack);
|
|
}
|
|
|
|
// TODO: version of above that will perform a deep copy (via GC) if necessary
|
|
|
|
// Generic buffer functions
|
|
void **vpbuffer_realloc(void **buf, int *len)
|
|
{
|
|
return realloc(buf, (*len) * sizeof(void *));
|
|
}
|
|
|
|
void **vpbuffer_add(void **buf, int *len, int i, void *obj)
|
|
{
|
|
if (i == *len) {
|
|
*len *= 2;
|
|
buf = vpbuffer_realloc(buf, len);
|
|
}
|
|
buf[i] = obj;
|
|
return buf;
|
|
}
|
|
|
|
void vpbuffer_free(void **buf)
|
|
{
|
|
free(buf);
|
|
}
|
|
|
|
vpbuffer *vp_create(void)
|
|
{
|
|
vpbuffer *v = malloc(sizeof(vpbuffer));
|
|
v->len = 128;
|
|
v->count = 0;
|
|
v->buf = NULL;
|
|
v->buf = vpbuffer_realloc(v->buf, &(v->len));
|
|
return v;
|
|
}
|
|
|
|
void vp_add(vpbuffer *v, void *obj)
|
|
{
|
|
v->buf = vpbuffer_add(v->buf, &(v->len), v->count++, obj);
|
|
}
|
|
|
|
object Cyc_bit_unset(void *data, object n1, object n2)
|
|
{
|
|
Cyc_check_int(data, n1);
|
|
Cyc_check_int(data, n2);
|
|
return (obj_int2obj(
|
|
obj_obj2int(n1) & ~(obj_obj2int(n2))));
|
|
}
|
|
|
|
object Cyc_bit_set(void *data, object n1, object n2)
|
|
{
|
|
Cyc_check_int(data, n1);
|
|
Cyc_check_int(data, n2);
|
|
return (obj_int2obj(
|
|
obj_obj2int(n1) | obj_obj2int(n2)));
|
|
}
|
|
|
|
object Cyc_num2double(void *data, object ptr, object z)
|
|
{
|
|
return_inexact_double_op_no_cps(data, ptr, (double), z);
|
|
}
|
|
|
|
void Cyc_make_rectangular(void *data, object k, object r, object i)
|
|
{
|
|
double_type dr, di;
|
|
Cyc_num2double(data, &dr, r);
|
|
Cyc_num2double(data, &di, i);
|
|
make_complex_num(num, double_value(&dr), double_value(&di));
|
|
return_closcall1(data, k, &num);
|
|
}
|
|
|
|
/* RNG section */
|
|
#define norm 2.328306549295728e-10
|
|
#define m1 4294967087.0
|
|
#define m2 4294944443.0
|
|
#define a12 1403580.0
|
|
#define a13n 810728.0
|
|
#define a21 527612.0
|
|
#define a23n 1370589.0
|
|
|
|
/***
|
|
The seeds for s10, s11, s12 must be integers in [0, m1 - 1] and not all 0.
|
|
The seeds for s20, s21, s22 must be integers in [0, m2 - 1] and not all 0.
|
|
***/
|
|
|
|
//#define SEED 12345
|
|
|
|
// JAE TODO: OK not to have these static?
|
|
//static double s10 = SEED, s11 = SEED, s12 = SEED,
|
|
// s20 = SEED, s21 = SEED, s22 = SEED;
|
|
|
|
|
|
double MRG32k3a (double seed)
|
|
{
|
|
double s10 = seed, s11 = seed, s12 = seed,
|
|
s20 = seed, s21 = seed, s22 = seed;
|
|
long k;
|
|
double p1, p2;
|
|
/* Component 1 */
|
|
p1 = a12 * s11 - a13n * s10;
|
|
k = p1 / m1;
|
|
p1 -= k * m1;
|
|
if (p1 < 0.0)
|
|
p1 += m1;
|
|
s10 = s11;
|
|
s11 = s12;
|
|
s12 = p1;
|
|
|
|
/* Component 2 */
|
|
p2 = a21 * s22 - a23n * s20;
|
|
k = p2 / m2;
|
|
p2 -= k * m2;
|
|
if (p2 < 0.0)
|
|
p2 += m2;
|
|
s20 = s21;
|
|
s21 = s22;
|
|
s22 = p2;
|
|
|
|
/* Combination */
|
|
if (p1 <= p2)
|
|
return ((p1 - p2 + m1) * norm);
|
|
else
|
|
return ((p1 - p2) * norm);
|
|
}
|
|
/* END RNG */
|
|
|
|
|
|
/** Dynamic loading */
|
|
void Cyc_import_shared_object(void *data, object cont, object filename, object entry_pt_fnc)
|
|
{
|
|
char buffer[256];
|
|
void *handle;
|
|
function_type entry_pt;
|
|
Cyc_check_str(data, filename);
|
|
Cyc_check_str(data, entry_pt_fnc);
|
|
handle = dlopen(string_str(filename), RTLD_GLOBAL | RTLD_LAZY);
|
|
if (handle == NULL) {
|
|
snprintf(buffer, 256, "%s", dlerror());
|
|
make_utf8_string(data, s, buffer);
|
|
Cyc_rt_raise2(data, "Unable to import library", &s);
|
|
}
|
|
dlerror(); /* Clear any existing error */
|
|
|
|
entry_pt = (function_type) dlsym(handle, string_str(entry_pt_fnc));
|
|
if (entry_pt == NULL) {
|
|
snprintf(buffer, 256, "%s, %s, %s", string_str(filename), string_str(entry_pt_fnc), dlerror());
|
|
make_utf8_string(data, s, buffer);
|
|
Cyc_rt_raise2(data, "Unable to load symbol", &s);
|
|
}
|
|
mclosure1(clo, entry_pt, cont);
|
|
entry_pt(data, 0, &clo, &clo);
|
|
}
|
|
|
|
/** Read */
|
|
|
|
/**
|
|
* @brief Helper function to perform a buffered read from an input port
|
|
* @param p Input port
|
|
* @return Number of characters read, or 0 for EOF/error
|
|
*/
|
|
int read_from_port(port_type *p)
|
|
{
|
|
size_t rv = 0;
|
|
FILE *fp = p->fp;
|
|
char *buf = p->mem_buf;
|
|
|
|
while(1) {
|
|
errno = 0;
|
|
rv = fread(buf, sizeof(char), p->read_len, fp);
|
|
|
|
if (rv != 0 || !ferror(fp) || errno != EINTR) {
|
|
break;
|
|
}
|
|
}
|
|
|
|
p->mem_buf_len = rv;
|
|
p->buf_idx = 0;
|
|
return rv;
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to raise an error from (read)
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
* @param msg Error message
|
|
*/
|
|
static void _read_error(void *data, port_type *p, const char *msg)
|
|
{
|
|
char buf[1024];
|
|
snprintf(buf, 1023, "(line %d, column %d): %s",
|
|
p->line_num, p->col_num, msg);
|
|
// TODO: can't do this because thread is blocked, need to return a value to cont.
|
|
// the cont could receive an error and raise it though
|
|
//Cyc_rt_raise_msg(data, buf);
|
|
make_string(str, buf);
|
|
str.num_cp = Cyc_utf8_count_code_points((uint8_t *)buf);
|
|
make_empty_vector(vec);
|
|
vec.num_elements = 1;
|
|
vec.elements = (object *) alloca(sizeof(object) * vec.num_elements);
|
|
vec.elements[0] = &str;
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read past a comment
|
|
* @param p Input port
|
|
*/
|
|
static void _read_line_comment(port_type *p)
|
|
{
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
break; // Return if buf is empty
|
|
}
|
|
}
|
|
if (p->mem_buf[p->buf_idx++] == '\n') {
|
|
p->line_num++; // Ignore col_num since we are just skipping over chars
|
|
p->col_num = 1;
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read past a block comment
|
|
* @param p Input port
|
|
*/
|
|
static void _read_multiline_comment(port_type *p)
|
|
{
|
|
int maybe_end = 0;
|
|
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
break; // Return if buf is empty
|
|
}
|
|
}
|
|
|
|
if (p->mem_buf[p->buf_idx] == '#' && maybe_end) {
|
|
p->buf_idx++;
|
|
break;
|
|
}
|
|
|
|
if (p->mem_buf[p->buf_idx] == '|') {
|
|
maybe_end = 1;
|
|
} else {
|
|
maybe_end = 0;
|
|
}
|
|
|
|
if (p->mem_buf[p->buf_idx] == '\n') {
|
|
p->line_num++;
|
|
p->col_num = 1;
|
|
} else {
|
|
p->col_num++;
|
|
}
|
|
p->buf_idx++;
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read past whitespace characters
|
|
* @param p Input port
|
|
*/
|
|
static void _read_whitespace(port_type *p)
|
|
{
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
break; // Return if buf is empty
|
|
}
|
|
}
|
|
if (p->mem_buf[p->buf_idx] == '\n') {
|
|
p->buf_idx++;
|
|
p->line_num++; // Ignore col_num since we are just skipping over chars
|
|
p->col_num = 1;
|
|
break;
|
|
} else if (isspace(p->mem_buf[p->buf_idx])) {
|
|
p->buf_idx++;
|
|
p->col_num++;
|
|
} else {
|
|
break; // Terminate on non-whitespace char
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to add a character to the port's token buffer
|
|
* @param p Input port
|
|
* @param c Character to add
|
|
*/
|
|
static void _read_add_to_tok_buf(port_type *p, char c)
|
|
{
|
|
// FUTURE: more efficient to try and use mem_buf directly??
|
|
// complicates things with more edge cases though
|
|
if ((p->tok_end + 1) == p->tok_buf_len) { // +1 for trailing \0 later on
|
|
p->tok_buf_len *= 2;
|
|
p->tok_buf = realloc(p->tok_buf, p->tok_buf_len);
|
|
if (!p->tok_buf) {
|
|
fprintf(stderr, "Unable to grow token buffer!\n");
|
|
exit(1);
|
|
}
|
|
}
|
|
p->tok_buf[p->tok_end++] = c;
|
|
}
|
|
|
|
/**
|
|
* @brief Determine if given string is numeric
|
|
*/
|
|
static int _read_is_numeric(const char *tok, int len)
|
|
{
|
|
return (len &&
|
|
((isdigit(tok[0])) ||
|
|
((len > 1) && tok[0] == '.' && isdigit(tok[1])) ||
|
|
((len > 1) && (tok[1] == '.' || isdigit(tok[1])) && (tok[0] == '-' || tok[0] == '+'))));
|
|
}
|
|
|
|
/**
|
|
* @brief Determine if given string is a complex number
|
|
*/
|
|
static int _read_is_complex_number(const char *tok, int len)
|
|
{
|
|
// Assumption: tok already passed checks from _read_is_numeric
|
|
return (tok[len - 1] == 'i' ||
|
|
tok[len - 1] == 'I');
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function, determine if given number is a hex digit
|
|
* @param c Character to check
|
|
*/
|
|
static int _read_is_hex_digit(char c)
|
|
{
|
|
return (c >= 'a' && c <= 'f') ||
|
|
(c >= 'A' && c <= 'F');
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read a string
|
|
* @param data Thread data object
|
|
* @param cont Current continuation
|
|
* @param p Input port
|
|
*/
|
|
static void _read_string(void *data, object cont, port_type *p)
|
|
{
|
|
char c;
|
|
int escaped = 0;
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
_read_error(data, p, "Missing closing double-quote");
|
|
}
|
|
}
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
|
|
if (escaped) {
|
|
escaped = 0;
|
|
switch (c) {
|
|
case '"':
|
|
case '\'':
|
|
case '?':
|
|
case '|':
|
|
case '\\':
|
|
_read_add_to_tok_buf(p, c);
|
|
break;
|
|
case 'a':
|
|
_read_add_to_tok_buf(p, '\a');
|
|
break;
|
|
case 'b':
|
|
_read_add_to_tok_buf(p, '\b');
|
|
break;
|
|
case 'n':
|
|
_read_add_to_tok_buf(p, '\n');
|
|
break;
|
|
case 'r':
|
|
_read_add_to_tok_buf(p, '\r');
|
|
break;
|
|
case 't':
|
|
_read_add_to_tok_buf(p, '\t');
|
|
break;
|
|
case 'x': {
|
|
char buf[32];
|
|
int i = 0;
|
|
while (i < 31){
|
|
if (p->mem_buf_len == 0 || p->mem_buf_len == p->buf_idx) {
|
|
int rv = read_from_port(p);
|
|
if (!rv) {
|
|
break;
|
|
}
|
|
}
|
|
if (p->mem_buf[p->buf_idx] == ';'){
|
|
p->buf_idx++;
|
|
break;
|
|
}
|
|
// Verify if hex digit is valid
|
|
if (!isdigit(p->mem_buf[p->buf_idx]) &&
|
|
!_read_is_hex_digit(p->mem_buf[p->buf_idx])) {
|
|
p->buf_idx++;
|
|
_read_error(data, p, "invalid hex digit in string");
|
|
}
|
|
buf[i] = p->mem_buf[p->buf_idx];
|
|
p->buf_idx++;
|
|
p->col_num++;
|
|
i++;
|
|
}
|
|
buf[i] = '\0';
|
|
{
|
|
char_type result = strtol(buf, NULL, 16);
|
|
char cbuf[5];
|
|
int i;
|
|
Cyc_utf8_encode_char(cbuf, 5, result);
|
|
for (i = 0; cbuf[i] != 0; i++) {
|
|
_read_add_to_tok_buf(p, cbuf[i]);
|
|
}
|
|
//p->tok_buf[p->tok_end++] = (char)result;
|
|
}
|
|
break;
|
|
}
|
|
default:
|
|
_read_error(data, p, "invalid escape character in string"); // TODO: char
|
|
break;
|
|
}
|
|
} else if (c == '"') {
|
|
p->tok_buf[p->tok_end] = '\0'; // TODO: what if buffer is full?
|
|
p->tok_end = 0; // Reset for next atom
|
|
{
|
|
make_utf8_string(data, str, p->tok_buf);
|
|
return_thread_runnable_with_obj(data, &str, p);
|
|
}
|
|
} else if (c == '\\') {
|
|
escaped = 1;
|
|
} else if (c == '\n') {
|
|
p->line_num++;
|
|
p->col_num = 1;
|
|
_read_add_to_tok_buf(p, c);
|
|
} else {
|
|
_read_add_to_tok_buf(p, c);
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read a literal identifier
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
*/
|
|
static void _read_literal_identifier(void *data, port_type *p)
|
|
{
|
|
char c;
|
|
int escaped = 0;
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
_read_error(data, p, "EOF encountered parsing literal identifier");
|
|
}
|
|
}
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
|
|
if (escaped) {
|
|
escaped = 0;
|
|
switch (c) {
|
|
case '"':
|
|
case '\'':
|
|
case '?':
|
|
case '|':
|
|
case '\\':
|
|
_read_add_to_tok_buf(p, c);
|
|
break;
|
|
case 'a':
|
|
_read_add_to_tok_buf(p, '\a');
|
|
break;
|
|
case 'b':
|
|
_read_add_to_tok_buf(p, '\b');
|
|
break;
|
|
case 'n':
|
|
_read_add_to_tok_buf(p, '\n');
|
|
break;
|
|
case 'r':
|
|
_read_add_to_tok_buf(p, '\r');
|
|
break;
|
|
case 't':
|
|
_read_add_to_tok_buf(p, '\t');
|
|
break;
|
|
case 'x': {
|
|
char buf[32];
|
|
int i = 0;
|
|
while (i < 31){
|
|
if (p->mem_buf_len == 0 || p->mem_buf_len == p->buf_idx) {
|
|
int rv = read_from_port(p);
|
|
if (!rv) {
|
|
break;
|
|
}
|
|
}
|
|
if (p->mem_buf[p->buf_idx] == ';'){
|
|
p->buf_idx++;
|
|
break;
|
|
}
|
|
// Verify if hex digit is valid
|
|
if (!isdigit(p->mem_buf[p->buf_idx]) &&
|
|
!_read_is_hex_digit(p->mem_buf[p->buf_idx])) {
|
|
p->buf_idx++;
|
|
_read_error(data, p, "invalid hex digit in literal identifier");
|
|
}
|
|
buf[i] = p->mem_buf[p->buf_idx];
|
|
p->buf_idx++;
|
|
p->col_num++;
|
|
i++;
|
|
}
|
|
buf[i] = '\0';
|
|
{
|
|
char_type result = strtol(buf, NULL, 16);
|
|
char cbuf[5];
|
|
int i;
|
|
Cyc_utf8_encode_char(cbuf, 5, result);
|
|
for (i = 0; cbuf[i] != 0; i++) {
|
|
_read_add_to_tok_buf(p, cbuf[i]);
|
|
}
|
|
//p->tok_buf[p->tok_end++] = (char)result;
|
|
}
|
|
break;
|
|
}
|
|
default:
|
|
_read_error(data, p, "invalid escape character in literal identifier"); // TODO: char
|
|
break;
|
|
}
|
|
} else if (c == '|') {
|
|
p->tok_buf[p->tok_end] = '\0'; // TODO: what if buffer is full?
|
|
p->tok_end = 0; // Reset for next atom
|
|
{
|
|
object sym = find_or_add_symbol(p->tok_buf);
|
|
return_thread_runnable_with_obj(data, sym, p);
|
|
}
|
|
} else if (c == '\\') {
|
|
escaped = 1;
|
|
} else if (c == '\n') {
|
|
p->line_num++;
|
|
p->col_num = 1;
|
|
_read_add_to_tok_buf(p, c);
|
|
} else {
|
|
_read_add_to_tok_buf(p, c);
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read a character token
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
*/
|
|
static void _read_return_character(void *data, port_type *p)
|
|
{
|
|
p->tok_buf[p->tok_end] = '\0'; // TODO: what if buffer is full?
|
|
p->tok_end = 0; // Reset for next atom
|
|
if (strlen(p->tok_buf) == 1) {
|
|
// ASCII char, consider merging with below?
|
|
return_thread_runnable_with_obj(data, obj_char2obj(p->tok_buf[0]), p);
|
|
} else if(strncmp(p->tok_buf, "alarm", 5) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj('\a'), p);
|
|
} else if(strncmp(p->tok_buf, "backspace", 9) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj('\b'), p);
|
|
} else if(strncmp(p->tok_buf, "delete", 6) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj(127), p);
|
|
} else if(strncmp(p->tok_buf, "escape", 6) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj(27), p);
|
|
} else if(strncmp(p->tok_buf, "newline", 7) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj('\n'), p);
|
|
} else if(strncmp(p->tok_buf, "null", 4) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj('\0'), p);
|
|
} else if(strncmp(p->tok_buf, "return", 6) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj('\r'), p);
|
|
} else if(strncmp(p->tok_buf, "space", 5) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj(' '), p);
|
|
} else if(strncmp(p->tok_buf, "tab", 3) == 0) {
|
|
return_thread_runnable_with_obj(data, obj_char2obj('\t'), p);
|
|
} else if(strlen(p->tok_buf) > 1 && p->tok_buf[0] == 'x') {
|
|
const char *buf = p->tok_buf + 1;
|
|
char_type result = strtol(buf, NULL, 16);
|
|
return_thread_runnable_with_obj(data, obj_char2obj(result), p);
|
|
} else {
|
|
// Try to read a UTF-8 char and if so return it, otherwise throw an error
|
|
uint32_t state = CYC_UTF8_ACCEPT;
|
|
char_type codepoint;
|
|
uint8_t *s = (uint8_t *)p->tok_buf;
|
|
while(s) {
|
|
if (!Cyc_utf8_decode(&state, &codepoint, *s)) {
|
|
s++;
|
|
break;
|
|
}
|
|
s++;
|
|
}
|
|
if (state == CYC_UTF8_ACCEPT && *s == '\0') {
|
|
return_thread_runnable_with_obj(data, obj_char2obj(codepoint), p);
|
|
} else {
|
|
char buf[31];
|
|
snprintf(buf, 30, "Unable to parse character %s", p->tok_buf);
|
|
_read_error(data, p, buf);
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function to read a character token
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
*/
|
|
static void _read_character(void *data, port_type *p)
|
|
{
|
|
char c;
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
_read_return_character(data, p);
|
|
}
|
|
}
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
|
|
if (p->tok_end && (isspace(c) || c == ')')) {
|
|
p->buf_idx--;
|
|
p->col_num--;
|
|
_read_return_character(data, p);
|
|
} else {
|
|
_read_add_to_tok_buf(p, c);
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function, return read number.
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
* @param base Number base
|
|
* @param exact Return an exact number if true
|
|
*/
|
|
static void _read_return_number(void *data, port_type *p, int base, int exact)
|
|
{
|
|
// TODO: validation?
|
|
p->tok_buf[p->tok_end] = '\0'; // TODO: what if buffer is full?
|
|
p->tok_end = 0; // Reset for next atom
|
|
make_empty_vector(vec);
|
|
make_string(str, p->tok_buf);
|
|
vec.num_elements = 3;
|
|
vec.elements = (object *) alloca(sizeof(object) * vec.num_elements);
|
|
vec.elements[0] = &str;
|
|
vec.elements[1] = obj_int2obj(base);
|
|
vec.elements[2] = exact ? boolean_t : boolean_f;
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function, parse&return read complex number.
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
* @param base Number base
|
|
* @param exact Return an exact number if true
|
|
*/
|
|
static void _read_return_complex_number(void *data, port_type *p, int len)
|
|
{
|
|
// TODO: return complex num, see _read_return_number for possible template
|
|
// probably want to have that function extract/identify the real/imaginary components.
|
|
// can just scan the buffer and read out start/end index of each number.
|
|
int i;
|
|
make_empty_vector(vec);
|
|
make_string(str, p->tok_buf);
|
|
vec.num_elements = 2;
|
|
vec.elements = (object *) alloca(sizeof(object) * vec.num_elements);
|
|
vec.elements[0] = &str;
|
|
i = 0;
|
|
if (p->tok_buf[0] == '-' || p->tok_buf[0] == '+') {
|
|
i++;
|
|
}
|
|
for (; i < len; i++) {
|
|
if (!isdigit(p->tok_buf[i]) && p->tok_buf[i] != '.' && p->tok_buf[i] != 'e' && p->tok_buf[i] != 'E') {
|
|
break;
|
|
}
|
|
}
|
|
vec.elements[1] = obj_int2obj(i);
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function, read number.
|
|
* @param data Thread data object
|
|
* @param p Input port
|
|
* @param base Number base
|
|
* @param exact Return an exact number if true
|
|
*/
|
|
static void _read_number(void *data, port_type *p, int base, int exact)
|
|
{
|
|
char c;
|
|
while(1) {
|
|
// Read more data into buffer, if needed
|
|
if (p->buf_idx == p->mem_buf_len) {
|
|
if (!read_from_port(p)){
|
|
_read_return_number(data, p, base, exact);
|
|
}
|
|
}
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
|
|
if (isdigit(c)) {
|
|
if ((base == 2 && c > '1') ||
|
|
(base == 8 && c > '7')) {
|
|
_read_error(data, p, "Illegal digit");
|
|
}
|
|
_read_add_to_tok_buf(p, c);
|
|
} else if (c == '+' || c == '-' || c == '.') {
|
|
_read_add_to_tok_buf(p, c);
|
|
} else if (base == 16 && _read_is_hex_digit(c)) {
|
|
_read_add_to_tok_buf(p, c);
|
|
} else {
|
|
p->buf_idx--;
|
|
p->col_num--;
|
|
_read_return_number(data, p, base, exact);
|
|
}
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper function, return read atom.
|
|
* @param data Thread data object
|
|
* @param cont Current continuation
|
|
* @param p Input port
|
|
*/
|
|
static void _read_return_atom(void *data, object cont, port_type *p)
|
|
{
|
|
object sym;
|
|
int len = p->tok_end;
|
|
|
|
// Back up a char, since we always get here after reaching a terminal char
|
|
// indicating we have the full atom
|
|
p->buf_idx--;
|
|
p->col_num--;
|
|
p->tok_buf[p->tok_end] = '\0'; // TODO: what if buffer is full?
|
|
p->tok_end = 0; // Reset for next atom
|
|
|
|
if (_read_is_numeric(p->tok_buf, len)) {
|
|
make_string(str, p->tok_buf);
|
|
str.num_cp = Cyc_utf8_count_code_points((uint8_t *)(p->tok_buf));
|
|
make_c_opaque(opq, &str);
|
|
if (_read_is_complex_number(p->tok_buf, len)) {
|
|
_read_return_complex_number(data, p, len);
|
|
} else {
|
|
return_thread_runnable_with_obj(data, &opq, p);
|
|
}
|
|
} else if (strncmp("+inf.0", p->tok_buf, 6) == 0 ||
|
|
strncmp("-inf.0", p->tok_buf, 6) == 0) {
|
|
make_double(d, pow(2.0, 1000000));
|
|
return_thread_runnable_with_obj(data, &d, p);
|
|
} else if (strncmp("+nan.0", p->tok_buf, 6) == 0 ||
|
|
strncmp("-nan.0", p->tok_buf, 6) == 0) {
|
|
make_double(d, 0.0 / 0.0);
|
|
return_thread_runnable_with_obj(data, &d, p);
|
|
} else {
|
|
sym = find_or_add_symbol(p->tok_buf);
|
|
return_thread_runnable_with_obj(data, sym, p);
|
|
}
|
|
}
|
|
|
|
/**
|
|
* @brief Helper macro for Cyc_io_read_token
|
|
*/
|
|
#define _read_next_char(data, cont, p) \
|
|
if (p->mem_buf_len == 0 || p->mem_buf_len == p->buf_idx) { \
|
|
int rv = read_from_port(p); \
|
|
if (!rv) { \
|
|
if (p->tok_end) _read_return_atom(data, cont, p); \
|
|
return_thread_runnable_with_obj(data, Cyc_EOF, p); \
|
|
} \
|
|
}
|
|
|
|
object Cyc_io_peek_char(void *data, object cont, object port)
|
|
{
|
|
FILE *stream;
|
|
port_type *p;
|
|
uint32_t state = CYC_UTF8_ACCEPT;
|
|
char_type codepoint;
|
|
int c, i = 0, at_mem_buf_end = 0;
|
|
char buf[5];
|
|
|
|
Cyc_check_port(data, port);
|
|
{
|
|
p = (port_type *)port;
|
|
stream = ((port_type *) port)->fp;
|
|
if (stream == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to read from closed port: ", port);
|
|
}
|
|
set_thread_blocked(data, cont);
|
|
if (p->mem_buf_len == 0 || p->mem_buf_len == p->buf_idx) {
|
|
_read_next_char(data, cont, p);
|
|
}
|
|
c = p->mem_buf[p->buf_idx];
|
|
if (Cyc_utf8_decode(&state, &codepoint, (uint8_t)c)) {
|
|
// Only have a partial UTF8 code point, read more chars.
|
|
// Problem is that there may not be enough space to store them
|
|
// and do need to set them aside since we are just peeking here
|
|
// and not actually supposed to be reading past chars.
|
|
|
|
buf[0] = c;
|
|
i = 1;
|
|
while (i < 5) { // TODO: limit to 4 chars??
|
|
if (p->mem_buf_len == p->buf_idx + i) {
|
|
// No more buffered chars
|
|
at_mem_buf_end = 1;
|
|
c = fgetc(stream);
|
|
if (c == EOF) break; // TODO: correct to do this here????
|
|
} else {
|
|
c = p->mem_buf[p->buf_idx + i];
|
|
}
|
|
buf[i++] = c;
|
|
if (!Cyc_utf8_decode(&state, &codepoint, (uint8_t)c)) {
|
|
break;
|
|
}
|
|
}
|
|
}
|
|
if (at_mem_buf_end && c != EOF) {
|
|
p->buf_idx = 0;
|
|
p->mem_buf_len = i;
|
|
memmove(p->mem_buf, buf, i);
|
|
}
|
|
|
|
return_thread_runnable_with_obj(data, (c != EOF) ? obj_char2obj(codepoint) : Cyc_EOF, p);
|
|
}
|
|
return Cyc_EOF;
|
|
}
|
|
|
|
object Cyc_io_peek_u8(void *data, object cont, object port)
|
|
{
|
|
FILE *stream;
|
|
port_type *p;
|
|
uint8_t c;
|
|
|
|
Cyc_check_port(data, port);
|
|
{
|
|
p = (port_type *)port;
|
|
stream = ((port_type *) port)->fp;
|
|
if (stream == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to read from closed port: ", port);
|
|
}
|
|
set_thread_blocked(data, cont);
|
|
if (p->mem_buf_len == 0 || p->mem_buf_len == p->buf_idx) {
|
|
_read_next_char(data, cont, p);
|
|
}
|
|
c = p->mem_buf[p->buf_idx];
|
|
return_thread_runnable_with_obj(data, (c != EOF) ? obj_int2obj(c) : Cyc_EOF, p);
|
|
}
|
|
return Cyc_EOF;
|
|
}
|
|
|
|
// TODO: full requirements are:
|
|
//
|
|
// Returns #t if a character is ready on the textual input
|
|
// port and returns #f otherwise. If char-ready returns #t
|
|
// then the next read-char operation on the given port is
|
|
// guaranteed not to hang. If the port is at end of file then
|
|
// char-ready? returns #t.
|
|
//
|
|
// This is a bit of a challenge because the internal buffers
|
|
// cannot differentiate between being empty and being at EOF.
|
|
//
|
|
//object Cyc_io_char_ready(void *data, object cont, object port)
|
|
//{
|
|
// port_type *p = (port_type *)port;
|
|
// Cyc_check_port(data, port);
|
|
//}
|
|
|
|
object Cyc_io_read_char(void *data, object cont, object port)
|
|
{
|
|
port_type *p = (port_type *)port;
|
|
Cyc_check_port(data, port);
|
|
if (p->fp == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to read from closed port: ", port);
|
|
}
|
|
{
|
|
uint32_t state = CYC_UTF8_ACCEPT;
|
|
char_type codepoint;
|
|
int c;
|
|
set_thread_blocked(data, cont);
|
|
do {
|
|
_read_next_char(data, cont, p);
|
|
c = p->mem_buf[p->buf_idx++];
|
|
if (c == EOF) break;
|
|
} while(Cyc_utf8_decode(&state, &codepoint, (uint8_t)c));
|
|
// TODO: limit above to 4 chars and then thrown an error?
|
|
p->col_num++;
|
|
return_thread_runnable_with_obj(data, (c != EOF) ? obj_char2obj(codepoint) : Cyc_EOF, p);
|
|
}
|
|
return Cyc_EOF;
|
|
}
|
|
|
|
object Cyc_io_read_u8(void *data, object cont, object port)
|
|
{
|
|
port_type *p = (port_type *)port;
|
|
Cyc_check_port(data, port);
|
|
if (p->fp == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to read from closed port: ", port);
|
|
}
|
|
{
|
|
uint8_t c;
|
|
set_thread_blocked(data, cont);
|
|
_read_next_char(data, cont, p);
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
return_thread_runnable_with_obj(data, (c != EOF) ? obj_int2obj(c) : Cyc_EOF, p);
|
|
}
|
|
return Cyc_EOF;
|
|
}
|
|
|
|
/* TODO: this function needs some work, but approximates what is needed */
|
|
object Cyc_io_read_line(void *data, object cont, object port)
|
|
{
|
|
FILE *stream = ((port_type *) port)->fp;
|
|
char buf[1027];
|
|
int len, num_cp, i = 0;
|
|
char_type codepoint;
|
|
uint32_t state;
|
|
|
|
Cyc_check_port(data, port);
|
|
if (stream == NULL) {
|
|
Cyc_rt_raise2(data, "Unable to read from closed port: ", port);
|
|
}
|
|
set_thread_blocked(data, cont);
|
|
errno = 0;
|
|
if (fgets(buf, 1023, stream) != NULL) {
|
|
state = Cyc_utf8_count_code_points_and_bytes((uint8_t *)buf, &codepoint, &num_cp, &len);
|
|
// Check if we stopped reading in the middle of a code point and
|
|
// if so, read one byte at a time until that code point is finished.
|
|
while (state != CYC_UTF8_ACCEPT && i < 3) {
|
|
int c = fgetc(stream);
|
|
buf[len] = c;
|
|
len++;
|
|
Cyc_utf8_decode(&state, &codepoint, (uint8_t)c);
|
|
if (state == CYC_UTF8_ACCEPT) {
|
|
num_cp++;
|
|
break;
|
|
}
|
|
i++;
|
|
}
|
|
|
|
{
|
|
// Remove any trailing CR / newline chars
|
|
while (len > 0 && (buf[len - 1] == '\n' ||
|
|
buf[len - 1] == '\r')) {
|
|
len--;
|
|
num_cp--;
|
|
}
|
|
buf[len] = '\0';
|
|
make_string_noalloc(s, buf, len);
|
|
s.num_cp = num_cp;
|
|
return_thread_runnable_with_obj(data, &s, port);
|
|
}
|
|
} else {
|
|
if (feof(stream)) {
|
|
return_thread_runnable_with_obj(data, Cyc_EOF, port);
|
|
} else {
|
|
// TODO: can't do this because we said thread could be blocked
|
|
//Cyc_rt_raise2(data, "Error reading from file: ", obj_int2obj(errno));
|
|
return_thread_runnable_with_obj(data, Cyc_EOF, port);
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
/**
|
|
* @brief Read next token from the input port.
|
|
* @param data Thread data object
|
|
* @param cont Current continuation
|
|
* @param port Input port
|
|
*/
|
|
void Cyc_io_read_token(void *data, object cont, object port)
|
|
{
|
|
Cyc_check_port(data, port);
|
|
port_type *p = (port_type *)port;
|
|
char c;
|
|
|
|
// Find and return (to cont, so want to minimize stack growth if possible) next token from buf
|
|
set_thread_blocked(data, cont);
|
|
while (1) {
|
|
// Do an I/O read for more data if buffer is full/empty
|
|
_read_next_char(data, cont, p);
|
|
|
|
// Process input one char at a time
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
|
|
// If comment found, eat up comment chars
|
|
if (c == ';') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
_read_line_comment(p);
|
|
} else if (c == '\n') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
p->line_num++;
|
|
p->col_num = 1;
|
|
} else if (isspace(c)) {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
_read_whitespace(p);
|
|
} else if (c == '(' || c == ')' || c == '\'' || c == '`') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
// Special encoding so we can distinguish from chars such as #\(
|
|
make_c_opaque(opq, obj_char2obj(c));
|
|
return_thread_runnable_with_obj(data, &opq, p);
|
|
} else if (c == ',') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
|
|
_read_next_char(data, cont, p); // Do another buffer read if needed
|
|
if (p->mem_buf[p->buf_idx] == '@') {
|
|
object unquote_splicing = find_or_add_symbol(",@");
|
|
make_empty_vector(vec);
|
|
vec.num_elements = 2;
|
|
vec.elements = (object *) alloca(sizeof(object) * vec.num_elements);
|
|
vec.elements[0] = unquote_splicing;
|
|
vec.elements[1] = boolean_f;
|
|
p->buf_idx++;
|
|
p->col_num++;
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
} else {
|
|
// Again, special encoding for syntax
|
|
make_c_opaque(opq, obj_char2obj(c));
|
|
return_thread_runnable_with_obj(data, &opq, p);
|
|
}
|
|
} else if (c == '"') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
_read_string(data, cont, p);
|
|
} else if (c == '#' && !p->tok_end) {
|
|
_read_next_char(data, cont, p); // Fill buffer
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
if (c == 't') {
|
|
if ((p->mem_buf_len - p->buf_idx) >= 3 &&
|
|
p->mem_buf[p->buf_idx + 0] == 'r' &&
|
|
p->mem_buf[p->buf_idx + 1] == 'u' &&
|
|
p->mem_buf[p->buf_idx + 2] == 'e') {
|
|
p->buf_idx += 3;
|
|
p->col_num += 3;
|
|
}
|
|
return_thread_runnable_with_obj(data, boolean_t, p);
|
|
} else if (c == 'f') {
|
|
if ((p->mem_buf_len - p->buf_idx) >= 4 &&
|
|
p->mem_buf[p->buf_idx + 0] == 'a' &&
|
|
p->mem_buf[p->buf_idx + 1] == 'l' &&
|
|
p->mem_buf[p->buf_idx + 2] == 's' &&
|
|
p->mem_buf[p->buf_idx + 3] == 'e') {
|
|
p->buf_idx += 4;
|
|
p->col_num += 4;
|
|
}
|
|
return_thread_runnable_with_obj(data, boolean_f, p);
|
|
} else if (c == '\\') {
|
|
_read_character(data, p);
|
|
} else if (c == 'e') {
|
|
_read_number(data, p, 10, 1);
|
|
} else if (c == 'i') {
|
|
_read_number(data, p, 10, 0);
|
|
} else if (c == 'b') {
|
|
_read_number(data, p, 2, 1);
|
|
} else if (c == 'o') {
|
|
_read_number(data, p, 8, 1);
|
|
} else if (c == 'x') {
|
|
_read_number(data, p, 16, 1);
|
|
} else if (c == '(') { // Vector
|
|
make_empty_vector(vec);
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
} else if (c == 'u') { // Bytevector
|
|
_read_next_char(data, cont, p); // Fill buffer
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
if (c == '8') {
|
|
_read_next_char(data, cont, p); // Fill buffer
|
|
c = p->mem_buf[p->buf_idx++];
|
|
p->col_num++;
|
|
if (c == '(') {
|
|
make_empty_bytevector(vec);
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
} else {
|
|
_read_error(data, p, "Unhandled input sequence");
|
|
}
|
|
} else {
|
|
_read_error(data, p, "Unhandled input sequence");
|
|
}
|
|
} else if (c == '|') { // Block comment
|
|
_read_multiline_comment(p);
|
|
continue;
|
|
} else if (c == ';') { // Datum comment
|
|
object sym = find_or_add_symbol("#;");
|
|
make_empty_vector(vec);
|
|
vec.num_elements = 2;
|
|
vec.elements = (object *) alloca(sizeof(object) * vec.num_elements);
|
|
vec.elements[0] = sym;
|
|
vec.elements[1] = boolean_f;
|
|
return_thread_runnable_with_obj(data, &vec, p);
|
|
} else {
|
|
char buf[31];
|
|
snprintf(buf, 30, "Unhandled input sequence %c", c);
|
|
_read_error(data, p, buf);
|
|
}
|
|
} else if (c == '|' && !p->tok_end) {
|
|
_read_literal_identifier(data, p);
|
|
} else if (c == '[' || c == '{') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
// Special encoding so we can distinguish from chars such as #\(
|
|
make_c_opaque(opq, obj_char2obj('(')); // Cheap support for brackets
|
|
return_thread_runnable_with_obj(data, &opq, p);
|
|
} else if (c == ']' || c == '}') {
|
|
if (p->tok_end) _read_return_atom(data, cont, p);
|
|
// Special encoding so we can distinguish from chars such as #\(
|
|
make_c_opaque(opq, obj_char2obj(')')); // Cheap support for brackets
|
|
return_thread_runnable_with_obj(data, &opq, p);
|
|
} else {
|
|
// No special meaning, add char to current token (an atom)
|
|
_read_add_to_tok_buf(p, c);
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
////////////// UTF-8 Section //////////////
|
|
|
|
// Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
|
|
// See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
|
|
static const uint8_t utf8d[] = {
|
|
// The first part of the table maps bytes to character classes that
|
|
// to reduce the size of the transition table and create bitmasks.
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
|
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
|
|
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
|
|
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
|
|
8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
|
|
10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
|
|
|
|
// The second part is a transition table that maps a combination
|
|
// of a state of the automaton and a character class to a state.
|
|
0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
|
|
12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
|
|
12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
|
|
12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
|
|
12,36,12,12,12,12,12,12,12,12,12,12,
|
|
};
|
|
|
|
/**
|
|
* @brief Decode the next byte of a codepoint.
|
|
* Based on example code from Bjoern Hoehrmann.
|
|
* @param state Out parameter, the state of the decoding
|
|
* @param codep Out parameter, contains the codepoint
|
|
* @param byte Byte to examine
|
|
* @return The current state: `CYC_UTF8_ACCEPT` if successful otherwise `CYC_UTF8_REJECT`.
|
|
*/
|
|
static uint32_t Cyc_utf8_decode(uint32_t* state, uint32_t* codep, uint32_t byte) {
|
|
uint32_t type = utf8d[byte];
|
|
|
|
*codep = (*state != CYC_UTF8_ACCEPT) ?
|
|
(byte & 0x3fu) | (*codep << 6) :
|
|
(0xff >> type) & (byte);
|
|
|
|
*state = utf8d[256 + *state + type];
|
|
return *state;
|
|
}
|
|
// END Bjoern Hoehrmann
|
|
|
|
/**
|
|
* @brief Count the number of code points in a string.
|
|
* Based on example code from Bjoern Hoehrmann.
|
|
* @param s String to examine
|
|
* @return The number of codepoints found, or -1 if there was an error.
|
|
*/
|
|
int Cyc_utf8_count_code_points(uint8_t* s) {
|
|
uint32_t codepoint;
|
|
uint32_t state = 0;
|
|
int count;
|
|
|
|
for (count = 0; *s; ++s)
|
|
if (!Cyc_utf8_decode(&state, &codepoint, *s))
|
|
count += 1;
|
|
|
|
if (state != CYC_UTF8_ACCEPT)
|
|
return -1;
|
|
return count;
|
|
}
|
|
|
|
/**
|
|
* @brief Count the number of code points and bytes in a string.
|
|
* @param s String to examine
|
|
* @param codepoint Out parameter, set to the codepoint.
|
|
* @param cpts Out parameter, set to the number of code points
|
|
* @param bytes Out parameter, set to the number of bytes
|
|
* @return Returns `CYC_UTF8_ACCEPT` on success, otherwise `CYC_UTF8_REJECT`.
|
|
*/
|
|
static int Cyc_utf8_count_code_points_and_bytes(uint8_t* s, char_type *codepoint, int *cpts, int *bytes) {
|
|
uint32_t state = 0;
|
|
*cpts = 0;
|
|
*bytes = 0;
|
|
for (; *s; ++s){
|
|
*bytes += 1;
|
|
if (!Cyc_utf8_decode(&state, codepoint, *s))
|
|
*cpts += 1;
|
|
}
|
|
|
|
if (state != CYC_UTF8_ACCEPT)
|
|
return state;
|
|
return 0;
|
|
}
|
|
|
|
// TODO: index into X codepoint in a string
|
|
|
|
/**
|
|
* @brief
|
|
* Use this when validating from a stream, as it may be that the stream stopped
|
|
* in the middle of a codepoint, hence state passed in as an arg, so it can be
|
|
* tested in a loop and also after the loop has finished.
|
|
*
|
|
* From https://stackoverflow.com/a/22135005/101258
|
|
*/
|
|
uint32_t Cyc_utf8_validate_stream(uint32_t *state, char *str, size_t len) {
|
|
size_t i;
|
|
uint32_t type;
|
|
|
|
for (i = 0; i < len; i++) {
|
|
// We don't care about the codepoint, so this is
|
|
// a simplified version of the decode function.
|
|
type = utf8d[(uint8_t)str[i]];
|
|
*state = utf8d[256 + (*state) + type];
|
|
|
|
if (*state == CYC_UTF8_REJECT)
|
|
break;
|
|
}
|
|
|
|
return *state;
|
|
}
|
|
|
|
/**
|
|
* @brief Simplified version of Cyc_utf8_validate_stream that must always be called with a complete string buffer.
|
|
*/
|
|
uint32_t Cyc_utf8_validate(char *str, size_t len) {
|
|
size_t i;
|
|
uint32_t state = CYC_UTF8_ACCEPT, type;
|
|
|
|
for (i = 0; i < len; i++) {
|
|
// We don't care about the codepoint, so this is
|
|
// a simplified version of the decode function.
|
|
type = utf8d[(uint8_t)str[i]];
|
|
state = utf8d[256 + (state) + type];
|
|
|
|
if (state == CYC_UTF8_REJECT)
|
|
break;
|
|
}
|
|
|
|
return state;
|
|
}
|
|
|
|
//int uint32_num_bytes(uint32_t x) {
|
|
// // TODO: could compute log(val) / log(256)
|
|
// if (x < 0x100) return 1;
|
|
// if (x < 0x10000) return 2;
|
|
// if (x < 0x1000000) return 3;
|
|
// return 4;
|
|
//}
|
|
|
|
/**
|
|
* This function takes one or more 32-bit chars and encodes them
|
|
* as an array of UTF-8 bytes.
|
|
* FROM: https://www.cprogramming.com/tutorial/utf8.c
|
|
*
|
|
* @param dest Destination byte buffer
|
|
* @param sz size of dest buffer in bytes
|
|
* @param src Buffer of source data, in 32-bit characters
|
|
* @param srcsz number of source characters, or -1 if 0-terminated
|
|
*
|
|
* @return Number of characters converted
|
|
*
|
|
* dest will only be '\0'-terminated if there is enough space. this is
|
|
* for consistency; imagine there are 2 bytes of space left, but the next
|
|
* character requires 3 bytes. in this case we could NUL-terminate, but in
|
|
* general we can't when there's insufficient space. therefore this function
|
|
* only NUL-terminates if all the characters fit, and there's space for
|
|
* the NUL as well.
|
|
* the destination string will never be bigger than the source string.
|
|
*/
|
|
int Cyc_utf8_encode(char *dest, int sz, uint32_t *src, int srcsz)
|
|
{
|
|
u_int32_t ch;
|
|
int i = 0;
|
|
char *dest_end = dest + sz;
|
|
|
|
while (srcsz<0 ? src[i]!=0 : i < srcsz) {
|
|
ch = src[i];
|
|
if (ch < 0x80) {
|
|
if (dest >= dest_end)
|
|
return i;
|
|
*dest++ = (char)ch;
|
|
}
|
|
else if (ch < 0x800) {
|
|
if (dest >= dest_end-1)
|
|
return i;
|
|
*dest++ = (ch>>6) | 0xC0;
|
|
*dest++ = (ch & 0x3F) | 0x80;
|
|
}
|
|
else if (ch < 0x10000) {
|
|
if (dest >= dest_end-2)
|
|
return i;
|
|
*dest++ = (ch>>12) | 0xE0;
|
|
*dest++ = ((ch>>6) & 0x3F) | 0x80;
|
|
*dest++ = (ch & 0x3F) | 0x80;
|
|
}
|
|
else if (ch < 0x110000) {
|
|
if (dest >= dest_end-3)
|
|
return i;
|
|
*dest++ = (ch>>18) | 0xF0;
|
|
*dest++ = ((ch>>12) & 0x3F) | 0x80;
|
|
*dest++ = ((ch>>6) & 0x3F) | 0x80;
|
|
*dest++ = (ch & 0x3F) | 0x80;
|
|
}
|
|
i++;
|
|
}
|
|
if (dest < dest_end)
|
|
*dest = '\0';
|
|
return i;
|
|
}
|
|
|
|
|
|
////////////// END UTF-8 Section //////////////
|