mirror of
https://github.com/justinethier/cyclone.git
synced 2025-05-19 05:39:17 +02:00
2341 lines
85 KiB
C
2341 lines
85 KiB
C
/**
|
|
* Cyclone Scheme
|
|
* Copyright (c) 2014, Justin Ethier
|
|
* All rights reserved.
|
|
*
|
|
* This file contains the C runtime used by compiled programs.
|
|
*/
|
|
|
|
#include "cyclone/types.h"
|
|
#include "cyclone/runtime.h"
|
|
|
|
/* TODO: working on validation for applying functions */
|
|
#define Cyc_check_num_args(fnc_name, num_args, args) { \
|
|
integer_type l = Cyc_length(args); \
|
|
if (num_args > l.value) { \
|
|
char buf[128]; \
|
|
snprintf(buf, 127, "Expected %d arguments but received %d.", num_args, l.value); \
|
|
Cyc_rt_raise_msg(buf); \
|
|
} \
|
|
}
|
|
|
|
/* Funcall section, these are hardcoded here to support
|
|
functions in this module. */
|
|
#define funcall1(cfn,a1) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(0, (closure)a1, cfn); } else { ((cfn)->fn)(1,cfn,a1);}
|
|
/* Return to continuation after checking for stack overflow. */
|
|
#define return_funcall1(cfn,a1) \
|
|
{char stack; \
|
|
if (check_overflow(&stack,stack_limit1)) { \
|
|
object buf[1]; buf[0] = a1;\
|
|
GC(cfn,buf,1); return; \
|
|
} else {funcall1((closure) (cfn),a1); return;}}
|
|
#define funcall2(cfn,a1,a2) if (type_of(cfn) == cons_tag || prim(cfn)) { Cyc_apply(1, (closure)a1, cfn,a2); } else { ((cfn)->fn)(2,cfn,a1,a2);}
|
|
/* Return to continuation after checking for stack overflow. */
|
|
#define return_funcall2(cfn,a1,a2) \
|
|
{char stack; \
|
|
if (check_overflow(&stack,stack_limit1)) { \
|
|
object buf[2]; buf[0] = a1;buf[1] = a2;\
|
|
GC(cfn,buf,2); return; \
|
|
} else {funcall2((closure) (cfn),a1,a2); return;}}
|
|
/*END funcall section */
|
|
|
|
/* Global variables. */
|
|
clock_t start; /* Starting time. */
|
|
char *stack_begin; /* Initialized by main. */
|
|
char *stack_limit1; /* Initialized by main. */
|
|
char *stack_limit2;
|
|
char *bottom; /* Bottom of tospace. */
|
|
char *allocp; /* Cheney allocate pointer. */
|
|
char *alloc_end;
|
|
/* TODO: not sure this is the best strategy for strings, especially if there
|
|
are a lot of long, later gen strings because that will cause a lot of
|
|
copying to occur during GC */
|
|
char *dhbottom; /* Bottom of data heap */
|
|
char *dhallocp; /* Current place in data heap */
|
|
char *dhalloc_limit; /* GC beyond this limit */
|
|
char *dhalloc_end;
|
|
long no_gcs = 0; /* Count the number of GC's. */
|
|
long no_major_gcs = 0; /* Count the number of GC's. */
|
|
object gc_cont; /* GC continuation closure. */
|
|
object gc_ans[NUM_GC_ANS]; /* argument for GC continuation closure. */
|
|
int gc_num_ans;
|
|
jmp_buf jmp_main; /* Where to jump to. */
|
|
|
|
object Cyc_global_variables = nil;
|
|
int _cyc_argc = 0;
|
|
char **_cyc_argv = NULL;
|
|
|
|
static symbol_type __EOF = {eof_tag, "", nil}; // symbol_type in lieu of custom type
|
|
const object Cyc_EOF = &__EOF;
|
|
|
|
object cell_get(object cell){
|
|
return car(cell);
|
|
}
|
|
|
|
static boolean_type t_boolean = {boolean_tag, "t"};
|
|
static boolean_type f_boolean = {boolean_tag, "f"};
|
|
const object boolean_t = &t_boolean;
|
|
const object boolean_f = &f_boolean;
|
|
|
|
static symbol_type Cyc_void_symbol = {symbol_tag, "", nil};
|
|
const object quote_void = &Cyc_void_symbol;
|
|
|
|
/* Stack Traces */
|
|
static const int MAX_STACK_TRACES = 10;
|
|
static char **Cyc_Stack_Traces;
|
|
static int Cyc_Stack_Trace_Idx = 0;
|
|
|
|
void Cyc_st_init() {
|
|
Cyc_Stack_Traces = calloc(MAX_STACK_TRACES, sizeof(char *));
|
|
}
|
|
|
|
void Cyc_st_add(char *frame) {
|
|
// Do not allow recursion to remove older frames
|
|
if (frame != Cyc_Stack_Traces[(Cyc_Stack_Trace_Idx - 1) % MAX_STACK_TRACES]) {
|
|
Cyc_Stack_Traces[Cyc_Stack_Trace_Idx] = frame;
|
|
Cyc_Stack_Trace_Idx = (Cyc_Stack_Trace_Idx + 1) % MAX_STACK_TRACES;
|
|
}
|
|
}
|
|
|
|
void Cyc_st_print(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
|
|
*/
|
|
int i = (Cyc_Stack_Trace_Idx + 1) % MAX_STACK_TRACES;
|
|
while (i != Cyc_Stack_Trace_Idx) {
|
|
if (Cyc_Stack_Traces[i]) {
|
|
fprintf(out, "%s\n", Cyc_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
|
|
*/
|
|
list symbol_table = nil;
|
|
|
|
char *_strdup (const char *s) {
|
|
char *d = malloc (strlen (s) + 1);
|
|
if (d) { strcpy (d,s); }
|
|
return d;
|
|
}
|
|
|
|
object find_symbol_by_name(const char *name) {
|
|
list l = symbol_table;
|
|
for (; !nullp(l); l = cdr(l)) {
|
|
const char *str = symbol_pname(car(l));
|
|
if (strcmp(str, name) == 0) return car(l);
|
|
}
|
|
return nil;
|
|
}
|
|
|
|
object add_symbol(symbol_type *psym) {
|
|
symbol_table = mcons(psym, symbol_table);
|
|
return psym;
|
|
}
|
|
|
|
object add_symbol_by_name(const char *name) {
|
|
symbol_type sym = {symbol_tag, _strdup(name), nil};
|
|
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 */
|
|
|
|
/* Global table */
|
|
list global_table = nil;
|
|
|
|
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 = mcons(mcvar(glo), global_table);
|
|
}
|
|
/* END Global table */
|
|
|
|
/* Mutation table
|
|
*
|
|
* Keep track of mutations (EG: set-car!) so that new
|
|
* values are transported to the heap during GC.
|
|
*/
|
|
list mutation_table = nil;
|
|
|
|
void add_mutation(object var, object value){
|
|
if (is_object_type(value)) {
|
|
mutation_table = mcons(var, mutation_table);
|
|
}
|
|
}
|
|
|
|
/* TODO: consider a more efficient implementation, such as reusing old nodes
|
|
instead of reclaiming them each time
|
|
*/
|
|
void clear_mutations() {
|
|
list l = mutation_table, next;
|
|
while (!nullp(l)) {
|
|
next = cdr(l);
|
|
free(l);
|
|
l = next;
|
|
}
|
|
mutation_table = nil;
|
|
}
|
|
/* END mutation table */
|
|
|
|
/* Runtime globals */
|
|
object Cyc_glo_call_cc = nil;
|
|
object Cyc_glo_eval = nil;
|
|
|
|
/* Exception handler */
|
|
object Cyc_exception_handler_stack = nil;
|
|
|
|
object Cyc_default_exception_handler(int argc, closure _, object err) {
|
|
fprintf(stderr, "Error: ");
|
|
|
|
if (nullp(err) || is_value_type(err) || type_of(err) != cons_tag) {
|
|
Cyc_display(err, stderr);
|
|
} else {
|
|
// Error is list of form (type arg1 ... argn)
|
|
err = cdr(err); // skip type field
|
|
for (; !nullp(err); err = cdr(err)){ // output with no enclosing parens
|
|
Cyc_display(car(err), stderr);
|
|
fprintf(stderr, " ");
|
|
}
|
|
}
|
|
|
|
fprintf(stderr, "\nCall history:\n");
|
|
Cyc_st_print(stderr);
|
|
fprintf(stderr, "\n");
|
|
exit(1);
|
|
return nil;
|
|
}
|
|
|
|
object Cyc_current_exception_handler() {
|
|
if (nullp(Cyc_exception_handler_stack)) {
|
|
return primitive_Cyc_91default_91exception_91handler;
|
|
} else {
|
|
return car(Cyc_exception_handler_stack);
|
|
}
|
|
}
|
|
|
|
/* Raise an exception from the runtime code */
|
|
void Cyc_rt_raise(object err) {
|
|
make_cons(c2, err, nil);
|
|
make_cons(c1, boolean_f, &c2);
|
|
make_cons(c0, &c1, nil);
|
|
apply(nil, Cyc_current_exception_handler(), &c0);
|
|
// Should never get here
|
|
fprintf(stderr, "Internal error in Cyc_rt_raise\n");
|
|
exit(1);
|
|
}
|
|
void Cyc_rt_raise2(const char *msg, object err) {
|
|
make_string(s, msg);
|
|
make_cons(c3, err, nil);
|
|
make_cons(c2, &s, &c3);
|
|
make_cons(c1, boolean_f, &c2);
|
|
make_cons(c0, &c1, nil);
|
|
apply(nil, Cyc_current_exception_handler(), &c0);
|
|
// Should never get here
|
|
fprintf(stderr, "Internal error in Cyc_rt_raise2\n");
|
|
exit(1);
|
|
}
|
|
void Cyc_rt_raise_msg(const char *err) {
|
|
make_string(s, err);
|
|
Cyc_rt_raise(&s);
|
|
}
|
|
/* END exception handler */
|
|
|
|
int equal(x, y) object x, y;
|
|
{
|
|
if (nullp(x)) return nullp(y);
|
|
if (nullp(y)) return nullp(x);
|
|
if (obj_is_char(x)) return obj_is_char(y) && x == y;
|
|
switch(type_of(x)) {
|
|
case integer_tag:
|
|
return (type_of(y) == integer_tag &&
|
|
((integer_type *) x)->value == ((integer_type *) y)->value);
|
|
case double_tag:
|
|
return (type_of(y) == double_tag &&
|
|
((double_type *) x)->value == ((double_type *) y)->value);
|
|
case string_tag:
|
|
return (type_of(y) == string_tag &&
|
|
strcmp(((string_type *) x)->str,
|
|
((string_type *) y)->str) == 0);
|
|
case vector_tag:
|
|
if (type_of(y) == vector_tag &&
|
|
((vector)x)->num_elt == ((vector)y)->num_elt) {
|
|
int i;
|
|
for (i = 0; i < ((vector)x)->num_elt; i++) {
|
|
if (equalp(((vector)x)->elts[i], ((vector)y)->elts[i]) == boolean_f)
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
return 0;
|
|
default:
|
|
return x == y;
|
|
}
|
|
}
|
|
|
|
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_cycle(object lst) {
|
|
object slow_lst, fast_lst;
|
|
if (nullp(lst) || is_value_type(lst) ||
|
|
(is_object_type(lst) && type_of(lst) != cons_tag)) {
|
|
return (boolean_f);
|
|
}
|
|
slow_lst = lst;
|
|
fast_lst = cdr(lst);
|
|
while(1) {
|
|
if (nullp(fast_lst)) return boolean_f;
|
|
if (Cyc_is_cons(fast_lst) == boolean_f) return boolean_f;
|
|
if (nullp(cdr(fast_lst))) return boolean_f;
|
|
if (Cyc_is_cons(cdr(fast_lst)) == boolean_f) return boolean_f;
|
|
if (is_object_type(car(slow_lst)) &&
|
|
boolean_f == Cyc_is_boolean(car(slow_lst)) && // Avoid expected dupes
|
|
//boolean_f == Cyc_is_symbol(car(slow_lst)) && //
|
|
eq(car(slow_lst), car(fast_lst))) return boolean_t;
|
|
|
|
slow_lst = cdr(slow_lst);
|
|
fast_lst = cddr(fast_lst);
|
|
}
|
|
}
|
|
|
|
// 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
|
|
//
|
|
object dispatch_display_va(int argc, object clo, object cont, object x, ...) {
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_display_va_list(argc - 1, x, ap);
|
|
va_end(ap);
|
|
return_funcall1(cont, result);
|
|
}
|
|
|
|
object Cyc_display_va(int argc, object x, ...) {
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_display_va_list(argc, x, ap);
|
|
va_end(ap);
|
|
return result;
|
|
}
|
|
|
|
object Cyc_display_va_list(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);
|
|
fp = ((port_type *)tmp)->fp;
|
|
}
|
|
return Cyc_display(x, fp);}
|
|
|
|
object Cyc_display(object x, FILE *port)
|
|
{object tmp = nil;
|
|
object has_cycle = boolean_f;
|
|
int i = 0;
|
|
if (nullp(x)) {fprintf(port, "()"); return quote_void;}
|
|
if (obj_is_char(x)) {fprintf(port, "%c", obj_obj2char(x)); return quote_void;}
|
|
switch (type_of(x))
|
|
{case closure0_tag:
|
|
case closure1_tag:
|
|
case closure2_tag:
|
|
case closure3_tag:
|
|
case closure4_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:
|
|
Cyc_display(Cyc_get_cvar(x), port);
|
|
break;
|
|
case boolean_tag:
|
|
fprintf(port, "#%s",((boolean_type *) x)->pname);
|
|
break;
|
|
case symbol_tag:
|
|
fprintf(port, "%s",((symbol_type *) x)->pname);
|
|
break;
|
|
case integer_tag:
|
|
fprintf(port, "%d", ((integer_type *) x)->value);
|
|
break;
|
|
case double_tag:
|
|
fprintf(port, "%lf", ((double_type *) x)->value);
|
|
break;
|
|
case string_tag:
|
|
fprintf(port, "%s", ((string_type *) x)->str);
|
|
break;
|
|
case vector_tag:
|
|
fprintf(port, "#(");
|
|
for (i = 0; i < ((vector) x)->num_elt; i++) {
|
|
if (i > 0) {
|
|
fprintf(port, " ");
|
|
}
|
|
Cyc_display(((vector)x)->elts[i], port);
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
case cons_tag:
|
|
has_cycle = Cyc_has_cycle(x);
|
|
fprintf(port, "(");
|
|
Cyc_display(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))->pname, "procedure", 10) == 0) {
|
|
fprintf(port, " ");
|
|
Cyc_display(cadr(x), port);
|
|
fprintf(port, " ...)"); /* skip body and env for now */
|
|
break;
|
|
}
|
|
|
|
for (tmp = cdr(x); tmp && ((closure) tmp)->tag == cons_tag; tmp = cdr(tmp)) {
|
|
if (has_cycle == boolean_t) {
|
|
if (i++ > 20) break; /* arbitrary number, for now */
|
|
}
|
|
fprintf(port, " ");
|
|
Cyc_display(car(tmp), port);
|
|
}
|
|
if (has_cycle == boolean_t) {
|
|
fprintf(port, " ...");
|
|
} else if (tmp) {
|
|
fprintf(port, " . ");
|
|
Cyc_display(tmp, port);
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
default:
|
|
fprintf(port, "Cyc_display: bad tag x=%ld\n", ((closure)x)->tag); getchar(); exit(0);}
|
|
return quote_void;}
|
|
|
|
object dispatch_write_va(int argc, object clo, object cont, object x, ...) {
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_write_va_list(argc - 1, x, ap);
|
|
va_end(ap);
|
|
return_funcall1(cont, result);
|
|
}
|
|
|
|
object Cyc_write_va(int argc, object x, ...) {
|
|
object result;
|
|
va_list ap;
|
|
va_start(ap, x);
|
|
result = Cyc_write_va_list(argc, x, ap);
|
|
va_end(ap);
|
|
return result;
|
|
}
|
|
|
|
object Cyc_write_va_list(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);
|
|
fp = ((port_type *)tmp)->fp;
|
|
}
|
|
return Cyc_write(x, fp);}
|
|
|
|
static object _Cyc_write(object x, FILE *port)
|
|
{object tmp = nil;
|
|
object has_cycle = boolean_f;
|
|
int i = 0;
|
|
if (nullp(x)) {fprintf(port, "()"); return quote_void;}
|
|
if (obj_is_char(x)) {fprintf(port, "#\\%c", obj_obj2char(x)); return quote_void;}
|
|
switch (type_of(x))
|
|
{case string_tag:
|
|
fprintf(port, "\"%s\"", ((string_type *) x)->str);
|
|
break;
|
|
// TODO: what about a list? contents should be displayed per (write)
|
|
case cons_tag:
|
|
has_cycle = Cyc_has_cycle(x);
|
|
fprintf(port, "(");
|
|
_Cyc_write(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))->pname, "procedure", 10) == 0) {
|
|
fprintf(port, " ");
|
|
_Cyc_write(cadr(x), port);
|
|
fprintf(port, " ...)"); /* skip body and env for now */
|
|
break;
|
|
}
|
|
|
|
for (tmp = cdr(x); tmp && ((closure) tmp)->tag == cons_tag; tmp = cdr(tmp)) {
|
|
if (has_cycle == boolean_t) {
|
|
if (i++ > 20) break; /* arbitrary number, for now */
|
|
}
|
|
fprintf(port, " ");
|
|
_Cyc_write(car(tmp), port);
|
|
}
|
|
if (has_cycle == boolean_t) {
|
|
fprintf(port, " ...");
|
|
} else if (tmp) {
|
|
fprintf(port, " . ");
|
|
_Cyc_write(tmp, port);
|
|
}
|
|
fprintf(port, ")");
|
|
break;
|
|
default:
|
|
Cyc_display(x, port);}
|
|
return quote_void;}
|
|
|
|
object Cyc_write(object x, FILE *port)
|
|
{object y = _Cyc_write(x, port);
|
|
fprintf(port, "\n");
|
|
return y;}
|
|
|
|
object Cyc_write_char(object c, object port)
|
|
{
|
|
if (obj_is_char(c)) {
|
|
fprintf(((port_type *)port)->fp, "%c", obj_obj2char(c));
|
|
} else {
|
|
Cyc_rt_raise2("Argument is not a character", c);
|
|
}
|
|
return quote_void;
|
|
}
|
|
|
|
// TODO: should not be a predicate, may end up moving these to Scheme code
|
|
object memberp(x,l) object x; list l;
|
|
{for (; !nullp(l); l = cdr(l)) if (boolean_f != equalp(x,car(l))) return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object memqp(x,l) object x; list l;
|
|
{for (; !nullp(l); l = cdr(l)) if (eq(x,car(l))) return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object get(x,i) object x,i;
|
|
{register object plist; register object plistd;
|
|
if (nullp(x)) return x;
|
|
if (type_of(x)!=symbol_tag) {printf("get: bad x=%ld\n",((closure)x)->tag); exit(0);}
|
|
plist = symbol_plist(x);
|
|
for (; !nullp(plist); plist = cdr(plistd))
|
|
{plistd = cdr(plist);
|
|
if (eq(car(plist),i)) return car(plistd);}
|
|
return nil;}
|
|
|
|
object equalp(x,y) object x,y;
|
|
{for (; ; x = cdr(x), y = cdr(y))
|
|
{if (equal(x,y)) return boolean_t;
|
|
if (obj_is_char(x) || obj_is_char(y) ||
|
|
nullp(x) || nullp(y) ||
|
|
type_of(x)!=cons_tag || type_of(y)!=cons_tag) return boolean_f;
|
|
if (boolean_f == equalp(car(x),car(y))) return boolean_f;}}
|
|
|
|
list assq(x,l) object x; list l;
|
|
{for (; !nullp(l); l = cdr(l))
|
|
{register list la = car(l); if (eq(x,car(la))) return la;}
|
|
return boolean_f;}
|
|
|
|
list assoc(x,l) object x; list l;
|
|
{if (nullp(l) || is_value_type(l) || type_of(l) != cons_tag) return boolean_f;
|
|
for (; !nullp(l); l = cdr(l))
|
|
{register list la = car(l); if (boolean_f != equalp(x,car(la))) return la;}
|
|
return boolean_f;}
|
|
|
|
|
|
// TODO: generate these using macros???
|
|
object __num_eq(x, y) object x, y;
|
|
{if (x && y && ((integer_type *)x)->value == ((integer_type *)y)->value)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object __num_gt(x, y) object x, y;
|
|
{//printf("DEBUG cmp %d, x %d, y %d, x tag %d, y tag %d\n",
|
|
// (((integer_type *)x)->value > ((integer_type *)y)->value),
|
|
// ((integer_type *)x)->value, ((integer_type *)y)->value,
|
|
// ((list)x)->tag, ((list)y)->tag);
|
|
//exit(1);
|
|
if (((integer_type *)x)->value > ((integer_type *)y)->value)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object __num_lt(x, y) object x, y;
|
|
{if (((integer_type *)x)->value < ((integer_type *)y)->value)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object __num_gte(x, y) object x, y;
|
|
{if (((integer_type *)x)->value >= ((integer_type *)y)->value)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object __num_lte(x, y) object x, y;
|
|
{if (((integer_type *)x)->value <= ((integer_type *)y)->value)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
// TODO: object Cyc_is_eq(x, y) object x, y)
|
|
object Cyc_is_boolean(object o){
|
|
if (!nullp(o) &&
|
|
!is_value_type(o) &&
|
|
((list)o)->tag == boolean_tag &&
|
|
(eq(boolean_f, o) || eq(boolean_t, o)))
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_cons(object o){
|
|
if (!nullp(o) && !is_value_type(o) && ((list)o)->tag == cons_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_null(object o){
|
|
if (nullp(o))
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_number(object o){
|
|
if (!nullp(o) && !is_value_type(o) &&
|
|
(type_of(o) == integer_tag || type_of(o) == double_tag))
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_real(object o){
|
|
return Cyc_is_number(o);}
|
|
|
|
object Cyc_is_integer(object o){
|
|
if (!nullp(o) && !is_value_type(o) && type_of(o) == integer_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_symbol(object o){
|
|
if (!nullp(o) && !is_value_type(o) && ((list)o)->tag == symbol_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_vector(object o){
|
|
if (!nullp(o) && !is_value_type(o) && ((list)o)->tag == vector_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_port(object o){
|
|
if (!nullp(o) && !is_value_type(o) && ((list)o)->tag == port_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_string(object o){
|
|
if (!nullp(o) && !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(object o) {
|
|
int tag;
|
|
if (!nullp(o) && !is_value_type(o)) {
|
|
tag = type_of(o);
|
|
if (tag == closure0_tag ||
|
|
tag == closure1_tag ||
|
|
tag == closure2_tag ||
|
|
tag == closure3_tag ||
|
|
tag == closure4_tag ||
|
|
tag == closureN_tag ||
|
|
tag == primitive_tag) {
|
|
return boolean_t;
|
|
}
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
object Cyc_is_eof_object(object o) {
|
|
if (!nullp(o) && !is_value_type(o) && type_of(o) == eof_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_is_cvar(object o) {
|
|
if (!nullp(o) && !is_value_type(o) && type_of(o) == cvar_tag)
|
|
return boolean_t;
|
|
return boolean_f;}
|
|
|
|
object Cyc_eq(object x, object y) {
|
|
if (eq(x, y))
|
|
return boolean_t;
|
|
return boolean_f;
|
|
}
|
|
|
|
object Cyc_set_car(object l, object val) {
|
|
car(l) = val;
|
|
add_mutation(l, val);
|
|
return l;
|
|
}
|
|
|
|
object Cyc_set_cdr(object l, object val) {
|
|
cdr(l) = val;
|
|
add_mutation(l, val);
|
|
return l;
|
|
}
|
|
|
|
object Cyc_vector_set(object v, object k, object obj) {
|
|
// TODO: bounds checking? do eventually need to figure out where that should go
|
|
int idx = ((integer_type *)k)->value;
|
|
((vector)v)->elts[idx] = obj;
|
|
// TODO: probably could be more efficient here and also pass
|
|
// index, so only that one entry needs GC.
|
|
add_mutation(v, obj);
|
|
return v;
|
|
}
|
|
|
|
object Cyc_vector_ref(object v, object k) {
|
|
if (nullp(v) || is_value_type(v) || ((list)v)->tag != vector_tag) {
|
|
Cyc_rt_raise_msg("vector-ref - invalid parameter, expected vector\n");
|
|
}
|
|
if (nullp(k) || is_value_type(k) || ((list)k)->tag != integer_tag) {
|
|
Cyc_rt_raise_msg("vector-ref - invalid parameter, expected integer\n");
|
|
}
|
|
|
|
return ((vector)v)->elts[((integer_type *)k)->value];
|
|
}
|
|
|
|
integer_type Cyc_vector_length(object v) {
|
|
if (!nullp(v) && !is_value_type(v) && ((list)v)->tag == vector_tag) {
|
|
make_int(len, ((vector)v)->num_elt);
|
|
return len;
|
|
}
|
|
Cyc_rt_raise_msg("vector-length - invalid parameter, expected vector\n"); }
|
|
|
|
integer_type Cyc_length(object l){
|
|
make_int(len, 0);
|
|
while(!nullp(l)){
|
|
if (((list)l)->tag != cons_tag){
|
|
Cyc_rt_raise_msg("length - invalid parameter, expected list\n");
|
|
}
|
|
l = cdr(l);
|
|
len.value++;
|
|
}
|
|
return len;
|
|
}
|
|
|
|
string_type Cyc_number2string(object n) {
|
|
char buffer[1024];
|
|
if (type_of(n) == integer_tag) {
|
|
snprintf(buffer, 1024, "%d", ((integer_type *)n)->value);
|
|
} else if (type_of(n) == double_tag) {
|
|
snprintf(buffer, 1024, "%lf", ((double_type *)n)->value);
|
|
} else {
|
|
buffer[0] = '\0'; // TODO: throw error instead
|
|
}
|
|
make_string(str, buffer);
|
|
return str;
|
|
}
|
|
|
|
string_type Cyc_symbol2string(object sym) {
|
|
make_string(str, symbol_pname(sym));
|
|
return str;
|
|
}
|
|
|
|
object Cyc_string2symbol(object str) {
|
|
object sym = find_symbol_by_name(symbol_pname(str));
|
|
if (!sym) {
|
|
sym = add_symbol_by_name(symbol_pname(str));
|
|
}
|
|
return sym;
|
|
}
|
|
|
|
string_type Cyc_list2string(object lst){
|
|
char *buf;
|
|
int i = 0;
|
|
integer_type len = Cyc_length(lst); // Inefficient, walks whole list
|
|
buf = alloca(sizeof(char) * (len.value + 1));
|
|
|
|
while(!nullp(lst)){
|
|
buf[i++] = obj_obj2char(car(lst));
|
|
lst = cdr(lst);
|
|
}
|
|
buf[i] = '\0';
|
|
|
|
make_string(str, buf);
|
|
return str;
|
|
}
|
|
|
|
void __string2list(const char *str, cons_type *buf, int buflen){
|
|
int i = 0;
|
|
while (str[i]){
|
|
buf[i].tag = cons_tag;
|
|
buf[i].cons_car = obj_char2obj(str[i]);
|
|
buf[i].cons_cdr = (i == buflen - 1) ? nil : buf + (i + 1);
|
|
i++;
|
|
}
|
|
}
|
|
|
|
common_type Cyc_string2number(object str){
|
|
common_type result;
|
|
double n;
|
|
if (type_of(str) == string_tag &&
|
|
((string_type *) str)->str){
|
|
n = atof(((string_type *) str)->str);
|
|
|
|
if (ceilf(n) == n) {
|
|
result.integer_t.tag = integer_tag;
|
|
result.integer_t.value = (int)n;
|
|
}
|
|
else {
|
|
result.double_t.tag = double_tag;
|
|
result.double_t.value = n;
|
|
}
|
|
} else {
|
|
// TODO: not good enough because we do pointer comparisons to #f
|
|
//result.boolean_t = boolean_f;
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
integer_type Cyc_string_cmp(object str1, object str2) {
|
|
// TODO: check types of str1, str2
|
|
make_int(cmp, strcmp(((string_type *)str1)->str,
|
|
((string_type *)str2)->str));
|
|
return cmp;
|
|
}
|
|
|
|
void dispatch_string_91append(int argc, object clo, object cont, object str1, ...) {
|
|
string_type result;
|
|
va_list ap;
|
|
va_start(ap, str1);
|
|
result = Cyc_string_append_va_list(argc - 1, str1, ap);
|
|
va_end(ap);
|
|
return_funcall1(cont, &result);
|
|
}
|
|
|
|
string_type Cyc_string_append(int argc, object str1, ...) {
|
|
string_type result;
|
|
va_list ap;
|
|
va_start(ap, str1);
|
|
result = Cyc_string_append_va_list(argc, str1, ap);
|
|
va_end(ap);
|
|
return result;
|
|
}
|
|
|
|
string_type Cyc_string_append_va_list(int argc, object str1, va_list ap) {
|
|
// TODO: one way to do this, perhaps not the most efficient:
|
|
// compute lengths of the strings,
|
|
// store lens and str ptrs
|
|
// allocate buffer, memcpy each str to buffer
|
|
// make_string using buffer
|
|
|
|
int i = 0, total_len = 1; // for null char
|
|
int *len = alloca(sizeof(int) * argc);
|
|
char *buffer, *bufferp, **str = alloca(sizeof(char *) * argc);
|
|
object tmp;
|
|
|
|
if (argc > 0) {
|
|
str[i] = ((string_type *)str1)->str;
|
|
len[i] = strlen(str[i]);
|
|
total_len += len[i];
|
|
}
|
|
|
|
for (i = 1; i < argc; i++) {
|
|
tmp = va_arg(ap, object);
|
|
str[i] = ((string_type *)tmp)->str;
|
|
len[i] = strlen(str[i]);
|
|
total_len += len[i];
|
|
}
|
|
|
|
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);
|
|
return result;
|
|
}
|
|
|
|
integer_type Cyc_string_length(object str) {
|
|
make_int(len, strlen(string_str(str)));
|
|
return len;
|
|
}
|
|
|
|
object Cyc_string_ref(object str, object k) {
|
|
const char *raw = string_str(str);
|
|
int idx = integer_value(k),
|
|
len = strlen(raw);
|
|
|
|
if (idx < 0 || idx >= len) {
|
|
Cyc_rt_raise2("string-ref - invalid index", k);
|
|
}
|
|
|
|
return obj_char2obj(raw[idx]);
|
|
}
|
|
|
|
string_type Cyc_substring(object str, object start, object end) {
|
|
const char *raw = string_str(str);
|
|
int s = integer_value(start),
|
|
e = integer_value(end),
|
|
len = strlen(raw);
|
|
|
|
if (s > e) {
|
|
Cyc_rt_raise2("substring - start cannot be greater than end", start);
|
|
}
|
|
if (s > len) {
|
|
Cyc_rt_raise2("substring - start cannot be greater than string length", start);
|
|
}
|
|
if (e > len) {
|
|
e = len;
|
|
}
|
|
|
|
{
|
|
make_stringn(sub, raw + s, e - s);
|
|
return sub;
|
|
}
|
|
}
|
|
|
|
/**
|
|
* Return directory where cyclone is installed.
|
|
* This is configured via the makefile during a build.
|
|
*/
|
|
string_type Cyc_installation_dir(object type) {
|
|
if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol)type)->pname, "sld", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_SLD);
|
|
make_string(str, buf);
|
|
return str;
|
|
} else if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol)type)->pname, "lib", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_LIB);
|
|
make_string(str, buf);
|
|
return str;
|
|
} else if (Cyc_is_symbol(type) == boolean_t &&
|
|
strncmp(((symbol)type)->pname, "inc", 5) == 0) {
|
|
char buf[1024];
|
|
snprintf(buf, sizeof(buf), "%s", CYC_INSTALL_INC);
|
|
make_string(str, buf);
|
|
return str;
|
|
} else {
|
|
make_string(str, CYC_INSTALL_DIR);
|
|
return str;
|
|
}
|
|
}
|
|
|
|
/**
|
|
* 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(object cont) {
|
|
int i;
|
|
object lis = nil;
|
|
for (i = _cyc_argc; i > 1; i--) { // skip program name
|
|
object ps = alloca(sizeof(string_type));
|
|
object pl = alloca(sizeof(cons_type));
|
|
make_string(s, _cyc_argv[i - 1]);
|
|
memcpy(ps, &s, sizeof(string_type));
|
|
((list)pl)->tag = cons_tag;
|
|
((list)pl)->cons_car = ps;
|
|
((list)pl)->cons_cdr = lis;
|
|
lis = pl;
|
|
}
|
|
return_funcall1(cont, lis);
|
|
}
|
|
|
|
integer_type Cyc_system(object cmd) {
|
|
if (nullp(cmd) || is_value_type(cmd) || type_of(cmd) != string_tag) {
|
|
make_int(n, -1);
|
|
return n;
|
|
} else {
|
|
make_int(n, system(((string_type *)cmd)->str));
|
|
return n;
|
|
}
|
|
}
|
|
|
|
integer_type Cyc_char2integer(object chr){
|
|
make_int(n, obj_obj2char(chr));
|
|
return n;
|
|
}
|
|
|
|
object Cyc_integer2char(object n){
|
|
int val = 0;
|
|
|
|
if (!nullp(n)) {
|
|
val = ((integer_type *) n)->value;
|
|
}
|
|
|
|
return obj_char2obj(val);
|
|
}
|
|
|
|
void my_exit(closure);
|
|
void my_exit(env) closure env; {
|
|
#if DEBUG_SHOW_DIAG
|
|
printf("my_exit: heap bytes allocated=%d time=%ld ticks no_gcs=%ld no_m_gcs=%ld\n",
|
|
allocp-bottom,clock()-start,no_gcs,no_major_gcs);
|
|
printf("my_exit: ticks/second=%ld\n",(long) CLOCKS_PER_SEC);
|
|
#endif
|
|
exit(0);}
|
|
|
|
object __halt(object obj) {
|
|
#if DEBUG_SHOW_DIAG
|
|
printf("\nhalt: ");
|
|
Cyc_display(obj);
|
|
printf("\n");
|
|
#endif
|
|
my_exit(obj);
|
|
return nil;
|
|
}
|
|
|
|
#define declare_num_op(FUNC, FUNC_OP, FUNC_APPLY, OP, DIV) \
|
|
common_type FUNC_OP(object x, object y) { \
|
|
common_type s; \
|
|
int tx = type_of(x), ty = type_of(y); \
|
|
s.double_t.tag = double_tag; \
|
|
if (DIV && \
|
|
((ty == integer_tag && integer_value(y) == 0) || \
|
|
(ty == double_tag && double_value(y) == 0.0))) { \
|
|
Cyc_rt_raise_msg("Divide by zero"); \
|
|
} \
|
|
if (tx == integer_tag && ty == integer_tag) { \
|
|
s.integer_t.tag = integer_tag; \
|
|
s.integer_t.value = ((integer_type *)x)->value OP ((integer_type *)y)->value; \
|
|
} else if (tx == double_tag && ty == integer_tag) { \
|
|
s.double_t.value = ((double_type *)x)->value OP ((integer_type *)y)->value; \
|
|
} else if (tx == integer_tag && ty == double_tag) { \
|
|
s.double_t.value = ((integer_type *)x)->value OP ((double_type *)y)->value; \
|
|
} else if (tx == double_tag && ty == double_tag) { \
|
|
s.double_t.value = ((double_type *)x)->value OP ((double_type *)y)->value; \
|
|
} else { \
|
|
make_string(s, "Bad argument type"); \
|
|
make_cons(c1, y, nil); \
|
|
make_cons(c0, &s, &c1); \
|
|
Cyc_rt_raise(&c0); \
|
|
} \
|
|
return s; \
|
|
} \
|
|
common_type FUNC(int argc, object n, ...) { \
|
|
va_list ap; \
|
|
va_start(ap, n); \
|
|
common_type result = Cyc_num_op_va_list(argc, FUNC_OP, n, ap); \
|
|
va_end(ap); \
|
|
return result; \
|
|
} \
|
|
void FUNC_APPLY(int argc, object clo, object cont, object n, ...) { \
|
|
va_list ap; \
|
|
va_start(ap, n); \
|
|
common_type result = Cyc_num_op_va_list(argc - 1, FUNC_OP, n, ap); \
|
|
va_end(ap); \
|
|
return_funcall1(cont, &result); \
|
|
}
|
|
|
|
declare_num_op(Cyc_sum, Cyc_sum_op, dispatch_sum, +, 0);
|
|
declare_num_op(Cyc_sub, Cyc_sub_op, dispatch_sub, -, 0);
|
|
declare_num_op(Cyc_mul, Cyc_mul_op, dispatch_mul, *, 0);
|
|
// TODO: what about divide-by-zero, and casting to double when
|
|
// result contains a decimal component?
|
|
declare_num_op(Cyc_div, Cyc_div_op, dispatch_div, /, 1);
|
|
|
|
common_type Cyc_num_op_va_list(int argc, common_type (fn_op(object, object)), object n, va_list ns) {
|
|
common_type sum;
|
|
int i;
|
|
if (argc == 0) {
|
|
sum.integer_t.tag = integer_tag;
|
|
sum.integer_t.value = 0;
|
|
return sum;
|
|
}
|
|
|
|
if (type_of(n) == integer_tag) {
|
|
sum.integer_t.tag = integer_tag;
|
|
sum.integer_t.value = ((integer_type *)n)->value;
|
|
} else if (type_of(n) == double_tag) {
|
|
sum.double_t.tag = double_tag;
|
|
sum.double_t.value = ((double_type *)n)->value;
|
|
} else {
|
|
make_string(s, "Bad argument type");
|
|
make_cons(c1, n, nil);
|
|
make_cons(c0, &s, &c1);
|
|
Cyc_rt_raise(&c0);
|
|
}
|
|
|
|
for (i = 1; i < argc; i++) {
|
|
common_type result = fn_op(&sum, va_arg(ns, object));
|
|
if (type_of(&result) == integer_tag) {
|
|
sum.integer_t.tag = integer_tag;
|
|
sum.integer_t.value = ((integer_type *) &result)->value;
|
|
} else if (type_of(&result) == double_tag) {
|
|
sum.double_t.tag = double_tag;
|
|
sum.double_t.value = ((double_type *) &result)->value;
|
|
} else {
|
|
Cyc_rt_raise_msg("Internal error, invalid tag in Cyc_num_op_va_list");
|
|
}
|
|
}
|
|
|
|
return sum;
|
|
}
|
|
|
|
/* I/O functions */
|
|
|
|
port_type Cyc_stdout() {
|
|
make_port(_stdout, stdout, 0);
|
|
return _stdout;
|
|
}
|
|
|
|
port_type Cyc_stdin() {
|
|
make_port(p, stdin, 1);
|
|
return p;
|
|
}
|
|
|
|
port_type Cyc_stderr() {
|
|
make_port(p, stderr, 0);
|
|
return p;
|
|
}
|
|
|
|
port_type Cyc_io_open_input_file(object str) {
|
|
const char *fname = ((string_type *)str)->str;
|
|
make_port(p, NULL, 1);
|
|
p.fp = fopen(fname, "r");
|
|
if (p.fp == NULL) { Cyc_rt_raise2("Unable to open file", str); }
|
|
return p;
|
|
}
|
|
|
|
port_type Cyc_io_open_output_file(object str) {
|
|
const char *fname = ((string_type *)str)->str;
|
|
make_port(p, NULL, 0);
|
|
p.fp = fopen(fname, "w");
|
|
if (p.fp == NULL) { Cyc_rt_raise2("Unable to open file", str); }
|
|
return p;
|
|
}
|
|
|
|
object Cyc_io_close_input_port(object port) {
|
|
return Cyc_io_close_port(port); }
|
|
|
|
object Cyc_io_close_output_port(object port) {
|
|
return Cyc_io_close_port(port); }
|
|
|
|
object Cyc_io_close_port(object port) {
|
|
if (port && type_of(port) == port_tag) {
|
|
FILE *stream = ((port_type *)port)->fp;
|
|
if (stream) fclose(stream);
|
|
((port_type *)port)->fp = NULL;
|
|
}
|
|
return port;
|
|
}
|
|
|
|
object Cyc_io_delete_file(object filename) {
|
|
const char *fname = ((string_type *)filename)->str;
|
|
if (remove(fname) == 0)
|
|
return boolean_t; // Success
|
|
return boolean_f;
|
|
}
|
|
|
|
object Cyc_io_file_exists(object filename) {
|
|
const char *fname = ((string_type *)filename)->str;
|
|
FILE *file;
|
|
// Possibly overkill, but portable
|
|
if (file = fopen(fname, "r")) {
|
|
fclose(file);
|
|
return boolean_t;
|
|
}
|
|
return boolean_f;
|
|
}
|
|
|
|
// TODO: port arg is optional! (maybe handle that in expansion section??)
|
|
object Cyc_io_read_char(object port) {
|
|
if (type_of(port) == port_tag) {
|
|
int c = fgetc(((port_type *) port)->fp);
|
|
if (c != EOF) {
|
|
return obj_char2obj(c);
|
|
}
|
|
}
|
|
return Cyc_EOF;
|
|
}
|
|
|
|
object Cyc_io_peek_char(object port) {
|
|
FILE *stream;
|
|
int c;
|
|
|
|
if (type_of(port) == port_tag) {
|
|
stream = ((port_type *) port)->fp;
|
|
c = fgetc(stream);
|
|
ungetc(c, stream);
|
|
if (c != EOF) {
|
|
return obj_char2obj(c);
|
|
}
|
|
}
|
|
return Cyc_EOF;
|
|
}
|
|
|
|
/* This heap cons is used only for initialization. */
|
|
list mcons(a,d) object a,d;
|
|
{register cons_type *c = malloc(sizeof(cons_type));
|
|
c->tag = cons_tag; c->cons_car = a; c->cons_cdr = d;
|
|
return c;}
|
|
|
|
cvar_type *mcvar(object *var) {
|
|
cvar_type *c = malloc(sizeof(cvar_type));
|
|
c->tag = cvar_tag;
|
|
c->pvar = var;
|
|
return c;}
|
|
|
|
void _Cyc_91global_91vars(object cont, object args){
|
|
return_funcall1(cont, Cyc_global_variables); }
|
|
void _car(object cont, object args) {
|
|
Cyc_check_num_args("car", 1, args);
|
|
//Cyc_check_type("car",
|
|
return_funcall1(cont, car(car(args))); }
|
|
void _cdr(object cont, object args) {
|
|
Cyc_check_num_args("cdr", 1, args);
|
|
return_funcall1(cont, cdr(car(args))); }
|
|
void _caar(object cont, object args) {
|
|
Cyc_check_num_args("caar", 1, args);
|
|
return_funcall1(cont, caar(car(args))); }
|
|
void _cadr(object cont, object args) {
|
|
Cyc_check_num_args("cadr", 1, args);
|
|
return_funcall1(cont, cadr(car(args))); }
|
|
void _cdar(object cont, object args) {
|
|
Cyc_check_num_args("cdar", 1, args);
|
|
return_funcall1(cont, cdar(car(args))); }
|
|
void _cddr(object cont, object args) {
|
|
Cyc_check_num_args("cddr", 1, args);
|
|
return_funcall1(cont, cddr(car(args))); }
|
|
void _caaar(object cont, object args) {
|
|
Cyc_check_num_args("caaar", 1, args);
|
|
return_funcall1(cont, caaar(car(args))); }
|
|
void _caadr(object cont, object args) {
|
|
Cyc_check_num_args("caadr", 1, args);
|
|
return_funcall1(cont, caadr(car(args))); }
|
|
void _cadar(object cont, object args) {
|
|
Cyc_check_num_args("cadar", 1, args);
|
|
return_funcall1(cont, cadar(car(args))); }
|
|
void _caddr(object cont, object args) {
|
|
Cyc_check_num_args("caddr", 1, args);
|
|
return_funcall1(cont, caddr(car(args))); }
|
|
void _cdaar(object cont, object args) {
|
|
Cyc_check_num_args("cdaar", 1, args);
|
|
return_funcall1(cont, cdaar(car(args))); }
|
|
void _cdadr(object cont, object args) {
|
|
Cyc_check_num_args("cdadr", 1, args);
|
|
return_funcall1(cont, cdadr(car(args))); }
|
|
void _cddar(object cont, object args) {
|
|
Cyc_check_num_args("cddar", 1, args);
|
|
return_funcall1(cont, cddar(car(args))); }
|
|
void _cdddr(object cont, object args) {
|
|
Cyc_check_num_args("cdddr", 1, args);
|
|
return_funcall1(cont, cdddr(car(args))); }
|
|
void _caaaar(object cont, object args) {
|
|
Cyc_check_num_args("caaaar", 1, args);
|
|
return_funcall1(cont, caaaar(car(args))); }
|
|
void _caaadr(object cont, object args) {
|
|
Cyc_check_num_args("caaadr", 1, args);
|
|
return_funcall1(cont, caaadr(car(args))); }
|
|
void _caadar(object cont, object args) {
|
|
Cyc_check_num_args("caadar", 1, args);
|
|
return_funcall1(cont, caadar(car(args))); }
|
|
void _caaddr(object cont, object args) {
|
|
Cyc_check_num_args("caaddr", 1, args);
|
|
return_funcall1(cont, caaddr(car(args))); }
|
|
void _cadaar(object cont, object args) {
|
|
Cyc_check_num_args("cadaar", 1, args);
|
|
return_funcall1(cont, cadaar(car(args))); }
|
|
void _cadadr(object cont, object args) {
|
|
Cyc_check_num_args("cadadr", 1, args);
|
|
return_funcall1(cont, cadadr(car(args))); }
|
|
void _caddar(object cont, object args) {
|
|
Cyc_check_num_args("caddar", 1, args);
|
|
return_funcall1(cont, caddar(car(args))); }
|
|
void _cadddr(object cont, object args) {
|
|
Cyc_check_num_args("cadddr", 1, args);
|
|
return_funcall1(cont, cadddr(car(args))); }
|
|
void _cdaaar(object cont, object args) {
|
|
Cyc_check_num_args("cdaaar", 1, args);
|
|
return_funcall1(cont, cdaaar(car(args))); }
|
|
void _cdaadr(object cont, object args) {
|
|
Cyc_check_num_args("cdaadr", 1, args);
|
|
return_funcall1(cont, cdaadr(car(args))); }
|
|
void _cdadar(object cont, object args) {
|
|
Cyc_check_num_args("cdadar", 1, args);
|
|
return_funcall1(cont, cdadar(car(args))); }
|
|
void _cdaddr(object cont, object args) {
|
|
Cyc_check_num_args("cdaddr", 1, args);
|
|
return_funcall1(cont, cdaddr(car(args))); }
|
|
void _cddaar(object cont, object args) {
|
|
Cyc_check_num_args("cddaar", 1, args);
|
|
return_funcall1(cont, cddaar(car(args))); }
|
|
void _cddadr(object cont, object args) {
|
|
Cyc_check_num_args("cddadr", 1, args);
|
|
return_funcall1(cont, cddadr(car(args))); }
|
|
void _cdddar(object cont, object args) {
|
|
Cyc_check_num_args("cdddar", 1, args);
|
|
return_funcall1(cont, cdddar(car(args))); }
|
|
void _cddddr(object cont, object args) {
|
|
Cyc_check_num_args("cddddr", 1, args);
|
|
return_funcall1(cont, cddddr(car(args))); }
|
|
void _cons(object cont, object args) {
|
|
Cyc_check_num_args("cons", 2, args);
|
|
{ make_cons(c, car(args), cadr(args));
|
|
return_funcall1(cont, &c); }}
|
|
void _eq_127(object cont, object args){
|
|
Cyc_check_num_args("eq?", 2, args);
|
|
return_funcall1(cont, Cyc_eq(car(args), cadr(args))); }
|
|
void _eqv_127(object cont, object args){
|
|
Cyc_check_num_args("eqv?", 2, args);
|
|
_eq_127(cont, args); }
|
|
void _equal_127(object cont, object args){
|
|
Cyc_check_num_args("equal?", 2, args);
|
|
return_funcall1(cont, equalp(car(args), cadr(args))); }
|
|
void _length(object cont, object args){
|
|
Cyc_check_num_args("length", 1, args);
|
|
{ integer_type i = Cyc_length(car(args));
|
|
return_funcall1(cont, &i); }}
|
|
void _vector_91length(object cont, object args){
|
|
Cyc_check_num_args("vector_91length", 1, args);
|
|
{ integer_type i = Cyc_vector_length(car(args));
|
|
return_funcall1(cont, &i); }}
|
|
void _null_127(object cont, object args) {
|
|
Cyc_check_num_args("null?", 1, args);
|
|
return_funcall1(cont, Cyc_is_null(car(args))); }
|
|
void _set_91car_67(object cont, object args) {
|
|
Cyc_check_num_args("set-car!", 2, args);
|
|
return_funcall1(cont, Cyc_set_car(car(args), cadr(args))); }
|
|
void _set_91cdr_67(object cont, object args) {
|
|
Cyc_check_num_args("set-cdr!", 2, args);
|
|
return_funcall1(cont, Cyc_set_cdr(car(args), cadr(args))); }
|
|
void _Cyc_91has_91cycle_127(object cont, object args) {
|
|
Cyc_check_num_args("Cyc-has-cycle?", 1, args);
|
|
return_funcall1(cont, Cyc_has_cycle(car(args))); }
|
|
void __87(object cont, object args) {
|
|
integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_sum, cont, cont, args); }
|
|
void __91(object cont, object args) {
|
|
Cyc_check_num_args("-", 1, args);
|
|
{ integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_sub, cont, cont, args); }}
|
|
void __85(object cont, object args) {
|
|
integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_mul, cont, cont, args); }
|
|
void __95(object cont, object args) {
|
|
Cyc_check_num_args("/", 1, args);
|
|
{ integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_div, cont, cont, args); }}
|
|
void _Cyc_91cvar_127(object cont, object args) {
|
|
Cyc_check_num_args("Cyc-cvar?", 1, args);
|
|
return_funcall1(cont, Cyc_is_cvar(car(args))); }
|
|
void _boolean_127(object cont, object args) {
|
|
Cyc_check_num_args("boolean?", 1, args);
|
|
return_funcall1(cont, Cyc_is_boolean(car(args))); }
|
|
void _char_127(object cont, object args) {
|
|
Cyc_check_num_args("char?", 1, args);
|
|
return_funcall1(cont, Cyc_is_char(car(args))); }
|
|
void _eof_91object_127(object cont, object args) {
|
|
Cyc_check_num_args("eof_91object?", 1, args);
|
|
return_funcall1(cont, Cyc_is_eof_object(car(args))); }
|
|
void _number_127(object cont, object args) {
|
|
Cyc_check_num_args("number?", 1, args);
|
|
return_funcall1(cont, Cyc_is_number(car(args))); }
|
|
void _real_127(object cont, object args) {
|
|
Cyc_check_num_args("real?", 1, args);
|
|
return_funcall1(cont, Cyc_is_real(car(args))); }
|
|
void _integer_127(object cont, object args) {
|
|
Cyc_check_num_args("integer?", 1, args);
|
|
return_funcall1(cont, Cyc_is_integer(car(args))); }
|
|
void _pair_127(object cont, object args) {
|
|
Cyc_check_num_args("pair?", 1, args);
|
|
return_funcall1(cont, Cyc_is_cons(car(args))); }
|
|
void _procedure_127(object cont, object args) {
|
|
Cyc_check_num_args("procedure?", 1, args);
|
|
return_funcall1(cont, Cyc_is_procedure(car(args))); }
|
|
void _port_127(object cont, object args) {
|
|
Cyc_check_num_args("port?", 1, args);
|
|
return_funcall1(cont, Cyc_is_port(car(args))); }
|
|
void _vector_127(object cont, object args) {
|
|
Cyc_check_num_args("vector?", 1, args);
|
|
return_funcall1(cont, Cyc_is_vector(car(args))); }
|
|
void _string_127(object cont, object args) {
|
|
Cyc_check_num_args("string?", 1, args);
|
|
return_funcall1(cont, Cyc_is_string(car(args))); }
|
|
void _symbol_127(object cont, object args) {
|
|
Cyc_check_num_args("symbol?", 1, args);
|
|
return_funcall1(cont, Cyc_is_symbol(car(args))); }
|
|
|
|
void _Cyc_91get_91cvar(object cont, object args) {
|
|
printf("not implemented\n"); exit(1); }
|
|
void _Cyc_91set_91cvar_67(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(object cont, object args) {
|
|
if(nullp(args))
|
|
__halt(nil);
|
|
__halt(car(args));
|
|
}
|
|
void __75halt(object cont, object args) {
|
|
exit(0); }
|
|
void _cell_91get(object cont, object args) {
|
|
printf("not implemented\n"); exit(1); }
|
|
void _set_91global_67(object cont, object args) {
|
|
printf("not implemented\n"); exit(1); }
|
|
void _set_91cell_67(object cont, object args) {
|
|
printf("not implemented\n"); exit(1); }
|
|
void _cell(object cont, object args) {
|
|
printf("not implemented\n"); exit(1); }
|
|
|
|
void __123(object cont, object args) {
|
|
Cyc_check_num_args("=", 2, args);
|
|
return_funcall1(cont, __num_eq(car(args), cadr(args)));}
|
|
void __125(object cont, object args) {
|
|
Cyc_check_num_args(">", 2, args);
|
|
return_funcall1(cont, __num_gt(car(args), cadr(args)));}
|
|
void __121(object cont, object args) {
|
|
Cyc_check_num_args("<", 2, args);
|
|
return_funcall1(cont, __num_lt(car(args), cadr(args)));}
|
|
void __125_123(object cont, object args) {
|
|
Cyc_check_num_args(">=", 2, args);
|
|
return_funcall1(cont, __num_gte(car(args), cadr(args)));}
|
|
void __121_123(object cont, object args) {
|
|
Cyc_check_num_args("<=", 2, args);
|
|
return_funcall1(cont, __num_lte(car(args), cadr(args)));}
|
|
|
|
void _apply(object cont, object args) {
|
|
Cyc_check_num_args("apply", 2, args);
|
|
apply(cont, car(args), cadr(args)); }
|
|
void _assoc (object cont, object args) {
|
|
Cyc_check_num_args("assoc ", 2, args);
|
|
return_funcall1(cont, assoc(car(args), cadr(args)));}
|
|
void _assq (object cont, object args) {
|
|
Cyc_check_num_args("assq ", 2, args);
|
|
return_funcall1(cont, assq(car(args), cadr(args)));}
|
|
void _assv (object cont, object args) {
|
|
Cyc_check_num_args("assv ", 2, args);
|
|
return_funcall1(cont, assq(car(args), cadr(args)));}
|
|
void _member(object cont, object args) {
|
|
Cyc_check_num_args("member", 2, args);
|
|
return_funcall1(cont, memberp(car(args), cadr(args)));}
|
|
void _memq(object cont, object args) {
|
|
Cyc_check_num_args("memq", 2, args);
|
|
return_funcall1(cont, memqp(car(args), cadr(args)));}
|
|
void _memv(object cont, object args) {
|
|
Cyc_check_num_args("memv", 2, args);
|
|
return_funcall1(cont, memqp(car(args), cadr(args)));}
|
|
void _char_91_125integer(object cont, object args) {
|
|
Cyc_check_num_args("char->integer", 1, args);
|
|
{ integer_type i = Cyc_char2integer(car(args));
|
|
return_funcall1(cont, &i);}}
|
|
void _integer_91_125char(object cont, object args) {
|
|
Cyc_check_num_args("integer->char", 1, args);
|
|
return_funcall1(cont, Cyc_integer2char(car(args)));}
|
|
void _string_91_125number(object cont, object args) {
|
|
Cyc_check_num_args("string->number", 1, args);
|
|
{ common_type i = Cyc_string2number(car(args));
|
|
return_funcall1(cont, &i);}}
|
|
void _string_91length(object cont, object args) {
|
|
Cyc_check_num_args("string-length", 1, args);
|
|
{ integer_type i = Cyc_string_length(car(args));
|
|
return_funcall1(cont, &i);}}
|
|
void _cyc_substring(object cont, object args) {
|
|
Cyc_check_num_args("substring", 3, args);
|
|
{ string_type s = Cyc_substring(car(args), cadr(args), caddr(args));
|
|
return_funcall1(cont, &s);}}
|
|
void _cyc_string_91ref(object cont, object args) {
|
|
Cyc_check_num_args("string-ref", 2, args);
|
|
{ object c = Cyc_string_ref(car(args), cadr(args));
|
|
return_funcall1(cont, c); }}
|
|
void _Cyc_91installation_91dir(object cont, object args) {
|
|
Cyc_check_num_args("Cyc-installation-dir", 1, args);
|
|
{ string_type dir = Cyc_installation_dir(car(args));
|
|
return_funcall1(cont, &dir);}}
|
|
void _command_91line_91arguments(object cont, object args) {
|
|
object cmdline = Cyc_command_line_arguments(cont);
|
|
return_funcall1(cont, cmdline); }
|
|
void _cyc_system(object cont, object args) {
|
|
Cyc_check_num_args("system", 1, args);
|
|
{ integer_type i = Cyc_system(car(args));
|
|
return_funcall1(cont, &i);}}
|
|
//void _error(object cont, object args) {
|
|
// integer_type argc = Cyc_length(args);
|
|
// dispatch_va(argc.value, dispatch_error, cont, cont, args); }
|
|
void _Cyc_91current_91exception_91handler(object cont, object args) {
|
|
object handler = Cyc_current_exception_handler();
|
|
return_funcall1(cont, handler); }
|
|
void _Cyc_91default_91exception_91handler(object cont, object args) {
|
|
// TODO: this is a quick-and-dirty implementation, may be a better way to write this
|
|
Cyc_default_exception_handler(1, args, car(args));
|
|
}
|
|
void _string_91cmp(object cont, object args) {
|
|
Cyc_check_num_args("string-cmp", 2, args);
|
|
{ integer_type cmp = Cyc_string_cmp(car(args), cadr(args));
|
|
return_funcall1(cont, &cmp);}}
|
|
void _string_91append(object cont, object args) {
|
|
integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_string_91append, cont, cont, args); }
|
|
void _string_91_125list(object cont, object args) {
|
|
Cyc_check_num_args("string->list", 1, args);
|
|
{ string2list(lst, car(args));
|
|
return_funcall1(cont, lst);}}
|
|
void _make_91vector(object cont, object args) {
|
|
Cyc_check_num_args("make-vector", 1, args);
|
|
{ integer_type argc = Cyc_length(args);
|
|
if (argc.value >= 2) {
|
|
make_vector(v, car(args), cadr(args));
|
|
return_funcall1(cont, v);}
|
|
else {
|
|
make_vector(v, car(args), boolean_f);
|
|
return_funcall1(cont, v);}}}
|
|
void _vector_91ref(object cont, object args) {
|
|
Cyc_check_num_args("vector-ref", 2, args);
|
|
{ object ref = Cyc_vector_ref(car(args), cadr(args));
|
|
return_funcall1(cont, ref);}}
|
|
void _vector_91set_67(object cont, object args) {
|
|
Cyc_check_num_args("vector-set!", 3, args);
|
|
{ object ref = Cyc_vector_set(car(args), cadr(args), caddr(args));
|
|
return_funcall1(cont, ref);}}
|
|
void _list_91_125vector(object cont, object args) {
|
|
Cyc_check_num_args("list->vector", 1, args);
|
|
{ list2vector(l, car(args));
|
|
return_funcall1(cont, l);}}
|
|
void _list_91_125string(object cont, object args) {
|
|
Cyc_check_num_args("list->string", 1, args);
|
|
{ string_type s = Cyc_list2string(car(args));
|
|
return_funcall1(cont, &s);}}
|
|
void _string_91_125symbol(object cont, object args) {
|
|
Cyc_check_num_args("string->symbol", 1, args);
|
|
return_funcall1(cont, Cyc_string2symbol(car(args)));}
|
|
void _symbol_91_125string(object cont, object args) {
|
|
Cyc_check_num_args("symbol->string", 1, args);
|
|
{ string_type s = Cyc_symbol2string(car(args));
|
|
return_funcall1(cont, &s);}}
|
|
void _number_91_125string(object cont, object args) {
|
|
Cyc_check_num_args("number->string", 1, args);
|
|
{ string_type s = Cyc_number2string(car(args));
|
|
return_funcall1(cont, &s);}}
|
|
void _open_91input_91file(object cont, object args) {
|
|
Cyc_check_num_args("open-input-file", 1, args);
|
|
{ port_type p = Cyc_io_open_input_file(car(args));
|
|
return_funcall1(cont, &p);}}
|
|
void _open_91output_91file(object cont, object args) {
|
|
Cyc_check_num_args("open-output-file", 1, args);
|
|
{ port_type p = Cyc_io_open_output_file(car(args));
|
|
return_funcall1(cont, &p);}}
|
|
void _close_91port(object cont, object args) {
|
|
Cyc_check_num_args("close-port", 1, args);
|
|
return_funcall1(cont, Cyc_io_close_port(car(args)));}
|
|
void _close_91input_91port(object cont, object args) {
|
|
Cyc_check_num_args("close-input-port", 1, args);
|
|
return_funcall1(cont, Cyc_io_close_input_port(car(args)));}
|
|
void _close_91output_91port(object cont, object args) {
|
|
Cyc_check_num_args("close-output-port", 1, args);
|
|
return_funcall1(cont, Cyc_io_close_output_port(car(args)));}
|
|
void _file_91exists_127(object cont, object args) {
|
|
Cyc_check_num_args("file-exists?", 1, args);
|
|
return_funcall1(cont, Cyc_io_file_exists(car(args)));}
|
|
void _delete_91file(object cont, object args) {
|
|
Cyc_check_num_args("delete-file", 1, args);
|
|
return_funcall1(cont, Cyc_io_delete_file(car(args)));}
|
|
void _read_91char(object cont, object args) {
|
|
Cyc_check_num_args("read-char", 1, args);
|
|
return_funcall1(cont, Cyc_io_read_char(car(args)));}
|
|
void _peek_91char(object cont, object args) {
|
|
Cyc_check_num_args("peek-char", 1, args);
|
|
return_funcall1(cont, Cyc_io_peek_char(car(args)));}
|
|
void _Cyc_91write_91char(object cont, object args) {
|
|
Cyc_check_num_args("write-char", 2, args);
|
|
return_funcall1(cont, Cyc_write_char(car(args), cadr(args)));}
|
|
void _Cyc_91write(object cont, object args) {
|
|
Cyc_check_num_args("write", 1, args);
|
|
{ integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_write_va, cont, cont, args); }}
|
|
void _display(object cont, object args) {
|
|
Cyc_check_num_args("display", 1, args);
|
|
{ integer_type argc = Cyc_length(args);
|
|
dispatch(argc.value, (function_type)dispatch_display_va, cont, cont, args); }}
|
|
void _call_95cc(object cont, object args){
|
|
Cyc_check_num_args("call/cc", 1, args);
|
|
return_funcall2(__glo_call_95cc, cont, car(args));
|
|
}
|
|
|
|
/*
|
|
* @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(object cont, object func, object args){
|
|
common_type buf;
|
|
|
|
//printf("DEBUG apply: ");
|
|
//Cyc_display(args);
|
|
//printf("\n");
|
|
if (!is_object_type(func)) {
|
|
Cyc_rt_raise2("Call of non-procedure: ", func);
|
|
}
|
|
|
|
switch(type_of(func)) {
|
|
case primitive_tag:
|
|
// TODO: should probably check arg counts and error out if needed
|
|
((primitive_type *)func)->fn(cont, args);
|
|
break;
|
|
case closure0_tag:
|
|
case closure1_tag:
|
|
case closure2_tag:
|
|
case closure3_tag:
|
|
case closure4_tag:
|
|
case closureN_tag:
|
|
buf.integer_t = Cyc_length(args);
|
|
// TODO: validate number of args provided:
|
|
Cyc_check_num_args("<procedure>", ((closure)func)->num_args, args); // TODO: could be more efficient, eg: cyc_length(args) is called twice.
|
|
dispatch(buf.integer_t.value, ((closure)func)->fn, func, cont, args);
|
|
break;
|
|
|
|
case cons_tag:
|
|
{
|
|
// TODO: should add more error checking here, make sure car(func) is a symbol
|
|
|
|
// 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.
|
|
if (strncmp(((symbol)car(func))->pname, "primitive", 10) == 0) {
|
|
make_cons(c, cadr(func), args);
|
|
((closure)__glo_eval)->fn(3, __glo_eval, cont, &c, nil);
|
|
} else if (strncmp(((symbol)car(func))->pname, "procedure", 10) == 0) {
|
|
make_cons(c, func, args);
|
|
((closure)__glo_eval)->fn(3, __glo_eval, cont, &c, nil);
|
|
} else {
|
|
make_cons(c, func, args);
|
|
Cyc_rt_raise2("Unable to evaluate: ", &c);
|
|
}
|
|
}
|
|
|
|
default:
|
|
printf("Invalid object type %ld\n", type_of(func));
|
|
exit(1);
|
|
}
|
|
return nil; // Never reached
|
|
}
|
|
|
|
// Version of apply meant to be called from within compiled code
|
|
void Cyc_apply(int argc, closure cont, object prim, ...){
|
|
va_list ap;
|
|
object tmp;
|
|
int i;
|
|
list args = alloca(sizeof(cons_type) * argc);
|
|
|
|
va_start(ap, prim);
|
|
|
|
for (i = 0; i < argc; i++) {
|
|
tmp = va_arg(ap, object);
|
|
args[i].tag = cons_tag;
|
|
args[i].cons_car = tmp;
|
|
args[i].cons_cdr = (i == (argc-1)) ? nil : &args[i + 1];
|
|
}
|
|
//printf("DEBUG applying primitive to ");
|
|
//Cyc_display((object)&args[0]);
|
|
//printf("\n");
|
|
|
|
va_end(ap);
|
|
apply(cont, prim, (object)&args[0]);
|
|
}
|
|
// END apply
|
|
|
|
/* Extract args from given array, assuming cont is the first arg in buf */
|
|
void Cyc_apply_from_buf(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(cons_type) * (argc - 1));
|
|
cont = buf[0];
|
|
|
|
for (i = 1; i < argc; i++) {
|
|
args[i - 1].tag = cons_tag;
|
|
args[i - 1].cons_car = buf[i];
|
|
args[i - 1].cons_cdr = (i == (argc-1)) ? nil : &args[i];
|
|
}
|
|
|
|
apply(cont, prim, (object)&args[0]);
|
|
}
|
|
|
|
char *transport(x, gcgen) char *x; int gcgen;
|
|
/* Transport one object. WARNING: x cannot be nil!!! */
|
|
{
|
|
if (nullp(x)) return x;
|
|
if (obj_is_char(x)) return x;
|
|
#if DEBUG_GC
|
|
printf("entered transport ");
|
|
printf("transport %ld\n", type_of(x));
|
|
#endif
|
|
switch (type_of(x))
|
|
{case cons_tag:
|
|
{register list nx = (list) allocp;
|
|
type_of(nx) = cons_tag; car(nx) = car(x); cdr(nx) = cdr(x);
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
allocp = ((char *) nx)+sizeof(cons_type);
|
|
return (char *) nx;}
|
|
case closure0_tag:
|
|
{register closure0 nx = (closure0) allocp;
|
|
type_of(nx) = closure0_tag; nx->fn = ((closure0) x)->fn;
|
|
nx->num_args = ((closure0) x)->num_args;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
allocp = ((char *) nx)+sizeof(closure0_type);
|
|
return (char *) nx;}
|
|
case closure1_tag:
|
|
{register closure1 nx = (closure1) allocp;
|
|
type_of(nx) = closure1_tag; nx->fn = ((closure1) x)->fn;
|
|
nx->num_args = ((closure1) x)->num_args;
|
|
nx->elt1 = ((closure1) x)->elt1;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(closure1_type);
|
|
return (char *) nx;}
|
|
case closure2_tag:
|
|
{register closure2 nx = (closure2) allocp;
|
|
type_of(nx) = closure2_tag; nx->fn = ((closure2) x)->fn;
|
|
nx->num_args = ((closure2) x)->num_args;
|
|
nx->elt1 = ((closure2) x)->elt1;
|
|
nx->elt2 = ((closure2) x)->elt2;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(closure2_type);
|
|
return (char *) nx;}
|
|
case closure3_tag:
|
|
{register closure3 nx = (closure3) allocp;
|
|
type_of(nx) = closure3_tag; nx->fn = ((closure3) x)->fn;
|
|
nx->num_args = ((closure3) x)->num_args;
|
|
nx->elt1 = ((closure3) x)->elt1;
|
|
nx->elt2 = ((closure3) x)->elt2;
|
|
nx->elt3 = ((closure3) x)->elt3;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(closure3_type);
|
|
return (char *) nx;}
|
|
case closure4_tag:
|
|
{register closure4 nx = (closure4) allocp;
|
|
type_of(nx) = closure4_tag; nx->fn = ((closure4) x)->fn;
|
|
nx->num_args = ((closure4) x)->num_args;
|
|
nx->elt1 = ((closure4) x)->elt1;
|
|
nx->elt2 = ((closure4) x)->elt2;
|
|
nx->elt3 = ((closure4) x)->elt3;
|
|
nx->elt4 = ((closure4) x)->elt4;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(closure4_type);
|
|
return (char *) nx;}
|
|
case closureN_tag:
|
|
{register closureN nx = (closureN) allocp;
|
|
int i;
|
|
type_of(nx) = closureN_tag; nx->fn = ((closureN) x)->fn;
|
|
nx->num_args = ((closureN) x)->num_args;
|
|
nx->num_elt = ((closureN) x)->num_elt;
|
|
nx->elts = (object *)(((char *)nx) + sizeof(closureN_type));
|
|
for (i = 0; i < nx->num_elt; i++) {
|
|
nx->elts[i] = ((closureN) x)->elts[i];
|
|
}
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(closureN_type) + sizeof(object) * nx->num_elt;
|
|
return (char *) nx;}
|
|
case vector_tag:
|
|
{register vector nx = (vector) allocp;
|
|
int i;
|
|
type_of(nx) = vector_tag;
|
|
nx->num_elt = ((vector) x)->num_elt;
|
|
nx->elts = (object *)(((char *)nx) + sizeof(vector_type));
|
|
for (i = 0; i < nx->num_elt; i++) {
|
|
nx->elts[i] = ((vector) x)->elts[i];
|
|
}
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(vector_type) + sizeof(object) * nx->num_elt;
|
|
return (char *) nx;}
|
|
case string_tag:
|
|
{register string_type *nx = (string_type *) allocp;
|
|
type_of(nx) = string_tag;
|
|
if (gcgen == 0) {
|
|
// Minor, data heap is not relocated
|
|
nx->str = ((string_type *)x)->str;
|
|
} else {
|
|
// Major collection, data heap is moving
|
|
nx->str = dhallocp;
|
|
int len = strlen(((string_type *) x)->str);
|
|
memcpy(dhallocp, ((string_type *) x)->str, len + 1);
|
|
dhallocp += len + 1;
|
|
}
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type);
|
|
return (char *) nx;}
|
|
case integer_tag:
|
|
{register integer_type *nx = (integer_type *) allocp;
|
|
type_of(nx) = integer_tag; nx->value = ((integer_type *) x)->value;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(integer_type);
|
|
return (char *) nx;}
|
|
case double_tag:
|
|
{register double_type *nx = (double_type *) allocp;
|
|
type_of(nx) = double_tag; nx->value = ((double_type *) x)->value;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(double_type);
|
|
return (char *) nx;}
|
|
case port_tag:
|
|
{register port_type *nx = (port_type *) allocp;
|
|
type_of(nx) = port_tag; nx->fp = ((port_type *) x)->fp;
|
|
nx->mode = ((port_type *) x)->mode;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(port_type);
|
|
return (char *) nx;}
|
|
case cvar_tag:
|
|
{register cvar_type *nx = (cvar_type *) allocp;
|
|
type_of(nx) = cvar_tag; nx->pvar = ((cvar_type *) x)->pvar;
|
|
forward(x) = nx; type_of(x) = forward_tag;
|
|
x = (char *) nx; allocp = ((char *) nx)+sizeof(cvar_type);
|
|
return (char *) nx;}
|
|
case forward_tag:
|
|
return (char *) forward(x);
|
|
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)
|
|
default:
|
|
printf("transport: bad tag x=%p x.tag=%ld\n",(void *)x,type_of(x)); exit(0);}
|
|
return x;}
|
|
|
|
/* Use overflow macro which already knows which way the stack goes. */
|
|
/* Major collection, transport objects on stack or old heap */
|
|
#define transp(p) \
|
|
temp = (p); \
|
|
if ((check_overflow(low_limit,temp) && \
|
|
check_overflow(temp,high_limit)) || \
|
|
(check_overflow(old_heap_low_limit - 1, temp) && \
|
|
check_overflow(temp,old_heap_high_limit + 1))) \
|
|
(p) = (object) transport(temp,major);
|
|
|
|
void GC_loop(int major, closure cont, object *ans, int num_ans)
|
|
{char foo;
|
|
int i;
|
|
register object temp;
|
|
register object low_limit = &foo; /* Move live data above us. */
|
|
register object high_limit = stack_begin;
|
|
register char *scanp = allocp; /* Cheney scan pointer. */
|
|
register object old_heap_low_limit = low_limit; // Minor-GC default
|
|
register object old_heap_high_limit = high_limit; // Minor-GC default
|
|
|
|
char *tmp_bottom = bottom; /* Bottom of tospace. */
|
|
char *tmp_allocp = allocp; /* Cheney allocate pointer. */
|
|
char *tmp_alloc_end = alloc_end;
|
|
char *tmp_dhbottom = dhbottom;
|
|
char *tmp_dhallocp = dhallocp;
|
|
char *tmp_dhallocp_end = dhalloc_end;
|
|
|
|
if (dhallocp > dhalloc_limit) {
|
|
// Upgrade to major GC
|
|
major = 1;
|
|
no_major_gcs++;
|
|
no_gcs--;
|
|
}
|
|
|
|
if (major) {
|
|
// Initialize new heap (TODO: make a function for this)
|
|
bottom = calloc(1,global_heap_size);
|
|
allocp = (char *) ((((long) bottom)+7) & -8);
|
|
alloc_end = allocp + global_heap_size - 8;
|
|
scanp = allocp;
|
|
old_heap_low_limit = tmp_bottom;
|
|
old_heap_high_limit = tmp_alloc_end;
|
|
|
|
dhallocp = dhbottom = calloc(1, global_heap_size);
|
|
dhalloc_limit = dhallocp + (long)((global_heap_size - 8) * 0.90);
|
|
dhalloc_end = dhallocp + global_heap_size - 8;
|
|
}
|
|
|
|
#if DEBUG_GC
|
|
printf("\n=== started GC type = %d === \n", major);
|
|
#endif
|
|
/* Transport GC's continuation and its argument. */
|
|
transp(cont);
|
|
gc_cont = cont;
|
|
gc_num_ans = num_ans;
|
|
#if DEBUG_GC
|
|
printf("DEBUG done transporting cont\n");
|
|
#endif
|
|
|
|
/* Prevent overrunning buffer */
|
|
if (num_ans > NUM_GC_ANS) {
|
|
printf("Fatal error - too many arguments (%d) to GC\n", num_ans);
|
|
exit(1);
|
|
}
|
|
|
|
for (i = 0; i < num_ans; i++){
|
|
transp(ans[i]);
|
|
gc_ans[i] = ans[i];
|
|
}
|
|
#if DEBUG_GC
|
|
printf("DEBUG done transporting gc_ans\n");
|
|
#endif
|
|
|
|
/* Transport mutations. */
|
|
{
|
|
list l;
|
|
for (l = mutation_table; !nullp(l); l = cdr(l)) {
|
|
object o = car(l);
|
|
if (type_of(o) == cons_tag) {
|
|
// Transport, if necessary
|
|
// TODO: need to test this with major GC, and
|
|
// GC's of list/car-cdr from same generation
|
|
transp(car(o));
|
|
transp(cdr(o));
|
|
} else if (type_of(o) == vector_tag) {
|
|
int i;
|
|
// TODO: probably too inefficient, try collecting single index
|
|
for (i = 0; i < ((vector)o)->num_elt; i++) {
|
|
transp(((vector)o)->elts[i]);
|
|
}
|
|
} else if (type_of(o) == forward_tag) {
|
|
// Already transported, skip
|
|
} else {
|
|
printf("Unexpected type %ld transporting mutation\n", type_of(o));
|
|
exit(1);
|
|
}
|
|
}
|
|
}
|
|
clear_mutations(); /* Reset for next time */
|
|
|
|
/* Transport global variables. */
|
|
transp(Cyc_global_variables); /* Internal global used by the runtime */
|
|
{
|
|
list l = global_table;
|
|
for(; !nullp(l); l = cdr(l)){
|
|
cvar_type *c = (cvar_type *)car(l);
|
|
transp(*(c->pvar)); // GC global, not the pvar
|
|
}
|
|
}
|
|
while (scanp<allocp) /* Scan the newspace. */
|
|
switch (type_of(scanp))
|
|
{case cons_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport cons_tag\n");
|
|
#endif
|
|
transp(car(scanp)); transp(cdr(scanp));
|
|
scanp += sizeof(cons_type); break;
|
|
case closure0_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport closure0 \n");
|
|
#endif
|
|
scanp += sizeof(closure0_type); break;
|
|
case closure1_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport closure1 \n");
|
|
#endif
|
|
transp(((closure1) scanp)->elt1);
|
|
scanp += sizeof(closure1_type); break;
|
|
case closure2_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport closure2 \n");
|
|
#endif
|
|
transp(((closure2) scanp)->elt1); transp(((closure2) scanp)->elt2);
|
|
scanp += sizeof(closure2_type); break;
|
|
case closure3_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport closure3 \n");
|
|
#endif
|
|
transp(((closure3) scanp)->elt1); transp(((closure3) scanp)->elt2);
|
|
transp(((closure3) scanp)->elt3);
|
|
scanp += sizeof(closure3_type); break;
|
|
case closure4_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport closure4 \n");
|
|
#endif
|
|
transp(((closure4) scanp)->elt1); transp(((closure4) scanp)->elt2);
|
|
transp(((closure4) scanp)->elt3); transp(((closure4) scanp)->elt4);
|
|
scanp += sizeof(closure4_type); break;
|
|
case closureN_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport closureN \n");
|
|
#endif
|
|
{int i; int n = ((closureN) scanp)->num_elt;
|
|
for (i = 0; i < n; i++) {
|
|
transp(((closureN) scanp)->elts[i]);
|
|
}
|
|
scanp += sizeof(closureN_type) + sizeof(object) * n;
|
|
}
|
|
break;
|
|
case vector_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport vector \n");
|
|
#endif
|
|
{int i; int n = ((vector) scanp)->num_elt;
|
|
for (i = 0; i < n; i++) {
|
|
transp(((vector) scanp)->elts[i]);
|
|
}
|
|
scanp += sizeof(vector_type) + sizeof(object) * n;
|
|
}
|
|
break;
|
|
case string_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport string \n");
|
|
#endif
|
|
scanp += sizeof(string_type); break;
|
|
case integer_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport integer \n");
|
|
#endif
|
|
scanp += sizeof(integer_type); break;
|
|
case double_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport double \n");
|
|
#endif
|
|
scanp += sizeof(double_type); break;
|
|
case port_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport port \n");
|
|
#endif
|
|
scanp += sizeof(port_type); break;
|
|
case cvar_tag:
|
|
#if DEBUG_GC
|
|
printf("DEBUG transport cvar \n");
|
|
#endif
|
|
scanp += sizeof(cvar_type); break;
|
|
case eof_tag:
|
|
case primitive_tag:
|
|
case symbol_tag:
|
|
case boolean_tag:
|
|
default:
|
|
printf("GC: bad tag scanp=%p scanp.tag=%ld\n",(void *)scanp,type_of(scanp));
|
|
exit(0);}
|
|
|
|
if (major) {
|
|
free(tmp_bottom);
|
|
free(tmp_dhbottom);
|
|
}
|
|
}
|
|
|
|
void GC(cont,ans,num_ans) closure cont; object *ans; int num_ans;
|
|
{
|
|
/* Only room for one more minor-GC, so do a major one.
|
|
* Not sure this is the best strategy, it may be better to do major
|
|
* ones sooner, perhaps after every x minor GC's.
|
|
*
|
|
* Also may need to consider dynamically increasing heap size, but
|
|
* by how much (1.3x, 1.5x, etc) and when? I suppose when heap usage
|
|
* after a collection is above a certain percentage, then it would be
|
|
* necessary to increase heap size the next time.
|
|
*/
|
|
if (allocp >= (bottom + (global_heap_size - global_stack_size))) {
|
|
//printf("Possibly only room for one more minor GC. no_gcs = %ld\n", no_gcs);
|
|
no_major_gcs++;
|
|
GC_loop(1, cont, ans, num_ans);
|
|
} else {
|
|
no_gcs++; /* Count the number of minor GC's. */
|
|
GC_loop(0, cont, ans, num_ans);
|
|
}
|
|
|
|
/* You have to let it all go, Neo. Fear, doubt, and disbelief. Free your mind... */
|
|
longjmp(jmp_main,1); /* Return globals gc_cont, gc_ans. */
|
|
}
|
|
|
|
|
|
/**
|
|
* Receive a list of arguments and apply them to the given function
|
|
*/
|
|
void dispatch(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(argc, func, clo, b);
|
|
}
|
|
|
|
/**
|
|
* Same as above but for a varargs C function
|
|
*/
|
|
void dispatch_va(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(argc, (function_type)func, clo, b);
|
|
}
|
|
|
|
static primitive_type Cyc_91global_91vars_primitive = {primitive_tag, "Cyc-global-vars", &_Cyc_91global_91vars};
|
|
static primitive_type Cyc_91get_91cvar_primitive = {primitive_tag, "Cyc-get-cvar", &_Cyc_91get_91cvar};
|
|
static primitive_type Cyc_91set_91cvar_67_primitive = {primitive_tag, "Cyc-set-cvar!", &_Cyc_91set_91cvar_67};
|
|
static primitive_type Cyc_91cvar_127_primitive = {primitive_tag, "Cyc-cvar?", &_Cyc_91cvar_127};
|
|
static primitive_type Cyc_91has_91cycle_127_primitive = {primitive_tag, "Cyc-has-cycle?", &_Cyc_91has_91cycle_127};
|
|
static primitive_type _87_primitive = {primitive_tag, "+", &__87};
|
|
static primitive_type _91_primitive = {primitive_tag, "-", &__91};
|
|
static primitive_type _85_primitive = {primitive_tag, "*", &__85};
|
|
static primitive_type _95_primitive = {primitive_tag, "/", &__95};
|
|
static primitive_type _123_primitive = {primitive_tag, "=", &__123};
|
|
static primitive_type _125_primitive = {primitive_tag, ">", &__125};
|
|
static primitive_type _121_primitive = {primitive_tag, "<", &__121};
|
|
static primitive_type _125_123_primitive = {primitive_tag, ">=", &__125_123};
|
|
static primitive_type _121_123_primitive = {primitive_tag, "<=", &__121_123};
|
|
static primitive_type apply_primitive = {primitive_tag, "apply", &_apply};
|
|
static primitive_type _75halt_primitive = {primitive_tag, "%halt", &__75halt};
|
|
static primitive_type exit_primitive = {primitive_tag, "exit", &_cyc_exit};
|
|
static primitive_type Cyc_91current_91exception_91handler_primitive = {primitive_tag, "Cyc_current_exception_handler", &_Cyc_91current_91exception_91handler};
|
|
static primitive_type Cyc_91default_91exception_91handler_primitive = {primitive_tag, "Cyc_default_exception_handler", &_Cyc_91default_91exception_91handler};
|
|
static primitive_type cons_primitive = {primitive_tag, "cons", &_cons};
|
|
static primitive_type cell_91get_primitive = {primitive_tag, "cell-get", &_cell_91get};
|
|
static primitive_type set_91global_67_primitive = {primitive_tag, "set-global!", &_set_91global_67};
|
|
static primitive_type set_91cell_67_primitive = {primitive_tag, "set-cell!", &_set_91cell_67};
|
|
static primitive_type cell_primitive = {primitive_tag, "cell", &_cell};
|
|
static primitive_type eq_127_primitive = {primitive_tag, "eq?", &_eq_127};
|
|
static primitive_type eqv_127_primitive = {primitive_tag, "eqv?", &_eqv_127};
|
|
static primitive_type equal_127_primitive = {primitive_tag, "equal?", &_equal_127};
|
|
static primitive_type assoc_primitive = {primitive_tag, "assoc", &_assoc};
|
|
static primitive_type assq_primitive = {primitive_tag, "assq", &_assq};
|
|
static primitive_type assv_primitive = {primitive_tag, "assv", &_assv};
|
|
static primitive_type member_primitive = {primitive_tag, "member", &_member};
|
|
static primitive_type memq_primitive = {primitive_tag, "memq", &_memq};
|
|
static primitive_type memv_primitive = {primitive_tag, "memv", &_memv};
|
|
static primitive_type length_primitive = {primitive_tag, "length", &_length};
|
|
static primitive_type vector_91length_primitive = {primitive_tag, "vector-length", &_vector_91length};
|
|
static primitive_type set_91car_67_primitive = {primitive_tag, "set-car!", &_set_91car_67};
|
|
static primitive_type set_91cdr_67_primitive = {primitive_tag, "set-cdr!", &_set_91cdr_67};
|
|
static primitive_type car_primitive = {primitive_tag, "car", &_car};
|
|
static primitive_type cdr_primitive = {primitive_tag, "cdr", &_cdr};
|
|
static primitive_type caar_primitive = {primitive_tag, "caar", &_caar};
|
|
static primitive_type cadr_primitive = {primitive_tag, "cadr", &_cadr};
|
|
static primitive_type cdar_primitive = {primitive_tag, "cdar", &_cdar};
|
|
static primitive_type cddr_primitive = {primitive_tag, "cddr", &_cddr};
|
|
static primitive_type caaar_primitive = {primitive_tag, "caaar", &_caaar};
|
|
static primitive_type caadr_primitive = {primitive_tag, "caadr", &_caadr};
|
|
static primitive_type cadar_primitive = {primitive_tag, "cadar", &_cadar};
|
|
static primitive_type caddr_primitive = {primitive_tag, "caddr", &_caddr};
|
|
static primitive_type cdaar_primitive = {primitive_tag, "cdaar", &_cdaar};
|
|
static primitive_type cdadr_primitive = {primitive_tag, "cdadr", &_cdadr};
|
|
static primitive_type cddar_primitive = {primitive_tag, "cddar", &_cddar};
|
|
static primitive_type cdddr_primitive = {primitive_tag, "cdddr", &_cdddr};
|
|
static primitive_type caaaar_primitive = {primitive_tag, "caaaar", &_caaaar};
|
|
static primitive_type caaadr_primitive = {primitive_tag, "caaadr", &_caaadr};
|
|
static primitive_type caadar_primitive = {primitive_tag, "caadar", &_caadar};
|
|
static primitive_type caaddr_primitive = {primitive_tag, "caaddr", &_caaddr};
|
|
static primitive_type cadaar_primitive = {primitive_tag, "cadaar", &_cadaar};
|
|
static primitive_type cadadr_primitive = {primitive_tag, "cadadr", &_cadadr};
|
|
static primitive_type caddar_primitive = {primitive_tag, "caddar", &_caddar};
|
|
static primitive_type cadddr_primitive = {primitive_tag, "cadddr", &_cadddr};
|
|
static primitive_type cdaaar_primitive = {primitive_tag, "cdaaar", &_cdaaar};
|
|
static primitive_type cdaadr_primitive = {primitive_tag, "cdaadr", &_cdaadr};
|
|
static primitive_type cdadar_primitive = {primitive_tag, "cdadar", &_cdadar};
|
|
static primitive_type cdaddr_primitive = {primitive_tag, "cdaddr", &_cdaddr};
|
|
static primitive_type cddaar_primitive = {primitive_tag, "cddaar", &_cddaar};
|
|
static primitive_type cddadr_primitive = {primitive_tag, "cddadr", &_cddadr};
|
|
static primitive_type cdddar_primitive = {primitive_tag, "cdddar", &_cdddar};
|
|
static primitive_type cddddr_primitive = {primitive_tag, "cddddr", &_cddddr};
|
|
static primitive_type char_91_125integer_primitive = {primitive_tag, "char->integer", &_char_91_125integer};
|
|
static primitive_type integer_91_125char_primitive = {primitive_tag, "integer->char", &_integer_91_125char};
|
|
static primitive_type string_91_125number_primitive = {primitive_tag, "string->number", &_string_91_125number};
|
|
static primitive_type string_91length_primitive = {primitive_tag, "string-length", &_string_91length};
|
|
static primitive_type substring_primitive = {primitive_tag, "substring", &_cyc_substring};
|
|
static primitive_type string_91ref_primitive = {primitive_tag, "string-ref", &_cyc_string_91ref};
|
|
static primitive_type Cyc_91installation_91dir_primitive = {primitive_tag, "Cyc-installation-dir", &_Cyc_91installation_91dir};
|
|
static primitive_type command_91line_91arguments_primitive = {primitive_tag, "command-line-arguments", &_command_91line_91arguments};
|
|
static primitive_type system_primitive = {primitive_tag, "system", &_cyc_system};
|
|
static primitive_type string_91cmp_primitive = {primitive_tag, "string-cmp", &_string_91cmp};
|
|
static primitive_type string_91append_primitive = {primitive_tag, "string-append", &_string_91append};
|
|
static primitive_type string_91_125list_primitive = {primitive_tag, "string->list", &_string_91_125list};
|
|
static primitive_type list_91_125string_primitive = {primitive_tag, "list->string", &_list_91_125string};
|
|
static primitive_type string_91_125symbol_primitive = {primitive_tag, "string->symbol", &_string_91_125symbol};
|
|
static primitive_type symbol_91_125string_primitive = {primitive_tag, "symbol->string", &_symbol_91_125string};
|
|
static primitive_type number_91_125string_primitive = {primitive_tag, "number->string", &_number_91_125string};
|
|
static primitive_type list_91_125vector_primitive = {primitive_tag, "list-vector", &_list_91_125vector};
|
|
static primitive_type make_91vector_primitive = {primitive_tag, "make-vector", &_make_91vector};
|
|
static primitive_type vector_91ref_primitive = {primitive_tag, "vector-ref", &_vector_91ref};
|
|
static primitive_type vector_91set_67_primitive = {primitive_tag, "vector-set!", &_vector_91set_67};
|
|
static primitive_type boolean_127_primitive = {primitive_tag, "boolean?", &_boolean_127};
|
|
static primitive_type char_127_primitive = {primitive_tag, "char?", &_char_127};
|
|
static primitive_type eof_91object_127_primitive = {primitive_tag, "eof-object?", &_eof_91object_127};
|
|
static primitive_type null_127_primitive = {primitive_tag, "null?", &_null_127};
|
|
static primitive_type number_127_primitive = {primitive_tag, "number?", &_number_127};
|
|
static primitive_type real_127_primitive = {primitive_tag, "real?", &_real_127};
|
|
static primitive_type integer_127_primitive = {primitive_tag, "integer?", &_integer_127};
|
|
static primitive_type pair_127_primitive = {primitive_tag, "pair?", &_pair_127};
|
|
static primitive_type procedure_127_primitive = {primitive_tag, "procedure?", &_procedure_127};
|
|
static primitive_type port_127_primitive = {primitive_tag, "port?", &_port_127};
|
|
static primitive_type vector_127_primitive = {primitive_tag, "vector?", &_vector_127};
|
|
static primitive_type string_127_primitive = {primitive_tag, "string?", &_string_127};
|
|
static primitive_type symbol_127_primitive = {primitive_tag, "symbol?", &_symbol_127};
|
|
static primitive_type open_91input_91file_primitive = {primitive_tag, "open-input-file", &_open_91input_91file};
|
|
static primitive_type open_91output_91file_primitive = {primitive_tag, "open-output-file", &_open_91output_91file};
|
|
static primitive_type close_91port_primitive = {primitive_tag, "close-port", &_close_91port};
|
|
static primitive_type close_91input_91port_primitive = {primitive_tag, "close-input-port", &_close_91input_91port};
|
|
static primitive_type close_91output_91port_primitive = {primitive_tag, "close-output-port", &_close_91output_91port};
|
|
static primitive_type file_91exists_127_primitive = {primitive_tag, "file-exists?", &_file_91exists_127};
|
|
static primitive_type delete_91file_primitive = {primitive_tag, "delete-file", &_delete_91file};
|
|
static primitive_type read_91char_primitive = {primitive_tag, "read-char", &_read_91char};
|
|
static primitive_type peek_91char_primitive = {primitive_tag, "peek-char", &_peek_91char};
|
|
static primitive_type Cyc_91write_primitive = {primitive_tag, "Cyc-write", &_Cyc_91write};
|
|
static primitive_type Cyc_91write_91char_primitive = {primitive_tag, "Cyc-write-char", &_Cyc_91write_91char};
|
|
static primitive_type Cyc_91display_primitive = {primitive_tag, "Cyc-display", &_display};
|
|
static primitive_type call_95cc_primitive = {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_91has_91cycle_127 = &Cyc_91has_91cycle_127_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_assoc = &assoc_primitive;
|
|
const object primitive_assq = &assq_primitive;
|
|
const object primitive_assv = &assv_primitive;
|
|
const object primitive_member = &member_primitive;
|
|
const object primitive_memq = &memq_primitive;
|
|
const object primitive_memv = &memv_primitive;
|
|
const object primitive_length = &length_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_Cyc_91installation_91dir = &Cyc_91installation_91dir_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_string_91_125list = &string_91_125list_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_91vector = &make_91vector_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_string_127 = &string_127_primitive;
|
|
const object primitive_port_127 = &port_127_primitive;
|
|
const object primitive_vector_127 = &vector_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_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_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;
|
|
|