Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-14 08:27:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

records are now generative, match can destructure records with $ patterns

Browse source
This commit is contained in:
Alex Shinn 2010-07-17 14:46:50 +09:00
parent c6c593f277
commit 9cf8124a81
9 changed files with 81 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
eval.c
View file

@ -397,7 +397,7 @@ static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), s
return (sexp_synclop(x) ? sexp_synclo_expr(x) : x);
}
static sexp sexp_strip_synclos (sexp ctx, sexp x) {
static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) {
sexp res;
sexp_gc_var2(kar, kdr);
sexp_gc_preserve2(ctx, kar, kdr);
@ -406,8 +406,8 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) {
x = sexp_synclo_expr(x);
goto loop;
} else if (sexp_pairp(x)) {
kar = sexp_strip_synclos(ctx, sexp_car(x));
kdr = sexp_strip_synclos(ctx, sexp_cdr(x));
kar = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_car(x));
kdr = sexp_strip_synclos(ctx sexp_api_pass(self, n), sexp_cdr(x));
res = sexp_cons(ctx, kar, kdr);
sexp_immutablep(res) = 1;
} else {
@ -641,8 +641,8 @@ static sexp analyze_define (sexp ctx, sexp x) {
static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
sexp res = SEXP_VOID, name;
sexp_gc_var3(proc, mac, tmp);
sexp_gc_preserve3(eval_ctx, proc, mac, tmp);
sexp_gc_var2(proc, mac);
sexp_gc_preserve2(eval_ctx, proc, mac);
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls)) {
if (! (sexp_pairp(sexp_car(ls)) && sexp_pairp(sexp_cdar(ls))
&& sexp_nullp(sexp_cddar(ls)))) {
@ -662,7 +662,7 @@ static sexp analyze_bind_syntax (sexp ls, sexp eval_ctx, sexp bind_ctx) {
}
}
}
sexp_gc_release3(eval_ctx);
sexp_gc_release2(eval_ctx);
return res;
}
@ -741,7 +741,7 @@ static sexp analyze (sexp ctx, sexp object) {
else
res = sexp_make_lit(ctx,
(sexp_core_code(op) == SEXP_CORE_QUOTE) ?
sexp_strip_synclos(ctx, sexp_cadr(x)) :
sexp_strip_synclos(ctx sexp_api_pass(NULL, 1), sexp_cadr(x)) :
sexp_cadr(x));
break;
case SEXP_CORE_DEFINE_SYNTAX:
@ -1361,6 +1361,7 @@ sexp sexp_define_foreign_param (sexp ctx, sexp env, const char *name, int num_ar
#if SEXP_USE_TYPE_DEFS
sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_TYPE_PREDICATE),
sexp_make_fixnum(SEXP_OP_TYPEP), SEXP_ONE, SEXP_ZERO,
@ -1369,6 +1370,7 @@ sexp sexp_make_type_predicate_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type) {
sexp_uint_t type_size;
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, type);
type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
return sexp_make_opcode(ctx, self, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
@ -1378,6 +1380,7 @@ sexp sexp_make_constructor_op (sexp ctx sexp_api_params(self, n), sexp name, sex
}
sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) {
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))
@ -1389,6 +1392,7 @@ sexp sexp_make_getter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp typ
}
sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, sexp type, sexp index) {
if (sexp_typep(type)) type = sexp_make_fixnum(sexp_type_tag(type));
if ((! sexp_fixnump(type)) || (sexp_unbox_fixnum(type) < 0))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, type);
if ((! sexp_fixnump(index)) || (sexp_unbox_fixnum(index) < 0))

3
include/chibi/eval.h
View file

