mirror of
https://github.com/justinethier/cyclone.git
synced 2025-07-09 14:07:34 +02:00
WIP - separating runtime code
This commit is contained in:
Justin Ethier
parent
c41608af7c
commit
dd8b1852f7
5 changed files with 321 additions and 315 deletions
4
Makefile
4
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;)
|
||||
|
|
|
|||
270
cyclone.h
Normal file
270
cyclone.h
Normal 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 */
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#include "runtime.h"
|
||||
#include "cyclone.h"
|
||||
|
||||
/**
|
||||
* Take list of args and call a function with them as params.
|
||||
|
|
|
|||
270
runtime.h
270
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 <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 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)<argc;j += 2)
|
||||
if (strcmp(name,argv[j]) == 0)
|
||||
return(atol(argv[j+1]));
|
||||
return(dval);} */
|
||||
return(dval);}
|
||||
|
||||
#endif /* CYCLONE_RUNTIME_H */
|
||||
|
|
|
|||
90
test.scm
90
test.scm
|
|
@ -6,48 +6,48 @@
|
|||
(return #t))))
|
||||
(write (test))
|
||||
|
||||
(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)
|
||||
;; (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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue