mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-09 14:07:34 +02:00
adding explicit renaming macros and a bunch of library code
This commit is contained in:
Alex Shinn
parent
a0c78ad611
commit
63d337491a
8 changed files with 305 additions and 159 deletions
2
Makefile
2
Makefile
|
|
@ -13,7 +13,7 @@ GC_OBJ=./gc/gc.a
|
|||
sexp.o: sexp.c sexp.h config.h defaults.h Makefile
|
||||
gcc -c $(CFLAGS) -o $@ $<
|
||||
|
||||
eval.o: eval.c debug.c eval.h sexp.h config.h defaults.h Makefile
|
||||
eval.o: eval.c debug.c opcodes.c eval.h sexp.h config.h defaults.h Makefile
|
||||
gcc -c $(CFLAGS) -o $@ $<
|
||||
|
||||
# main.o: main.c eval.h sexp.h config.h Makefile
|
||||
|
|
|
|||
14
debug.c
14
debug.c
|
|
@ -4,14 +4,14 @@
|
|||
|
||||
static const char* reverse_opcode_names[] =
|
||||
{"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL",
|
||||
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "EVAL", "JUMP_UNLESS", "JUMP",
|
||||
"PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET",
|
||||
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP_UNLESS",
|
||||
"JUMP", "PUSH", "DROP", "STACK_REF", "LOCAL_REF", "LOCAL_SET",
|
||||
"CLOSURE_REF", "VECTOR_REF", "VECTOR_SET", "STRING_REF", "STRING_SET",
|
||||
"MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP",
|
||||
"SYMBOLP", "CHARP", "EOFP", "TYPEP",
|
||||
"CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", "MUL", "DIV",
|
||||
"QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", "DISPLAY", "WRITE",
|
||||
"WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE",
|
||||
"MAKE_PROCEDURE", "MAKE_VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP",
|
||||
"EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB",
|
||||
"MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ",
|
||||
"DISPLAY", "WRITE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ",
|
||||
"READ_CHAR", "RET", "DONE",
|
||||
};
|
||||
|
||||
void disasm (sexp bc, sexp out) {
|
||||
|
|
|
|||
140
eval.c
140
eval.c
|
|
@ -88,7 +88,7 @@ static sexp env_global_ref(sexp e, sexp key, sexp dflt) {
|
|||
static void env_define(sexp e, sexp key, sexp value) {
|
||||
sexp cell = sexp_assq(key, sexp_env_bindings(e));
|
||||
if (cell != SEXP_FALSE)
|
||||
sexp_cdar(cell) = value;
|
||||
sexp_cdr(cell) = value;
|
||||
else
|
||||
sexp_push(sexp_env_bindings(e), sexp_cons(key, value));
|
||||
}
|
||||
|
|
@ -278,6 +278,25 @@ static sexp sexp_identifierp (sexp x) {
|
|||
return sexp_make_boolean(sexp_idp(x));
|
||||
}
|
||||
|
||||
static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) {
|
||||
sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE;
|
||||
if (sexp_synclop(id1)) {
|
||||
e1 = sexp_synclo_env(id1);
|
||||
id1 = sexp_synclo_expr(id1);
|
||||
}
|
||||
if (sexp_synclop(id2)) {
|
||||
e2 = sexp_synclo_env(id2);
|
||||
id2 = sexp_synclo_expr(id2);
|
||||
}
|
||||
cell = env_cell(e1, id1);
|
||||
if (sexp_lambdap(sexp_cdr(cell)))
|
||||
lam1 = sexp_cdr(cell);
|
||||
cell = env_cell(e2, id2);
|
||||
if (sexp_lambdap(sexp_cdr(cell)))
|
||||
lam2 = sexp_cdr(cell);
|
||||
return sexp_make_boolean((id1 == id2) && (lam1 == lam2));
|
||||
}
|
||||
|
||||
/************************* the compiler ***************************/
|
||||
|
||||
static sexp sexp_compile_error(char *message, sexp irritants) {
|
||||
|
|
@ -298,10 +317,14 @@ static sexp analyze (sexp x, sexp context) {
|
|||
sexp op, cell, res;
|
||||
loop:
|
||||
if (sexp_pairp(x)) {
|
||||
if (! sexp_listp(x)) {
|
||||
if (sexp_listp(x) == SEXP_FALSE) {
|
||||
res = sexp_compile_error("dotted list in source", sexp_list1(x));
|
||||
} else if (sexp_idp(sexp_car(x))) {
|
||||
cell = env_cell(sexp_context_env(context), sexp_car(x));
|
||||
if (sexp_synclop(sexp_car(x)))
|
||||
cell = env_cell(sexp_synclo_env(sexp_car(x)),
|
||||
sexp_synclo_expr(sexp_car(x)));
|
||||
else
|
||||
cell = env_cell(sexp_context_env(context), sexp_car(x));
|
||||
if (! cell) return analyze_app(x, context);
|
||||
op = sexp_cdr(cell);
|
||||
if (sexp_corep(op)) {
|
||||
|
|
@ -365,7 +388,7 @@ static sexp analyze_lambda (sexp x, sexp context) {
|
|||
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
|
||||
return sexp_compile_error("bad lambda syntax", sexp_list1(x));
|
||||
for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
if (! sexp_symbolp(sexp_car(ls)))
|
||||
if (! sexp_idp(sexp_car(ls)))
|
||||
return sexp_compile_error("non-symbol parameter", sexp_list1(x));
|
||||
else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE)
|
||||
return sexp_compile_error("duplicate parameter", sexp_list1(x));
|
||||
|
|
@ -757,7 +780,8 @@ static void generate_lambda (sexp lambda, sexp context) {
|
|||
}
|
||||
}
|
||||
generate(sexp_lambda_body(lambda), ctx);
|
||||
flags = sexp_make_integer(sexp_listp(sexp_lambda_params(lambda)) ? 0 : 1);
|
||||
flags = sexp_make_integer((sexp_listp(sexp_lambda_params(lambda))==SEXP_FALSE)
|
||||
? 1 : 0);
|
||||
len = sexp_length(sexp_lambda_params(lambda));
|
||||
bc = finalize_bytecode(ctx);
|
||||
if (sexp_nullp(fv)) {
|
||||
|
|
@ -1404,91 +1428,9 @@ static struct sexp_struct core_forms[] = {
|
|||
{.tag=SEXP_CORE, .value={.core={CORE_LETREC_SYNTAX, "letrec-syntax"}}},
|
||||
};
|
||||
|
||||
static struct sexp_struct opcodes[] = {
|
||||
#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}}
|
||||
#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL)
|
||||
#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f)
|
||||
#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f)
|
||||
#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f)
|
||||
#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f)
|
||||
#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL)
|
||||
_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL),
|
||||
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL),
|
||||
_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL),
|
||||
_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL),
|
||||
_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL),
|
||||
_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL),
|
||||
_FN1(0, "identifier?", sexp_identifierp),
|
||||
_FN1(SEXP_PAIR, "length", sexp_length),
|
||||
_FN1(SEXP_PAIR, "reverse", sexp_reverse),
|
||||
_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
|
||||
_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file),
|
||||
_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file),
|
||||
_FN1(SEXP_IPORT, "close-input-port", sexp_close_port),
|
||||
_FN1(SEXP_OPORT, "close-output-port", sexp_close_port),
|
||||
_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env),
|
||||
_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env),
|
||||
_FN2(0, SEXP_ENV, "%load", sexp_load),
|
||||
#if USE_MATH
|
||||
_FN1(0, "exp", sexp_exp),
|
||||
_FN1(0, "log", sexp_log),
|
||||
_FN1(0, "sin", sexp_sin),
|
||||
_FN1(0, "cos", sexp_cos),
|
||||
_FN1(0, "tan", sexp_tan),
|
||||
_FN1(0, "asin", sexp_asin),
|
||||
_FN1(0, "acos", sexp_acos),
|
||||
_FN1(0, "atan", sexp_atan),
|
||||
_FN1(0, "sqrt", sexp_sqrt),
|
||||
#endif
|
||||
_FN2(0, SEXP_PAIR, "memq", sexp_memq),
|
||||
_FN2(0, SEXP_PAIR, "assq", sexp_assq),
|
||||
_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo),
|
||||
_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT),
|
||||
_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
|
||||
_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
|
||||
_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE),
|
||||
_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
|
||||
};
|
||||
#include "opcodes.c"
|
||||
|
||||
static sexp standard_env_syms_interned_p = 0;
|
||||
static int standard_env_syms_interned_p = 0;
|
||||
|
||||
static sexp sexp_make_null_env (sexp version) {
|
||||
sexp_uint_t i;
|
||||
|
|
@ -1502,16 +1444,17 @@ static sexp sexp_make_null_env (sexp version) {
|
|||
|
||||
static sexp sexp_make_standard_env (sexp version) {
|
||||
sexp_uint_t i;
|
||||
sexp e = sexp_make_null_env(version), cell, sym;
|
||||
sexp e = sexp_make_null_env(version), op, cell, sym;
|
||||
for (i=0; i<(sizeof(opcodes)/sizeof(opcodes[0])); i++) {
|
||||
op = &opcodes[i];
|
||||
if ((! standard_env_syms_interned_p)
|
||||
&& sexp_opcode_opt_param_p(&opcodes[i])
|
||||
&& sexp_opcode_data(&opcodes[i])) {
|
||||
sym = sexp_intern((char*)sexp_opcode_data(&opcodes[i]));
|
||||
&& sexp_opcode_opt_param_p(op)
|
||||
&& sexp_opcode_data(op)) {
|
||||
sym = sexp_intern((char*)sexp_opcode_data(op));
|
||||
cell = env_cell_create(e, sym, SEXP_UNDEF);
|
||||
sexp_opcode_data(&opcodes[i]) = cell;
|
||||
sexp_opcode_data(op) = cell;
|
||||
}
|
||||
env_define(e, sexp_intern(sexp_opcode_name(&opcodes[i])), &opcodes[i]);
|
||||
env_define(e, sexp_intern(sexp_opcode_name(op)), op);
|
||||
}
|
||||
env_define(e, the_cur_in_symbol, sexp_make_input_port(stdin));
|
||||
env_define(e, the_cur_out_symbol, sexp_make_output_port(stdout));
|
||||
|
|
@ -1523,7 +1466,6 @@ static sexp sexp_make_standard_env (sexp version) {
|
|||
|
||||
/************************** eval interface ****************************/
|
||||
|
||||
/* args ... n ret-ip ret-cp ret-fp */
|
||||
sexp apply(sexp proc, sexp args, sexp context) {
|
||||
sexp *stack = sexp_context_stack(context), ls;
|
||||
sexp_sint_t top = sexp_context_top(context), offset;
|
||||
|
|
@ -1558,9 +1500,9 @@ sexp compile (sexp x, sexp context) {
|
|||
sexp eval_in_context (sexp obj, sexp context) {
|
||||
sexp thunk = compile(obj, context);
|
||||
if (sexp_exceptionp(thunk)) {
|
||||
sexp_print_exception(obj, env_global_ref(sexp_context_env(context),
|
||||
the_cur_err_symbol,
|
||||
SEXP_FALSE));
|
||||
sexp_print_exception(thunk, env_global_ref(sexp_context_env(context),
|
||||
the_cur_err_symbol,
|
||||
SEXP_FALSE));
|
||||
return SEXP_UNDEF;
|
||||
}
|
||||
return apply(thunk, SEXP_NULL, context);
|
||||
|
|
|
|||
1
eval.h
1
eval.h
|
|
@ -68,6 +68,7 @@ enum opcode_names {
|
|||
OP_FCALL1,
|
||||
OP_FCALL2,
|
||||
OP_FCALL3,
|
||||
OP_FCALL4,
|
||||
OP_EVAL,
|
||||
OP_JUMP_UNLESS,
|
||||
OP_JUMP,
|
||||
|
|
|
|||
135
init.scm
135
init.scm
|
|
@ -1,22 +1,21 @@
|
|||
|
||||
;; let* cond case delay and do
|
||||
;; cond case delay do
|
||||
;; quasiquote let-syntax
|
||||
;; letrec-syntax syntax-rules eqv? equal? not boolean? number?
|
||||
;; letrec-syntax syntax-rules not boolean? number?
|
||||
;; complex? real? rational? integer? exact? inexact?
|
||||
;; positive? negative? odd? even? max min quotient remainder
|
||||
;; modulo numerator denominator floor ceiling truncate round
|
||||
;; rationalize sqrt expt
|
||||
;; rationalize expt
|
||||
;; make-rectangular make-polar real-part imag-part magnitude angle
|
||||
;; exact->inexact inexact->exact number->string string->number
|
||||
;; list? list-tail list-ref memv
|
||||
;; member assv assoc symbol->string string->symbol
|
||||
;; symbol->string string->symbol
|
||||
;; char-alphabetic? char-numeric? char-whitespace?
|
||||
;; char-upper-case? char-lower-case? char->integer integer->char
|
||||
;; char-upcase char-downcase make-string string string-length
|
||||
;; string=? string-ci=? string<? string>?
|
||||
;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
|
||||
;; substring string-append string->list list->string string-copy
|
||||
;; string-fill! make-vector vector vector-length
|
||||
;; string-fill! vector vector-length
|
||||
;; vector->list list->vector vector-fill! procedure? apply
|
||||
;; map for-each force call-with-current-continuation values
|
||||
;; call-with-values dynamic-wind scheme-report-environment
|
||||
|
|
@ -24,8 +23,7 @@
|
|||
;; current-input-port current-output-port
|
||||
;; with-input-from-file with-output-to-file open-input-file
|
||||
;; open-output-file close-input-port close-output-port
|
||||
;; peek-char eof-object? char-ready?
|
||||
;; eval
|
||||
;; peek-char char-ready?
|
||||
|
||||
;; provide c[ad]{2,4}r
|
||||
|
||||
|
|
@ -34,14 +32,14 @@
|
|||
(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 (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)))))
|
||||
|
|
@ -62,6 +60,33 @@
|
|||
|
||||
(define (list . args) args)
|
||||
|
||||
(define (list-tail ls k)
|
||||
(if (zero? k)
|
||||
ls
|
||||
(list-tail (cdr ls) (- k 1))))
|
||||
|
||||
(define (list-ref ls k) (car (list-tail ls k)))
|
||||
|
||||
(define eqv? equal?)
|
||||
|
||||
(define (member obj ls)
|
||||
(if (null? ls)
|
||||
#f
|
||||
(if (equal? obj (car ls))
|
||||
ls
|
||||
(member obj (cdr ls)))))
|
||||
|
||||
(define memv member)
|
||||
|
||||
(define (assoc obj ls)
|
||||
(if (null? ls)
|
||||
#f
|
||||
(if (equal? obj (caar ls))
|
||||
ls
|
||||
(member obj (cdr ls)))))
|
||||
|
||||
(define assv assoc)
|
||||
|
||||
(define (append-reverse a b)
|
||||
(if (pair? a)
|
||||
(append-reverse (cdr a) (cons (car a) b))
|
||||
|
|
@ -114,30 +139,74 @@
|
|||
(lambda (expr use-env mac-env)
|
||||
(make-syntactic-closure use-env '() (f expr mac-env)))))
|
||||
|
||||
(define-syntax let
|
||||
(lambda (expr use-env mac-env)
|
||||
(cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr)))
|
||||
(map cadr (cadr expr)))))
|
||||
(define er-macro-transformer
|
||||
(lambda (f)
|
||||
(lambda (expr use-env mac-env)
|
||||
((lambda (rename compare) (f expr rename compare))
|
||||
((lambda (renames)
|
||||
(lambda (identifier)
|
||||
((lambda (cell)
|
||||
(if cell
|
||||
(cdr cell)
|
||||
((lambda (name)
|
||||
(set! renames (cons (cons identifier name) renames))
|
||||
name)
|
||||
(make-syntactic-closure mac-env '() identifier))))
|
||||
(assq identifier renames))))
|
||||
'())
|
||||
(lambda (x y) (identifier=? use-env x use-env y))))))
|
||||
|
||||
(define-syntax letrec
|
||||
(lambda (expr use-env mac-env)
|
||||
(list
|
||||
(cons 'lambda
|
||||
(cons '()
|
||||
(append (map (lambda (x) (cons 'define x)) (cadr expr))
|
||||
(cddr expr)))))))
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(list
|
||||
(cons (rename 'lambda)
|
||||
(cons '()
|
||||
(append (map (lambda (x) (cons (rename 'define) x)) (cadr expr))
|
||||
(cddr expr))))))))
|
||||
|
||||
(define-syntax let
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (identifier? (cadr expr))
|
||||
(list (rename 'letrec)
|
||||
(list (list (cadr expr)
|
||||
(cons (rename 'lambda)
|
||||
(cons (map car (caddr expr))
|
||||
(cdddr expr)))))
|
||||
(cons (cadr expr) (map cadr (caddr expr))))
|
||||
(cons (cons (rename 'lambda) (cons (map car (cadr expr)) (cddr expr)))
|
||||
(map cadr (cadr expr)))))))
|
||||
|
||||
(define-syntax let*
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cadr expr))
|
||||
(cons (rename 'begin) (cddr expr))
|
||||
(list (rename 'let)
|
||||
(list (caadr expr))
|
||||
(cons (rename 'let*) (cons (cdadr expr) (cddr expr))))))))
|
||||
|
||||
(define-syntax or
|
||||
(sc-macro-transformer
|
||||
(lambda (expr use-env)
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#f
|
||||
(list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
|
||||
(list (rename 'if) (rename 'tmp)
|
||||
(rename 'tmp)
|
||||
(cons (rename 'or) (cddr expr))))))))
|
||||
|
||||
(define-syntax and
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(if (null? (cdr expr))
|
||||
#t
|
||||
(if (null? (cddr expr))
|
||||
(make-syntactic-closure use-env '() (cadr expr))
|
||||
(list 'let (list (list 'tmp (make-syntactic-closure use-env '() (cadr expr))))
|
||||
(list 'if 'tmp
|
||||
'tmp
|
||||
(make-syntactic-closure use-env '() (cons 'or (cddr expr))))))))))
|
||||
(cadr expr)
|
||||
(list (rename 'if) (cadr expr)
|
||||
(cons (rename 'and) (cddr expr))
|
||||
#f))))))
|
||||
|
||||
;; char utils
|
||||
|
||||
|
|
|
|||
90
opcodes.c
Normal file
90
opcodes.c
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
|
||||
#define _OP(c,o,n,m,t,u,i,s,d,p) {.tag=SEXP_OPCODE, .value={.opcode={c, o, n, m, t, u, i, s, d, p}}}
|
||||
#define _FN(o,n,t,u,s,f) _OP(OPC_FOREIGN, o, n, 0, t, u, 0, s, (sexp)f, NULL)
|
||||
#define _FN0(s, f) _FN(OP_FCALL0, 0, 0, 0, s, f)
|
||||
#define _FN1(t, s, f) _FN(OP_FCALL1, 1, t, 0, s, f)
|
||||
#define _FN2(t, u, s, f) _FN(OP_FCALL2, 2, t, u, s, f)
|
||||
#define _FN3(t, u, s, f) _FN(OP_FCALL3, 3, t, u, s, f)
|
||||
#define _FN4(t, u, s, f) _FN(OP_FCALL4, 4, t, u, s, f)
|
||||
#define _PARAM(n,a,t) _OP(OPC_PARAMETER, OP_NOOP, 0, 2, t, 0, 0, n, a, NULL)
|
||||
|
||||
static struct sexp_struct opcodes[] = {
|
||||
_OP(OPC_ACCESSOR, OP_CAR, 1, 0, SEXP_PAIR, 0, 0, "car", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_SET_CAR, 2, 0, SEXP_PAIR, 0, 0, "set-car!", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL),
|
||||
_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL),
|
||||
_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL),
|
||||
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL),
|
||||
_OP(OPC_CONSTRUCTOR, OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL),
|
||||
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL),
|
||||
_OP(OPC_GENERIC, OP_APPLY1, 2, 0, SEXP_PROCEDURE, SEXP_PAIR, 0, "apply1", NULL, NULL),
|
||||
_OP(OPC_GENERIC, OP_CALLCC, 1, SEXP_PROCEDURE, 0, 0, 0, "call-with-current-continuation", NULL, NULL),
|
||||
_OP(OPC_GENERIC, OP_ERROR, 1, SEXP_STRING, 0, 0, 0, "error", NULL, NULL),
|
||||
_OP(OPC_IO, OP_WRITE, 1, 3, 0, SEXP_OPORT, 0, "write", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_DISPLAY, 1, 3, 0, SEXP_OPORT, 0, "display", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_WRITE_CHAR, 1, 3, 0, SEXP_OPORT, 0, "write-char", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL),
|
||||
_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL),
|
||||
_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL),
|
||||
_FN2(0, 0, "equal?", sexp_equalp),
|
||||
_FN1(0, "list?", sexp_listp),
|
||||
_FN1(0, "identifier?", sexp_identifierp),
|
||||
_FN4(0, SEXP_ENV, "identifier=?", sexp_identifier_eq),
|
||||
_FN1(SEXP_PAIR, "length", sexp_length),
|
||||
_FN1(SEXP_PAIR, "reverse", sexp_reverse),
|
||||
_FN1(SEXP_PAIR, "list->vector", sexp_list_to_vector),
|
||||
_FN1(SEXP_STRING, "open-input-file", sexp_open_input_file),
|
||||
_FN1(SEXP_STRING, "open-output-file", sexp_open_output_file),
|
||||
_FN1(SEXP_IPORT, "close-input-port", sexp_close_port),
|
||||
_FN1(SEXP_OPORT, "close-output-port", sexp_close_port),
|
||||
_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env),
|
||||
_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env),
|
||||
_FN2(0, SEXP_ENV, "%load", sexp_load),
|
||||
#if USE_MATH
|
||||
_FN1(0, "exp", sexp_exp),
|
||||
_FN1(0, "log", sexp_log),
|
||||
_FN1(0, "sin", sexp_sin),
|
||||
_FN1(0, "cos", sexp_cos),
|
||||
_FN1(0, "tan", sexp_tan),
|
||||
_FN1(0, "asin", sexp_asin),
|
||||
_FN1(0, "acos", sexp_acos),
|
||||
_FN1(0, "atan", sexp_atan),
|
||||
_FN1(0, "sqrt", sexp_sqrt),
|
||||
#endif
|
||||
_FN2(0, SEXP_PAIR, "memq", sexp_memq),
|
||||
_FN2(0, SEXP_PAIR, "assq", sexp_assq),
|
||||
_FN3(SEXP_ENV, SEXP_PAIR, "make-syntactic-closure", sexp_make_synclo),
|
||||
_PARAM("current-input-port", (sexp)"*current-input-port*", SEXP_IPORT),
|
||||
_PARAM("current-output-port", (sexp)"*current-output-port*", SEXP_OPORT),
|
||||
_PARAM("current-error-port", (sexp)"*current-error-port*", SEXP_OPORT),
|
||||
_PARAM("current-error-handler", (sexp)"*current-error-handler*", SEXP_PROCEDURE),
|
||||
_PARAM("interaction-environment", (sexp)"*interaction-environment*", SEXP_ENV),
|
||||
};
|
||||
|
||||
76
sexp.c
76
sexp.c
|
|
@ -91,8 +91,8 @@ void sexp_deep_free (sexp obj) {
|
|||
|
||||
/***************************** exceptions *****************************/
|
||||
|
||||
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants,
|
||||
sexp file, sexp line) {
|
||||
sexp sexp_make_exception (sexp kind, sexp message, sexp irritants,
|
||||
sexp file, sexp line) {
|
||||
sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION);
|
||||
sexp_exception_kind(exn) = kind;
|
||||
sexp_exception_message(exn) = message;
|
||||
|
|
@ -102,11 +102,11 @@ sexp sexp_make_exception(sexp kind, sexp message, sexp irritants,
|
|||
return exn;
|
||||
}
|
||||
|
||||
sexp sexp_print_exception(sexp exn, sexp out) {
|
||||
sexp sexp_print_exception (sexp exn, sexp out) {
|
||||
sexp ls;
|
||||
sexp_write_string("ERROR", out);
|
||||
if (sexp_integerp(sexp_exception_line(exn))
|
||||
&& sexp_exception_line(exn) > sexp_make_integer(0)) {
|
||||
&& (sexp_exception_line(exn) > sexp_make_integer(0))) {
|
||||
sexp_write_string(" on line ", out);
|
||||
sexp_write(sexp_exception_line(exn), out);
|
||||
}
|
||||
|
|
@ -116,7 +116,8 @@ sexp sexp_print_exception(sexp exn, sexp out) {
|
|||
}
|
||||
sexp_write_string(": ", out);
|
||||
sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out);
|
||||
if (sexp_pairp(sexp_exception_irritants(exn))) {
|
||||
if (sexp_exception_irritants(exn)
|
||||
&& sexp_pairp(sexp_exception_irritants(exn))) {
|
||||
if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
|
||||
sexp_write_string(": ", out);
|
||||
sexp_write(sexp_car(sexp_exception_irritants(exn)), out);
|
||||
|
|
@ -136,7 +137,7 @@ sexp sexp_print_exception(sexp exn, sexp out) {
|
|||
return SEXP_UNDEF;
|
||||
}
|
||||
|
||||
static sexp sexp_read_error(char *message, sexp irritants, sexp port) {
|
||||
static sexp sexp_read_error (char *message, sexp irritants, sexp port) {
|
||||
sexp name = (sexp_port_name(port)
|
||||
? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE);
|
||||
return sexp_make_exception(the_read_error_symbol,
|
||||
|
|
@ -148,17 +149,17 @@ static sexp sexp_read_error(char *message, sexp irritants, sexp port) {
|
|||
|
||||
/*************************** list utilities ***************************/
|
||||
|
||||
sexp sexp_cons(sexp head, sexp tail) {
|
||||
sexp sexp_cons (sexp head, sexp tail) {
|
||||
sexp pair = sexp_alloc_type(pair, SEXP_PAIR);
|
||||
sexp_car(pair) = head;
|
||||
sexp_cdr(pair) = tail;
|
||||
return pair;
|
||||
}
|
||||
|
||||
int sexp_listp (sexp obj) {
|
||||
sexp sexp_listp (sexp obj) {
|
||||
while (sexp_pairp(obj))
|
||||
obj = sexp_cdr(obj);
|
||||
return (obj == SEXP_NULL);
|
||||
return sexp_make_boolean(obj == SEXP_NULL);
|
||||
}
|
||||
|
||||
sexp sexp_memq (sexp x, sexp ls) {
|
||||
|
|
@ -172,21 +173,21 @@ sexp sexp_memq (sexp x, sexp ls) {
|
|||
|
||||
sexp sexp_assq (sexp x, sexp ls) {
|
||||
while (sexp_pairp(ls))
|
||||
if (x == sexp_caar(ls))
|
||||
return ls;
|
||||
if (sexp_pairp(sexp_car(ls)) && (x == sexp_caar(ls)))
|
||||
return sexp_car(ls);
|
||||
else
|
||||
ls = sexp_cdr(ls);
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
|
||||
sexp sexp_reverse(sexp ls) {
|
||||
sexp sexp_reverse (sexp ls) {
|
||||
sexp res = SEXP_NULL;
|
||||
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
|
||||
res = sexp_cons(sexp_car(ls), res);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_nreverse(sexp ls) {
|
||||
sexp sexp_nreverse (sexp ls) {
|
||||
sexp a, b, tmp;
|
||||
if (ls == SEXP_NULL) {
|
||||
return ls;
|
||||
|
|
@ -204,19 +205,62 @@ sexp sexp_nreverse(sexp ls) {
|
|||
}
|
||||
}
|
||||
|
||||
sexp sexp_append(sexp a, sexp b) {
|
||||
sexp sexp_append (sexp a, sexp b) {
|
||||
for (a=sexp_reverse(a); sexp_pairp(a); a=sexp_cdr(a))
|
||||
b = sexp_cons(sexp_car(a), b);
|
||||
return b;
|
||||
}
|
||||
|
||||
sexp sexp_length(sexp ls) {
|
||||
sexp sexp_length (sexp ls) {
|
||||
sexp_uint_t res=0;
|
||||
for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls))
|
||||
;
|
||||
return sexp_make_integer(res);
|
||||
}
|
||||
|
||||
sexp sexp_equalp (sexp a, sexp b) {
|
||||
sexp_uint_t len;
|
||||
sexp *v1, *v2;
|
||||
loop:
|
||||
if (a == b)
|
||||
return SEXP_TRUE;
|
||||
if (! sexp_pointerp(a))
|
||||
return sexp_make_boolean(sexp_integerp(a) && sexp_pointerp(b)
|
||||
&& (sexp_unbox_integer(a)
|
||||
== sexp_flonum_value(b)));
|
||||
else if (! sexp_pointerp(b))
|
||||
return sexp_make_boolean(sexp_integerp(b) && sexp_pointerp(a)
|
||||
&& (sexp_unbox_integer(b)
|
||||
== sexp_flonum_value(a)));
|
||||
if (sexp_pointer_tag(a) != sexp_pointer_tag(b))
|
||||
return SEXP_FALSE;
|
||||
switch (sexp_pointer_tag(a)) {
|
||||
case SEXP_PAIR:
|
||||
if (sexp_equalp(sexp_car(a), sexp_car(b)) == SEXP_FALSE)
|
||||
return SEXP_FALSE;
|
||||
a = sexp_cdr(a);
|
||||
b = sexp_cdr(b);
|
||||
goto loop;
|
||||
case SEXP_VECTOR:
|
||||
len = sexp_vector_length(a);
|
||||
if (len != sexp_vector_length(b))
|
||||
return SEXP_FALSE;
|
||||
v1 = sexp_vector_data(a);
|
||||
v2 = sexp_vector_data(b);
|
||||
for (len--; len >= 0; len--)
|
||||
if (sexp_equalp(v1[len], v2[len]) == SEXP_FALSE)
|
||||
return SEXP_FALSE;
|
||||
return SEXP_TRUE;
|
||||
case SEXP_STRING:
|
||||
return sexp_make_boolean((sexp_string_length(a) == sexp_string_length(b))
|
||||
&& (! strncmp(sexp_string_data(a),
|
||||
sexp_string_data(b),
|
||||
sexp_string_length(a))));
|
||||
default:
|
||||
return SEXP_FALSE;
|
||||
}
|
||||
}
|
||||
|
||||
/********************* strings, symbols, vectors **********************/
|
||||
|
||||
sexp sexp_make_flonum(double f) {
|
||||
|
|
@ -805,7 +849,7 @@ sexp sexp_read_raw (sexp in) {
|
|||
case '(':
|
||||
sexp_push_char(c1, in);
|
||||
res = sexp_read(in);
|
||||
if (! sexp_listp(res)) {
|
||||
if (sexp_listp(res) == SEXP_FALSE) {
|
||||
if (! sexp_exceptionp(res)) {
|
||||
sexp_deep_free(res);
|
||||
res = sexp_read_error("dotted list not allowed in vector syntax",
|
||||
|
|
|
|||
6
sexp.h
6
sexp.h
|
|
@ -153,7 +153,7 @@ struct sexp_struct {
|
|||
} lit;
|
||||
/* compiler state */
|
||||
struct {
|
||||
sexp bc, lambda, offsets, *stack, env;
|
||||
sexp bc, lambda, *stack, env;
|
||||
sexp_uint_t pos, top, depth, tailp;
|
||||
} context;
|
||||
} value;
|
||||
|
|
@ -326,7 +326,6 @@ struct sexp_struct {
|
|||
#define sexp_context_pos(x) ((x)->value.context.pos)
|
||||
#define sexp_context_top(x) ((x)->value.context.top)
|
||||
#define sexp_context_lambda(x) ((x)->value.context.lambda)
|
||||
#define sexp_context_offsets(x) ((x)->value.context.offsets)
|
||||
#define sexp_context_tailp(x) ((x)->value.context.tailp)
|
||||
|
||||
/****************************** arithmetic ****************************/
|
||||
|
|
@ -400,7 +399,8 @@ void sexp_printf(sexp port, sexp fmt, ...);
|
|||
|
||||
sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag);
|
||||
sexp sexp_cons(sexp head, sexp tail);
|
||||
int sexp_listp(sexp obj);
|
||||
sexp sexp_equalp (sexp a, sexp b);
|
||||
sexp sexp_listp(sexp obj);
|
||||
sexp sexp_reverse(sexp ls);
|
||||
sexp sexp_nreverse(sexp ls);
|
||||
sexp sexp_append(sexp a, sexp b);
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue