diff --git a/Makefile b/Makefile index d96be379..6c546951 100644 --- a/Makefile +++ b/Makefile @@ -21,7 +21,7 @@ libcyclone.a: runtime.c runtime.h #gcc -static main.c -L. -lmean -o statically_linked #Note: the first three letters (the lib) must not be specified, as well as the suffix (.a) -cyclone: cyclone.scm trans.so cgen.so parser.so +cyclone: cyclone.scm trans.so cgen.so parser.so libcyclone.a csc cyclone.scm .PHONY: test @@ -37,5 +37,5 @@ tags: .PHONY: clean clean: - rm -rf a.out *.o *.so *.c *.out tags cyclone icyc + rm -rf a.out *.o *.so *.a *.out tags cyclone icyc $(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;) diff --git a/cyclone.h b/cyclone.h new file mode 100644 index 00000000..bd59dc61 --- /dev/null +++ b/cyclone.h @@ -0,0 +1,270 @@ +/** + * Cyclone Scheme + * Copyright (c) 2014, Justin Ethier + * All rights reserved. + * + * This file contains C types used by compiled programs. + */ + +#ifndef CYCLONE_H +#define CYCLONE_H + +/* Debug GC flag */ +#define DEBUG_GC 0 + +/* Show diagnostic information for the GC when program terminate */ +#define DEBUG_SHOW_DIAG 0 + +/* Maximum number of args that GC will accept */ +#define NUM_GC_ANS 128 + +/* STACK_GROWS_DOWNWARD is a machine-specific preprocessor switch. */ +/* It is true for the Macintosh 680X0 and the Intel 80860. */ +#define STACK_GROWS_DOWNWARD 1 + +/* STACK_SIZE is the size of the stack buffer, in bytes. */ +/* Some machines like a smallish stack--i.e., 4k-16k, while others */ +/* like a biggish stack--i.e., 100k-500k. */ +#define STACK_SIZE 100000 + +/* HEAP_SIZE is the size of the 2nd generation, in bytes. */ +/* HEAP_SIZE should be at LEAST 225000*sizeof(cons_type). */ +#define HEAP_SIZE 6000000 + +/* Define size of Lisp tags. Options are "short" or "long". */ +typedef long tag_type; + +#include +#include +#include +#include +#include +#include + +#ifndef CLOCKS_PER_SEC +/* gcc doesn't define this, even though ANSI requires it in .. */ +#define CLOCKS_PER_SEC 0 +#define setjmp _setjmp +#define longjmp _longjmp +#endif + +/* The following sparc hack is courtesy of Roger Critchlow. */ +/* It speeds up the output by more than a factor of THREE. */ +/* Do 'gcc -O -S cboyer13.c'; 'perlscript >cboyer.s'; 'gcc cboyer.s'. */ +#ifdef __GNUC__ +#ifdef sparc +#define never_returns __attribute__ ((noreturn)) +#else +#define never_returns /* __attribute__ ((noreturn)) */ +#endif +#else +#define never_returns /* __attribute__ ((noreturn)) */ +#endif + +#if STACK_GROWS_DOWNWARD +#define check_overflow(x,y) ((x) < (y)) +#else +#define check_overflow(x,y) ((x) > (y)) +#endif + +/* Define tag values. (I don't trust compilers to optimize enums.) */ +#define cons_tag 0 +#define symbol_tag 1 +#define forward_tag 2 +#define closure0_tag 3 +#define closure1_tag 4 +#define closure2_tag 5 +#define closure3_tag 6 +#define closure4_tag 7 +#define closureN_tag 8 +#define integer_tag 9 +#define double_tag 10 +#define string_tag 11 +#define primitive_tag 12 +#define eof_tag 13 +#define port_tag 14 +#define boolean_tag 15 +#define cvar_tag 16 + +#define nil NULL +#define eq(x,y) (x == y) +#define nullp(x) (x == NULL) +#define or(x,y) (x || y) +#define and(x,y) (x && y) + +/* Define general object type. */ + +typedef void *object; + +#define type_of(x) (((list) x)->tag) +#define forward(x) (((list) x)->cons_car) + +/* Define value types. + Depending on the underlying architecture, compiler, etc these types + have extra least significant bits that can be used to mark them as + values instead of objects (IE, pointer to a tagged object). + On many machines, addresses are multiples of four, leaving the two + least significant bits free - according to lisp in small pieces. + + experimenting with chars below: +*/ +#define obj_is_char(x) ((unsigned long)(x) & (unsigned long)1) +#define obj_obj2char(x) (char)((long)(x)>>1) +#define obj_char2obj(c) ((void *)(((c)<<1) | 1)) + +#define is_value_type(x) obj_is_char(x) +#define is_object_type(x) (x && !is_value_type(x)) + +/* Define function type. */ + +typedef void (*function_type)(); +typedef void (*function_type_va)(int, object, object, object, ...); + +/* Define C-variable integration type */ +typedef struct {tag_type tag; object *pvar;} cvar_type; +typedef cvar_type *cvar; +#define make_cvar(n,v) cvar_type n; n.tag = cvar_tag; n.pvar = v; + +/* Define boolean type. */ +typedef struct {const tag_type tag; const char *pname;} boolean_type; +typedef boolean_type *boolean; + +#define boolean_pname(x) (((boolean_type *) x)->pname) + +#define defboolean(name,pname) \ +static boolean_type name##_boolean = {boolean_tag, #pname}; \ +static const object boolean_##name = &name##_boolean + +/* Define symbol type. */ + +typedef struct {const tag_type tag; const char *pname; object plist;} symbol_type; +typedef symbol_type *symbol; + +#define symbol_pname(x) (((symbol_type *) x)->pname) +#define symbol_plist(x) (((symbol_type *) x)->plist) + +#define defsymbol(name,pname) \ +static symbol_type name##_symbol = {symbol_tag, #pname, nil}; \ +static const object quote_##name = &name##_symbol + +/* Define numeric types */ +typedef struct {tag_type tag; int value;} integer_type; +#define make_int(n,v) integer_type n; n.tag = integer_tag; n.value = v; +typedef struct {tag_type tag; double value;} double_type; +#define make_double(n,v) double_type n; n.tag = double_tag; n.value = v; + +/* Define string type */ +typedef struct {tag_type tag; char *str;} string_type; +#define make_string(cv,s) string_type cv; cv.tag = string_tag; \ +{ int len = strlen(s); cv.str = dhallocp; \ + if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \ + printf("Fatal error: data heap overflow\n"); exit(1); } \ + memcpy(dhallocp, s, len + 1); dhallocp += len + 1; } + +/* I/O types */ + +// TODO: FILE* may not be good enough +// consider http://stackoverflow.com/questions/6206893/how-to-implement-char-ready-in-c +// TODO: a simple wrapper around FILE may not be good enough long-term +// TODO: how exactly mode will be used. need to know r/w, bin/txt +typedef struct {tag_type tag; FILE *fp; int mode;} port_type; +#define make_port(p,f,m) port_type p; p.tag = port_tag; p.fp = f; p.mode = m; + +/* Define cons type. */ + +typedef struct {tag_type tag; object cons_car,cons_cdr;} cons_type; +typedef cons_type *list; + +#define car(x) (((list) x)->cons_car) +#define cdr(x) (((list) x)->cons_cdr) +#define caar(x) (car(car(x))) +#define cadr(x) (car(cdr(x))) +#define cdar(x) (cdr(car(x))) +#define cddr(x) (cdr(cdr(x))) +#define caaar(x) (car(car(car(x)))) +#define caadr(x) (car(car(cdr(x)))) +#define cadar(x) (car(cdr(car(x)))) +#define caddr(x) (car(cdr(cdr(x)))) +#define cdaar(x) (cdr(car(car(x)))) +#define cdadr(x) (cdr(car(cdr(x)))) +#define cddar(x) (cdr(cdr(car(x)))) +#define cdddr(x) (cdr(cdr(cdr(x)))) +#define caaaar(x) (car(car(car(car(x))))) +#define caaadr(x) (car(car(car(cdr(x))))) +#define caadar(x) (car(car(cdr(car(x))))) +#define caaddr(x) (car(car(cdr(cdr(x))))) +#define cadaar(x) (car(cdr(car(car(x))))) +#define cadadr(x) (car(cdr(car(cdr(x))))) +#define caddar(x) (car(cdr(cdr(car(x))))) +#define cadddr(x) (car(cdr(cdr(cdr(x))))) +#define cdaaar(x) (cdr(car(car(car(x))))) +#define cdaadr(x) (cdr(car(car(cdr(x))))) +#define cdadar(x) (cdr(car(cdr(car(x))))) +#define cdaddr(x) (cdr(car(cdr(cdr(x))))) +#define cddaar(x) (cdr(cdr(car(car(x))))) +#define cddadr(x) (cdr(cdr(car(cdr(x))))) +#define cdddar(x) (cdr(cdr(cdr(car(x))))) +#define cddddr(x) (cdr(cdr(cdr(cdr(x))))) + +#define make_cons(n,a,d) \ +cons_type n; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d; + +#define atom(x) ((x == NULL) || (((cons_type *) x)->tag != cons_tag)) + +/* Closure types. (I don't trust compilers to optimize vector refs.) */ + +typedef struct {tag_type tag; function_type fn;} closure0_type; +typedef struct {tag_type tag; function_type fn; object elt1;} closure1_type; +typedef struct {tag_type tag; function_type fn; object elt1,elt2;} closure2_type; +typedef struct {tag_type tag; function_type fn; object elt1,elt2,elt3;} closure3_type; +typedef struct {tag_type tag; function_type fn; object elt1,elt2,elt3,elt4;} closure4_type; +typedef struct {tag_type tag; function_type fn; int num_elt; object *elts;} closureN_type; + +typedef closure0_type *closure0; +typedef closure1_type *closure1; +typedef closure2_type *closure2; +typedef closure3_type *closure3; +typedef closure4_type *closure4; +typedef closureN_type *closureN; +typedef closure0_type *closure; + +#define mclosure0(c,f) closure0_type c; c.tag = closure0_tag; c.fn = f; +#define mclosure1(c,f,a) closure1_type c; c.tag = closure1_tag; \ + c.fn = f; c.elt1 = a; +#define mclosure2(c,f,a1,a2) closure2_type c; c.tag = closure2_tag; \ + c.fn = f; c.elt1 = a1; c.elt2 = a2; +#define mclosure3(c,f,a1,a2,a3) closure3_type c; c.tag = closure3_tag; \ + c.fn = f; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3; +#define mclosure4(c,f,a1,a2,a3,a4) closure4_type c; c.tag = closure4_tag; \ + c.fn = f; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3; c.elt4 = a4; +// #define setq(x,e) x = e + +#define mlist1(e1) (mcons(e1,nil)) +#define mlist2(e2,e1) (mcons(e2,mlist1(e1))) +#define mlist3(e3,e2,e1) (mcons(e3,mlist2(e2,e1))) +#define mlist4(e4,e3,e2,e1) (mcons(e4,mlist3(e3,e2,e1))) +#define mlist5(e5,e4,e3,e2,e1) (mcons(e5,mlist4(e4,e3,e2,e1))) +#define mlist6(e6,e5,e4,e3,e2,e1) (mcons(e6,mlist5(e5,e4,e3,e2,e1))) +#define mlist7(e7,e6,e5,e4,e3,e2,e1) (mcons(e7,mlist6(e6,e5,e4,e3,e2,e1))) + +// #define rule(lhs,rhs) (mlist3(quote_equal,lhs,rhs)) + +#define make_cell(n,a) make_cons(n,a,nil); + +/* Primitive types */ +//typedef void (*prim_function_type)(); +typedef struct {tag_type tag; const char *pname; function_type fn;} primitive_type; +typedef primitive_type *primitive; + +#define defprimitive(name, pname, fnc) \ +static primitive_type name##_primitive = {primitive_tag, #pname, fnc}; \ +static const object primitive_##name = &name##_primitive + +#define prim(x) (x && ((primitive)x)->tag == primitive_tag) +#define prim_name(x) (((primitive_type *) x)->pname) + + +void dispatch(int argc, function_type func, object clo, object cont, object args); +void dispatch_va(int argc, function_type_va func, object clo, object cont, object args); + +#endif /* CYCLONE_H */ diff --git a/runtime.c b/runtime.c index 2e8a9692..83469d2d 100644 --- a/runtime.c +++ b/runtime.c @@ -1,4 +1,4 @@ -#include "runtime.h" +#include "cyclone.h" /** * Take list of args and call a function with them as params. diff --git a/runtime.h b/runtime.h index 3843c6d5..0e0e015b 100644 --- a/runtime.h +++ b/runtime.h @@ -9,261 +9,14 @@ #ifndef CYCLONE_RUNTIME_H #define CYCLONE_RUNTIME_H -/* Debug GC flag */ -#define DEBUG_GC 0 - -/* Show diagnostic information for the GC when program terminate */ -#define DEBUG_SHOW_DIAG 0 - -/* Maximum number of args that GC will accept */ -#define NUM_GC_ANS 100 - -/* STACK_GROWS_DOWNWARD is a machine-specific preprocessor switch. */ -/* It is true for the Macintosh 680X0 and the Intel 80860. */ -#define STACK_GROWS_DOWNWARD 1 - -/* STACK_SIZE is the size of the stack buffer, in bytes. */ -/* Some machines like a smallish stack--i.e., 4k-16k, while others */ -/* like a biggish stack--i.e., 100k-500k. */ -#define STACK_SIZE 100000 - -/* HEAP_SIZE is the size of the 2nd generation, in bytes. */ -/* HEAP_SIZE should be at LEAST 225000*sizeof(cons_type). */ -#define HEAP_SIZE 6000000 +#include "cyclone.h" long global_stack_size; long global_heap_size; -/* Define size of Lisp tags. Options are "short" or "long". */ -typedef long tag_type; - -#include -#include -#include -#include -#include -#include - -#ifndef CLOCKS_PER_SEC -/* gcc doesn't define this, even though ANSI requires it in .. */ -#define CLOCKS_PER_SEC 0 -#define setjmp _setjmp -#define longjmp _longjmp -#endif - -/* The following sparc hack is courtesy of Roger Critchlow. */ -/* It speeds up the output by more than a factor of THREE. */ -/* Do 'gcc -O -S cboyer13.c'; 'perlscript >cboyer.s'; 'gcc cboyer.s'. */ -#ifdef __GNUC__ -#ifdef sparc -#define never_returns __attribute__ ((noreturn)) -#else -#define never_returns /* __attribute__ ((noreturn)) */ -#endif -#else -#define never_returns /* __attribute__ ((noreturn)) */ -#endif - -#if STACK_GROWS_DOWNWARD -#define check_overflow(x,y) ((x) < (y)) -#else -#define check_overflow(x,y) ((x) > (y)) -#endif - -/* Define tag values. (I don't trust compilers to optimize enums.) */ -#define cons_tag 0 -#define symbol_tag 1 -#define forward_tag 2 -#define closure0_tag 3 -#define closure1_tag 4 -#define closure2_tag 5 -#define closure3_tag 6 -#define closure4_tag 7 -#define closureN_tag 8 -#define integer_tag 9 -#define double_tag 10 -#define string_tag 11 -#define primitive_tag 12 -#define eof_tag 13 -#define port_tag 14 -#define boolean_tag 15 -#define cvar_tag 16 - -#define nil NULL -#define eq(x,y) (x == y) -#define nullp(x) (x == NULL) -#define or(x,y) (x || y) -#define and(x,y) (x && y) - -/* Define general object type. */ - -typedef void *object; - -#define type_of(x) (((list) x)->tag) -#define forward(x) (((list) x)->cons_car) - -/* Define value types. - Depending on the underlying architecture, compiler, etc these types - have extra least significant bits that can be used to mark them as - values instead of objects (IE, pointer to a tagged object). - On many machines, addresses are multiples of four, leaving the two - least significant bits free - according to lisp in small pieces. - - experimenting with chars below: -*/ -#define obj_is_char(x) ((unsigned long)(x) & (unsigned long)1) -#define obj_obj2char(x) (char)((long)(x)>>1) -#define obj_char2obj(c) ((void *)(((c)<<1) | 1)) - -#define is_value_type(x) obj_is_char(x) -#define is_object_type(x) (x && !is_value_type(x)) - -/* Define function type. */ - -typedef void (*function_type)(); - -/* Define C-variable integration type */ -typedef struct {tag_type tag; object *pvar;} cvar_type; -typedef cvar_type *cvar; -#define make_cvar(n,v) cvar_type n; n.tag = cvar_tag; n.pvar = v; - -/* Define boolean type. */ -typedef struct {const tag_type tag; const char *pname;} boolean_type; -typedef boolean_type *boolean; - -#define boolean_pname(x) (((boolean_type *) x)->pname) - -#define defboolean(name,pname) \ -static boolean_type name##_boolean = {boolean_tag, #pname}; \ -static const object boolean_##name = &name##_boolean - -/* Define symbol type. */ - -typedef struct {const tag_type tag; const char *pname; object plist;} symbol_type; -typedef symbol_type *symbol; - -#define symbol_pname(x) (((symbol_type *) x)->pname) -#define symbol_plist(x) (((symbol_type *) x)->plist) - -#define defsymbol(name,pname) \ -static symbol_type name##_symbol = {symbol_tag, #pname, nil}; \ -static const object quote_##name = &name##_symbol - -/* Define numeric types */ -typedef struct {tag_type tag; int value;} integer_type; -#define make_int(n,v) integer_type n; n.tag = integer_tag; n.value = v; -typedef struct {tag_type tag; double value;} double_type; -#define make_double(n,v) double_type n; n.tag = double_tag; n.value = v; - -/* Define string type */ -typedef struct {tag_type tag; char *str;} string_type; -#define make_string(cv,s) string_type cv; cv.tag = string_tag; \ -{ int len = strlen(s); cv.str = dhallocp; \ - if ((dhallocp + len + 1) >= dhbottom + global_heap_size) { \ - printf("Fatal error: data heap overflow\n"); exit(1); } \ - memcpy(dhallocp, s, len + 1); dhallocp += len + 1; } - -/* I/O types */ - -// TODO: FILE* may not be good enough -// consider http://stackoverflow.com/questions/6206893/how-to-implement-char-ready-in-c -// TODO: a simple wrapper around FILE may not be good enough long-term -// TODO: how exactly mode will be used. need to know r/w, bin/txt -typedef struct {tag_type tag; FILE *fp; int mode;} port_type; -#define make_port(p,f,m) port_type p; p.tag = port_tag; p.fp = f; p.mode = m; - static symbol_type __EOF = {eof_tag, "", nil}; // symbol_type in lieu of custom type static const object Cyc_EOF = &__EOF; -/* Define cons type. */ -typedef struct {tag_type tag; object cons_car,cons_cdr;} cons_type; -typedef cons_type *list; - -#define car(x) (((list) x)->cons_car) -#define cdr(x) (((list) x)->cons_cdr) -#define caar(x) (car(car(x))) -#define cadr(x) (car(cdr(x))) -#define cdar(x) (cdr(car(x))) -#define cddr(x) (cdr(cdr(x))) -#define caaar(x) (car(car(car(x)))) -#define caadr(x) (car(car(cdr(x)))) -#define cadar(x) (car(cdr(car(x)))) -#define caddr(x) (car(cdr(cdr(x)))) -#define cdaar(x) (cdr(car(car(x)))) -#define cdadr(x) (cdr(car(cdr(x)))) -#define cddar(x) (cdr(cdr(car(x)))) -#define cdddr(x) (cdr(cdr(cdr(x)))) -#define caaaar(x) (car(car(car(car(x))))) -#define caaadr(x) (car(car(car(cdr(x))))) -#define caadar(x) (car(car(cdr(car(x))))) -#define caaddr(x) (car(car(cdr(cdr(x))))) -#define cadaar(x) (car(cdr(car(car(x))))) -#define cadadr(x) (car(cdr(car(cdr(x))))) -#define caddar(x) (car(cdr(cdr(car(x))))) -#define cadddr(x) (car(cdr(cdr(cdr(x))))) -#define cdaaar(x) (cdr(car(car(car(x))))) -#define cdaadr(x) (cdr(car(car(cdr(x))))) -#define cdadar(x) (cdr(car(cdr(car(x))))) -#define cdaddr(x) (cdr(car(cdr(cdr(x))))) -#define cddaar(x) (cdr(cdr(car(car(x))))) -#define cddadr(x) (cdr(cdr(car(cdr(x))))) -#define cdddar(x) (cdr(cdr(cdr(car(x))))) -#define cddddr(x) (cdr(cdr(cdr(cdr(x))))) - -#define make_cons(n,a,d) \ -cons_type n; n.tag = cons_tag; n.cons_car = a; n.cons_cdr = d; - -#define atom(x) ((x == NULL) || (((cons_type *) x)->tag != cons_tag)) - -/* Closure types. (I don't trust compilers to optimize vector refs.) */ - -typedef struct {tag_type tag; function_type fn;} closure0_type; -typedef struct {tag_type tag; function_type fn; object elt1;} closure1_type; -typedef struct {tag_type tag; function_type fn; object elt1,elt2;} closure2_type; -typedef struct {tag_type tag; function_type fn; object elt1,elt2,elt3;} closure3_type; -typedef struct {tag_type tag; function_type fn; object elt1,elt2,elt3,elt4;} closure4_type; -typedef struct {tag_type tag; function_type fn; int num_elt; object *elts;} closureN_type; - -typedef closure0_type *closure0; -typedef closure1_type *closure1; -typedef closure2_type *closure2; -typedef closure3_type *closure3; -typedef closure4_type *closure4; -typedef closureN_type *closureN; -typedef closure0_type *closure; - -#define mclosure0(c,f) closure0_type c; c.tag = closure0_tag; c.fn = f; -#define mclosure1(c,f,a) closure1_type c; c.tag = closure1_tag; \ - c.fn = f; c.elt1 = a; -#define mclosure2(c,f,a1,a2) closure2_type c; c.tag = closure2_tag; \ - c.fn = f; c.elt1 = a1; c.elt2 = a2; -#define mclosure3(c,f,a1,a2,a3) closure3_type c; c.tag = closure3_tag; \ - c.fn = f; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3; -#define mclosure4(c,f,a1,a2,a3,a4) closure4_type c; c.tag = closure4_tag; \ - c.fn = f; c.elt1 = a1; c.elt2 = a2; c.elt3 = a3; c.elt4 = a4; -#define setq(x,e) x = e - -#define DEBUG_mclosure0(c, f) closureN_type c; c.tag = closureN_tag; c.fn = f; \ - c.num_elt = 0; c.elts = (object *)alloca(sizeof(object) * c.num_elt); -#define DEBUG_mclosure1(c, f, a1) closureN_type c; c.tag = closureN_tag; c.fn = f; \ - c.num_elt = 1; c.elts = (object *)alloca(sizeof(object) * c.num_elt); c.elts[0] = a1; -#define DEBUG_mclosure2(c, f, a1, a2) closureN_type c; c.tag = closureN_tag; c.fn = f; \ - c.num_elt = 2; c.elts = (object *)alloca(sizeof(object) * c.num_elt); c.elts[0] = a1; c.elts[1] = a2; -#define DEBUG_mclosure3(c, f, a1, a2, a3) closureN_type c; c.tag = closureN_tag; c.fn = f; \ - c.num_elt = 3; c.elts = (object *)alloca(sizeof(object) * c.num_elt); c.elts[0] = a1; c.elts[1] = a2; c.elts[2] = a3; - - -#define mlist1(e1) (mcons(e1,nil)) -#define mlist2(e2,e1) (mcons(e2,mlist1(e1))) -#define mlist3(e3,e2,e1) (mcons(e3,mlist2(e2,e1))) -#define mlist4(e4,e3,e2,e1) (mcons(e4,mlist3(e3,e2,e1))) -#define mlist5(e5,e4,e3,e2,e1) (mcons(e5,mlist4(e4,e3,e2,e1))) -#define mlist6(e6,e5,e4,e3,e2,e1) (mcons(e6,mlist5(e5,e4,e3,e2,e1))) -#define mlist7(e7,e6,e5,e4,e3,e2,e1) (mcons(e7,mlist6(e6,e5,e4,e3,e2,e1))) - -#define rule(lhs,rhs) (mlist3(quote_equal,lhs,rhs)) - -#define make_cell(n,a) make_cons(n,a,nil); static object cell_get(object cell){ return car(cell); } @@ -311,10 +64,6 @@ static object cell_set(object cell, object value){ var = args; \ } -typedef void (*function_type_va)(int, object, object, object, ...); -static void dispatch(int argc, function_type func, object clo, object cont, object args); -static void dispatch_va(int argc, function_type_va func, object clo, object cont, object args); - /* Prototypes for Lisp built-in functions. */ static object Cyc_global_variables = nil; @@ -352,23 +101,11 @@ static object memqp(object,list); static char *transport(char *,int); static void GC(closure,object*,int) never_returns; static void main_main(long stack_size,long heap_size,char *stack_base) never_returns; -//static long long_arg(int argc,char **argv,char *name,long dval); +static long long_arg(int argc,char **argv,char *name,long dval); void dispatch(int argc, function_type func, object clo, object cont, object args); void dispatch_va(int argc, function_type_va func, object clo, object cont, object args); -/* Primitive types */ -//typedef void (*prim_function_type)(); -typedef struct {tag_type tag; const char *pname; function_type fn;} primitive_type; -typedef primitive_type *primitive; - -#define defprimitive(name, pname, fnc) \ -static primitive_type name##_primitive = {primitive_tag, #pname, fnc}; \ -static const object primitive_##name = &name##_primitive - -#define prim(x) (x && ((primitive)x)->tag == primitive_tag) -#define prim_name(x) (((primitive_type *) x)->pname) - /* Symbol Table */ /* Notes for the symbol table @@ -1864,13 +1601,12 @@ static void main_main (stack_size,heap_size,stack_base) /* */ printf("main: your setjmp and/or longjmp are broken.\n"); exit(0);}} -/* static long long_arg(argc,argv,name,dval) int argc; char **argv; char *name; long dval; {int j; for(j=1;(j+1) 65 - -(write - (call/cc - (lambda (k) - (with-exception-handler - (lambda (x) - (display "condition: ") - (write x) - ;(newline) - (k 'exception)) - (lambda () - (+ 1 (raise 'an-error))))))) - -(with-exception-handler - (lambda (x) - (display "something went wrong\n")) - (lambda () - (+ 1 (raise 'an-error)))) - -;(define test '(a b)) -;(set-car! test '(1 2 3)) -;(write test) -;(raise 'done) -;(define (loop n) -; (cond -; ((= n 10000) -; (write test) -; (loop 0)) -; (else -; (loop (+ n 1))))) -;(loop 0) +;; (write +;; (with-exception-handler +;; (lambda (con) +;; (cond +;; ((string? con) +;; (display con)) +;; (else +;; (display "a warning has been issued"))) +;; 42) +;; (lambda () +;; (+ (raise-continuable "should be a number") 23) +;; ))) +;; ;prints: should be a number +;; ;=> 65 +;; +;; (write +;; (call/cc +;; (lambda (k) +;; (with-exception-handler +;; (lambda (x) +;; (display "condition: ") +;; (write x) +;; ;(newline) +;; (k 'exception)) +;; (lambda () +;; (+ 1 (raise 'an-error))))))) +;; +;; (with-exception-handler +;; (lambda (x) +;; (display "something went wrong\n")) +;; (lambda () +;; (+ 1 (raise 'an-error)))) +;; +;; ;(define test '(a b)) +;; ;(set-car! test '(1 2 3)) +;; ;(write test) +;; ;(raise 'done) +;; ;(define (loop n) +;; ; (cond +;; ; ((= n 10000) +;; ; (write test) +;; ; (loop 0)) +;; ; (else +;; ; (loop (+ n 1))))) +;; ;(loop 0)