@ -93,6 +93,9 @@ enum sexp_opcode_names {
SEXP_OP_MAKE,
SEXP_OP_SLOT_REF,
SEXP_OP_SLOT_SET,
SEXP_OP_ISA,
SEXP_OP_SLOTN_REF,
SEXP_OP_SLOTN_SET,
SEXP_OP_CAR,
SEXP_OP_CDR,
SEXP_OP_SET_CAR,

2
include/chibi/sexp.h
View file

@ -472,6 +472,8 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i])
#define sexp_slot_set(x,i,v) (((sexp*)&((x)->value))[i] = (v))
#define sexp_isa(a, b) (sexp_pointerp(a) && sexp_typep(b) && (sexp_pointer_tag(a) == sexp_type_tag(b)))
#if SEXP_USE_IMMEDIATE_FLONUMS
union sexp_flonum_conv {
float flonum;

13
lib/chibi/match/match.scm
View file

@ -161,6 +161,10 @@
(match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
((match-two v (p *** . q) g+s sk fk i)
(match-syntax-error "invalid use of ***" (p *** . q)))
((match-two v ($ rec p ...) g+s sk fk i)
(if (is-a? v rec)
(match-record-refs v rec 0 (p ...) g+s sk fk i)
fk))
((match-two v (p . q) g+s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
@ -471,6 +475,15 @@
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
fk i)))))))
(define-syntax match-record-refs
(syntax-rules ()
((_ v rec n (p . q) g+s sk fk i)
(let ((w (slot-ref rec v n)))
(match-one w p ((slot-ref rec v n) (slot-set! rec v n))
(match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
((_ v rec n () g+s (sk ...) fk i)
(sk ... i))))
;; Extract all identifiers in a pattern. A little more complicated
;; than just looking for symbols, we need to ignore special keywords
;; and non-pattern forms (such as the predicate expression in ?

19
lib/srfi/9.module
View file

@ -13,17 +13,21 @@
(pred (cadddr expr))
(fields (cddddr expr))
(num-fields (length fields))
(index (register-simple-type name-str num-fields))
(_define (rename 'define))
(_lambda (rename 'lambda))
(_let (rename 'let)))
(_let (rename 'let))
(_register (rename 'register-simple-type)))
(define (index-of field ls)
(let lp ((ls ls) (i 0))
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
`(,(rename 'begin)
;; type
(,_define ,name (,_register ,name-str ,num-fields))
;; predicate
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string (identifier->symbol pred))
,index))
,name))
;; fields
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
@ -32,7 +36,7 @@
(,(rename 'make-getter)
,(symbol->string
(identifier->symbol (cadar ls)))
,index
,name
,i))
res)))
(lp (cdr ls)
@ -43,17 +47,18 @@
(,(rename 'make-setter)
,(symbol->string
(identifier->symbol (caddar ls)))
,index
,name
,i))
res)
res)))))
;; constructor
(,_define ,make
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
(cond
((null? ls)
`(,_let ((%make (,(rename 'make-constructor)
,(symbol->string (identifier->symbol make))
,index))
,name))
,@set-defs)
(,_lambda ,make-fields
(,_let ((res (%make)))
@ -79,7 +84,7 @@
(cons (list setter
(list (rename 'make-setter)
setter-name
index
name
(index-of (car ls) fields)))
set-defs)))))))))))))))))

3
opcodes.c
View file

@ -36,6 +36,8 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string
#endif
#endif
_OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", 0, NULL),
_OP(SEXP_OPC_GETTER, SEXP_OP_SLOTN_REF,3,0, 0, SEXP_FIXNUM, 0,"slot-ref", 0, NULL),
_OP(SEXP_OPC_SETTER, SEXP_OP_SLOTN_SET,4,0, 0, SEXP_FIXNUM, 0,"slot-set!", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", 0, NULL),
_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", 0, NULL),
@ -58,6 +60,7 @@ _OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_CONS, 2, 0, 0, 0, 0, "cons", 0, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_VECTOR, 1, 1, SEXP_FIXNUM, 0, 0, "make-vector", SEXP_VOID, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_PROCEDURE, 4, 0, 0, 0, 0, "make-procedure", 0, NULL),
_OP(SEXP_OPC_CONSTRUCTOR, SEXP_OP_MAKE_EXCEPTION, 5, 0, 0, 0, 0, "make-exception", 0, NULL),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_ISA, 2, 0, 0, 0, 0, "is-a?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, 0),
_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, 0),

7
opt/opcode_names.h
View file

@ -10,9 +10,10 @@ static const char* reverse_opcode_names[] =
"STRING-REF", "STRING-SET", "STRING-LENGTH",
"MAKE-PROCEDURE", "MAKE-VECTOR",
"MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
"EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR",
"SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
"MUL", "DIV", "QUOTIENT", "REMAINDER",
"EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET",
"ISA?", "SLOTN-REF", "SLOTN-SET",
"CAR", "CDR", "SET-CAR", "SET-CDR", "CONS",
"ADD", "SUB", "MUL", "DIV", "QUOTIENT", "REMAINDER",
"LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
"CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
"WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR",

7
sexp.c
View file

@ -183,7 +183,7 @@ sexp sexp_register_type_op (sexp ctx sexp_api_params(self, n), sexp name,
sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
sexp_type_name(type) = strdup(sexp_string_data(name));
sexp_type_finalize(type) = f;
res = sexp_make_fixnum(num_types);
res = type;
#if SEXP_USE_GLOBAL_TYPES
sexp_num_types = num_types + 1;
#else
@ -1200,6 +1200,11 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out);
sexp_write_string(ctx, ">", out);
break;
case SEXP_SYNCLO:
sexp_write_string(ctx, "#<sc: ", out);
sexp_write(ctx, sexp_synclo_expr(obj), out);
sexp_write_string(ctx, ">", out);
break;
case SEXP_STRING:
sexp_write_char(ctx, '"', out);
i = sexp_string_length(obj);

27
vm.c
View file

@ -931,6 +931,33 @@ sexp sexp_vm (sexp ctx, sexp proc) {
ip += sizeof(sexp)*2;
top--;
break;
case SEXP_OP_ISA:
_ARG2 = sexp_make_boolean(sexp_isa(_ARG1, _ARG2));
top--;
break;
case SEXP_OP_SLOTN_REF:
if (! sexp_typep(_ARG1))
sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
else if (! sexp_isa(_ARG2, _ARG1))
sexp_raise("slot-ref: bad type", sexp_list1(ctx, _ARG2));
else if (! sexp_fixnump(_ARG3))
sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3));
_ARG3 = sexp_slot_ref(_ARG2, sexp_unbox_fixnum(_ARG3));
top-=2;
break;
case SEXP_OP_SLOTN_SET:
if (! sexp_typep(_ARG1))
sexp_raise("slot-ref: not a record type", sexp_list1(ctx, _ARG1));
else if (! sexp_isa(_ARG2, _ARG1))
sexp_raise("slot-set!: bad type", sexp_list1(ctx, _ARG2));
else if (sexp_immutablep(_ARG2))
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG2));
else if (! sexp_fixnump(_ARG3))
sexp_raise("slot-ref: not an integer", sexp_list1(ctx, _ARG3));
sexp_slot_set(_ARG2, sexp_unbox_fixnum(_ARG3), _ARG4);
_ARG4 = SEXP_VOID;
top-=3;
break;
case SEXP_OP_CAR:
if (! sexp_pairp(_ARG1))
sexp_raise("car: not a pair", sexp_list1(ctx, _ARG1));