Fcalva/cyclone
1
0
Fork 0
mirror of https://github.com/justinethier/cyclone.git synced 2025-07-09 14:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

WIP - separating runtime code

Browse source
This commit is contained in:
Justin Ethier 2015-03-30 13:40:41 -04:00
parent c41608af7c
commit dd8b1852f7
5 changed files with 321 additions and 315 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Makefile
View file

@ -21,7 +21,7 @@ libcyclone.a: runtime.c runtime.h
#gcc -static main.c -L. -lmean -o statically_linked #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) #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 csc cyclone.scm
.PHONY: test .PHONY: test
@ -37,5 +37,5 @@ tags:
.PHONY: clean .PHONY: clean
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;) $(foreach f,$(TESTSCM), rm -rf $(f) $(f).c tests/$(f).c;)

270
cyclone.h Normal file
View file

@ -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 <stdlib.h>
#include <stdio.h>
#include <time.h>
#include <setjmp.h>
#include <stdarg.h>
#include <string.h>
#ifndef CLOCKS_PER_SEC
/* gcc doesn't define this, even though ANSI requires it in <time.h>.. */
#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 */

2
runtime.c
View file

@ -1,4 +1,4 @@
#include "runtime.h" #include "cyclone.h"
/** /**
* Take list of args and call a function with them as params. * Take list of args and call a function with them as params.

270
runtime.h
View file

@ -9,261 +9,14 @@
#ifndef CYCLONE_RUNTIME_H #ifndef CYCLONE_RUNTIME_H
#define CYCLONE_RUNTIME_H #define CYCLONE_RUNTIME_H
/* Debug GC flag */ #include "cyclone.h"
#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
long global_stack_size; long global_stack_size;
long global_heap_size; long global_heap_size;
/* Define size of Lisp tags. Options are "short" or "long". */
typedef long tag_type;
#include <stdlib.h>
#include <stdio.h>
#include <time.h>
#include <setjmp.h>
#include <stdarg.h>
#include <string.h>
#ifndef CLOCKS_PER_SEC
/* gcc doesn't define this, even though ANSI requires it in <time.h>.. */
#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 symbol_type __EOF = {eof_tag, "", nil}; // symbol_type in lieu of custom type
static const object Cyc_EOF = &__EOF; 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){ static object cell_get(object cell){
return car(cell); return car(cell);
} }
@ -311,10 +64,6 @@ static object cell_set(object cell, object value){
var = args; \ 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. */ /* Prototypes for Lisp built-in functions. */
static object Cyc_global_variables = nil; static object Cyc_global_variables = nil;
@ -352,23 +101,11 @@ static object memqp(object,list);
static char *transport(char *,int); static char *transport(char *,int);
static void GC(closure,object*,int) never_returns; static void GC(closure,object*,int) never_returns;
static void main_main(long stack_size,long heap_size,char *stack_base) 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(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); 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 */ /* Symbol Table */
/* Notes for the 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);}} printf("main: your setjmp and/or longjmp are broken.\n"); exit(0);}}
/*
static long long_arg(argc,argv,name,dval) static long long_arg(argc,argv,name,dval)
int argc; char **argv; char *name; long dval; int argc; char **argv; char *name; long dval;
{int j; {int j;
for(j=1;(j+1)<argc;j += 2) for(j=1;(j+1)<argc;j += 2)
if (strcmp(name,argv[j]) == 0) if (strcmp(name,argv[j]) == 0)
return(atol(argv[j+1])); return(atol(argv[j+1]));
return(dval);} */ return(dval);}
#endif /* CYCLONE_RUNTIME_H */ #endif /* CYCLONE_RUNTIME_H */

90
test.scm
View file

@ -6,48 +6,48 @@
(return #t)))) (return #t))))
(write (test)) (write (test))
(write ;; (write
(with-exception-handler ;; (with-exception-handler
(lambda (con) ;; (lambda (con)
(cond ;; (cond
((string? con) ;; ((string? con)
(display con)) ;; (display con))
(else ;; (else
(display "a warning has been issued"))) ;; (display "a warning has been issued")))
42) ;; 42)
(lambda () ;; (lambda ()
(+ (raise-continuable "should be a number") 23) ;; (+ (raise-continuable "should be a number") 23)
))) ;; )))
;prints: should be a number ;; ;prints: should be a number
;=> 65 ;; ;=> 65
;;
(write ;; (write
(call/cc ;; (call/cc
(lambda (k) ;; (lambda (k)
(with-exception-handler ;; (with-exception-handler
(lambda (x) ;; (lambda (x)
(display "condition: ") ;; (display "condition: ")
(write x) ;; (write x)
;(newline) ;; ;(newline)
(k 'exception)) ;; (k 'exception))
(lambda () ;; (lambda ()
(+ 1 (raise 'an-error))))))) ;; (+ 1 (raise 'an-error)))))))
;;
(with-exception-handler ;; (with-exception-handler
(lambda (x) ;; (lambda (x)
(display "something went wrong\n")) ;; (display "something went wrong\n"))
(lambda () ;; (lambda ()
(+ 1 (raise 'an-error)))) ;; (+ 1 (raise 'an-error))))
;;
;(define test '(a b)) ;; ;(define test '(a b))
;(set-car! test '(1 2 3)) ;; ;(set-car! test '(1 2 3))
;(write test) ;; ;(write test)
;(raise 'done) ;; ;(raise 'done)
;(define (loop n) ;; ;(define (loop n)
; (cond ;; ; (cond
; ((= n 10000) ;; ; ((= n 10000)
; (write test) ;; ; (write test)
; (loop 0)) ;; ; (loop 0))
; (else ;; ; (else
; (loop (+ n 1))))) ;; ; (loop (+ n 1)))))
;(loop 0) ;; ;(loop 0)