mirror of
https://github.com/false-schemers/skint.git
synced 2024-12-26 21:58:51 +01:00
lambda*/case-lambda cleanup
This commit is contained in:
ESL
parent
109aaef590
commit
b564316cf8
6 changed files with 514 additions and 514 deletions
49
i.c
49
i.c
|
|
@ -372,21 +372,6 @@ define_instruction(brt) { int dx = fixnum_from_obj(*ip++); if (ac) ip += dx; gon
|
|||
|
||||
define_instruction(brnot) { int dx = fixnum_from_obj(*ip++); if (!ac) ip += dx; gonexti(); }
|
||||
|
||||
/* define_instruction(brcne) {
|
||||
obj v = *ip++;
|
||||
int dx = fixnum_from_obj(*ip++);
|
||||
ip = (ac == v) ? ip : ip + dx;
|
||||
gonexti();
|
||||
}
|
||||
|
||||
define_instruction(brclt) {
|
||||
obj v = *ip++;
|
||||
int dx = fixnum_from_obj(*ip++);
|
||||
// unsigned tagged fixnums can be compared as-is
|
||||
ip = (ac >= v) ? ip : ip + dx;
|
||||
gonexti();
|
||||
} */
|
||||
|
||||
define_instruction(sseti) {
|
||||
int i = fixnum_from_obj(*ip++);
|
||||
boxref(sref(i)) = ac;
|
||||
|
|
@ -492,7 +477,7 @@ define_instruction(push) { spush(ac); gonexti(); }
|
|||
define_instruction(jdceq) {
|
||||
obj v = *ip++, i = *ip++;
|
||||
if (ac == v) {
|
||||
rd = dref(fixnum_from_obj(i)); ckx(rd);
|
||||
rd = dref(fixnum_from_obj(i));
|
||||
rx = obj_from_fixnum(0);
|
||||
callsubi();
|
||||
}
|
||||
|
|
@ -502,7 +487,7 @@ define_instruction(jdceq) {
|
|||
define_instruction(jdcge) {
|
||||
obj v = *ip++, i = *ip++;
|
||||
if (ac >= v) { /* unsigned tagged fixnums can be compared as-is */
|
||||
rd = dref(fixnum_from_obj(i)); ckx(rd);
|
||||
rd = dref(fixnum_from_obj(i));
|
||||
rx = obj_from_fixnum(0);
|
||||
callsubi();
|
||||
}
|
||||
|
|
@ -511,7 +496,7 @@ define_instruction(jdcge) {
|
|||
|
||||
define_instruction(jdref) {
|
||||
int i = fixnum_from_obj(*ip++);
|
||||
rd = dref(i); ckx(rd);
|
||||
rd = dref(i);
|
||||
rx = obj_from_fixnum(0);
|
||||
callsubi();
|
||||
}
|
||||
|
|
@ -660,13 +645,6 @@ define_instruction(ckx) {
|
|||
failactype("procedure");
|
||||
}
|
||||
|
||||
define_instruction(cknj) {
|
||||
if (likely(is_flonum_obj(ac))) gonexti();
|
||||
if (!is_fixnum_obj(ac)) failactype("number");
|
||||
ac = obj_from_flonum(sp-r, (flonum_t)fixnum_from_obj(ac));
|
||||
gonexti();
|
||||
}
|
||||
|
||||
|
||||
/* integrable instructions */
|
||||
|
||||
|
|
@ -3165,27 +3143,6 @@ more:
|
|||
*--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
|
||||
goto more;
|
||||
} break;
|
||||
/* case 'c': { cases
|
||||
fixnum_t n;
|
||||
ra = sref(1); hp = rds_arg(r, sp, hp);
|
||||
if (iseof(ra)) goto out;
|
||||
hreserve(hbsz(3)*2, sp-r);
|
||||
*--hp = sref(0); *--hp = pbr->g;
|
||||
*--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
|
||||
*--hp = sref(0); *--hp = ra;
|
||||
*--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
|
||||
ra = sref(1); hp = rds_block(r, sp, hp);
|
||||
if (iseof(ra)) goto out;
|
||||
n = length(ra);
|
||||
hreserve(hbsz(3)*1, sp-r);
|
||||
*--hp = sref(0); *--hp = obj_from_fixnum(n);
|
||||
*--hp = obj_from_size(PAIR_BTAG); sref(0) = hendblk(3);
|
||||
if (n > 0) {
|
||||
obj lp = lastpair(ra); assert(ispair(lp));
|
||||
cdr(lp) = sref(0); sref(0) = ra;
|
||||
}
|
||||
goto more;
|
||||
} break; */
|
||||
case 'b': { /* branches */
|
||||
fixnum_t n; int c;
|
||||
ra = sref(1); hp = rds_block(r, sp, hp);
|
||||
|
|
|
|||
5
i.h
5
i.h
|
|
@ -51,8 +51,6 @@ declare_instruction(sbox, "#", 1, NULL, 0, NULL)
|
|||
declare_instruction(br, NULL, 'b', NULL, 0, NULL)
|
||||
declare_instruction(brnot, "?", 'b', NULL, 0, NULL)
|
||||
declare_instruction(brt, "~?", 'b', NULL, 0, NULL)
|
||||
/* declare_instruction(brcne, "|", 'c', NULL, 0, NULL) */
|
||||
/* declare_instruction(brclt, "|!", 'c', NULL, 0, NULL) */
|
||||
declare_instruction(sseti, ".!", 1, NULL, 0, NULL)
|
||||
declare_instruction(dseti, ":!", 1, NULL, 0, NULL)
|
||||
declare_instruction(gset, "@!", 'g', NULL, 0, NULL)
|
||||
|
|
@ -218,9 +216,6 @@ declare_instruction(ckr, "%r", 0, "%ckr", 1, INLINED)
|
|||
declare_instruction(ckw, "%w", 0, "%ckw", 1, INLINED)
|
||||
declare_instruction(ckx, "%x", 0, "%ckx", 1, INLINED)
|
||||
|
||||
/* type checks-adapters */
|
||||
declare_instruction(cknj, "%z", 0, "%cknj", 1, INLINED)
|
||||
|
||||
/* intrinsics (no arg checks), integrables and globals */
|
||||
declare_instruction(isq, "q", 0, "%isq", 2, INLINED)
|
||||
declare_instruction(isv, "v", 0, "%isv", 2, INLINED)
|
||||
|
|
|
|||
1
src/k.sf
1
src/k.sf
|
|
@ -933,6 +933,7 @@
|
|||
(do ([clauses (reverse clauses) (cdr clauses)] [l l (cons #f l)])
|
||||
[(null? clauses)]
|
||||
(codegen (cadr (car clauses)) l f s g #f port)
|
||||
(write-char #\% port) (write-char #\x port)
|
||||
(write-char #\, port))
|
||||
(write-char #\& port)
|
||||
(write-serialized-arg (length clauses) port)
|
||||
|
|
|
|||
56
src/t.scm
56
src/t.scm
|
|
@ -23,26 +23,26 @@
|
|||
(cons x s))))
|
||||
|
||||
(define set-union
|
||||
(lambda (sl s2)
|
||||
(if (null? sl)
|
||||
(lambda (s1 s2)
|
||||
(if (null? s1)
|
||||
s2
|
||||
(set-union (cdr sl) (set-cons (car sl) s2)))))
|
||||
(set-union (cdr s1) (set-cons (car s1) s2)))))
|
||||
|
||||
(define set-minus
|
||||
(lambda (sl s2)
|
||||
(if (null? sl)
|
||||
(lambda (s1 s2)
|
||||
(if (null? s1)
|
||||
'()
|
||||
(if (set-member? (car sl) s2)
|
||||
(set-minus (cdr sl) s2)
|
||||
(cons (car sl) (set-minus (cdr sl) s2))))))
|
||||
(if (set-member? (car s1) s2)
|
||||
(set-minus (cdr s1) s2)
|
||||
(cons (car s1) (set-minus (cdr s1) s2))))))
|
||||
|
||||
(define set-intersect
|
||||
(lambda (sl s2)
|
||||
(if (null? sl)
|
||||
(lambda (s1 s2)
|
||||
(if (null? s1)
|
||||
'()
|
||||
(if (set-member? (car sl) s2)
|
||||
(cons (car sl) (set-intersect (cdr sl) s2))
|
||||
(set-intersect (cdr sl) s2)))))
|
||||
(if (set-member? (car s1) s2)
|
||||
(cons (car s1) (set-intersect (cdr s1) s2))
|
||||
(set-intersect (cdr s1) s2)))))
|
||||
|
||||
(define-syntax record-case
|
||||
(syntax-rules (else)
|
||||
|
|
@ -129,6 +129,7 @@
|
|||
; <core> -> (ref <id>)
|
||||
; <core> -> (set! <id> <core>)
|
||||
; <core> -> (lambda <ids> <core>) where <ids> -> (<id> ...) | (<id> ... . <id>) | <id>
|
||||
; <core> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>)
|
||||
; <core> -> (begin <core> ...)
|
||||
; <core> -> (if <core> <core> <core>)
|
||||
; <core> -> (call <core> <core> ...)
|
||||
|
|
@ -139,6 +140,15 @@
|
|||
; <core> -> (define <id> <core>)
|
||||
; <core> -> (define-syntax <id> <transformer>)
|
||||
|
||||
(define normalize-arity
|
||||
(lambda (arity)
|
||||
(if (and (list2? arity) (fixnum? (car arity)) (boolean? (cadr arity)))
|
||||
arity
|
||||
(let loop ([cnt 0] [l arity])
|
||||
(cond [(pair? l) (loop (fx+ 1 cnt) (cdr l))]
|
||||
[(null? l) (list cnt #f)]
|
||||
[else (list cnt #t)])))))
|
||||
|
||||
; convention for 'flattened' <ids> is to put rest arg if any at the front
|
||||
(define flatten-idslist
|
||||
(lambda (ilist)
|
||||
|
|
@ -221,6 +231,7 @@
|
|||
[(begin) (xform-begin tail env)]
|
||||
[(if) (xform-if tail env)]
|
||||
[(lambda) (xform-lambda tail env)]
|
||||
[(lambda*) (xform-lambda* tail env)]
|
||||
[(body) (xform-body tail env)]
|
||||
[(define) (xform-define (car tail) (cadr tail) env)]
|
||||
[(define-syntax) (xform-define-syntax (car tail) (cadr tail) env)]
|
||||
|
|
@ -290,6 +301,17 @@
|
|||
(xform-body (cdr tail) ienv)))]))
|
||||
(error 'transform "improper lambda body")))
|
||||
|
||||
(define (xform-lambda* tail env)
|
||||
(if (list? tail)
|
||||
(cons 'lambda*
|
||||
(map (lambda (aexp)
|
||||
(if (list2? aexp)
|
||||
(list (normalize-arity (car aexp))
|
||||
(xform #f (cadr aexp) env))
|
||||
(error 'transform "improper lambda* clause")))
|
||||
tail))
|
||||
(error 'transform "improper lambda* form")))
|
||||
|
||||
(define (xform-body tail env)
|
||||
(if (null? tail)
|
||||
(list 'begin)
|
||||
|
|
@ -360,6 +382,7 @@
|
|||
(make-binding 'begin 'begin)
|
||||
(make-binding 'if 'if)
|
||||
(make-binding 'lambda 'lambda)
|
||||
(make-binding 'lambda* 'lambda*)
|
||||
(make-binding 'body 'body)
|
||||
denotation-of-default-ellipsis))
|
||||
|
||||
|
|
@ -499,8 +522,7 @@
|
|||
(if (null? rules) (error 'transform "invalid syntax" use))
|
||||
(let* ([rule (car rules)] [pat (car rule)] [tmpl (cadr rule)])
|
||||
(cond [(match-pattern pat use use-env) =>
|
||||
(lambda (bindings)
|
||||
(expand-template pat tmpl bindings))]
|
||||
(lambda (bindings) (expand-template pat tmpl bindings))]
|
||||
[else (loop (cdr rules))])))))
|
||||
|
||||
(install-transformer! 'syntax-rules
|
||||
|
|
@ -626,3 +648,7 @@
|
|||
(install-sr-transformer! 'unless
|
||||
(syntax-rules ()
|
||||
[(_ test . rest) (if (not test) (begin . rest))]))
|
||||
|
||||
(install-sr-transformer! 'case-lambda
|
||||
(syntax-rules ()
|
||||
[(_ [args . body] ...) (lambda* [args (lambda args . body)] ...)]))
|
||||
|
|
|
|||
43
t.c
43
t.c
|
|
@ -67,6 +67,11 @@ char *t_code[] = {
|
|||
0,
|
||||
"&0{%1.0p?{.0d,@(y6:list3?)[11}f]1}@!(y6:list4?)",
|
||||
|
||||
0,
|
||||
"&0{%1${.2,@(y6:list2?)[01}?{.0aI0?{.0daY1}{f}}{f}?{.0]1}.0,'0,,#0.0,&1"
|
||||
"{%2.1p?{.1d,.1,'1I+,:0^[22}.1u?{f,.1,l2]2}t,.1,l2]2}.!0.0^_1[12}@!(y15"
|
||||
":normalize-arity)",
|
||||
|
||||
0,
|
||||
"&0{%1.0L0?{.0]1}n,.1,,#0.0,&1{%2.0p?{.1,.1ac,.1d,:0^[22}.0u?{.1A9]2}.1"
|
||||
"A9,.1c]2}.!0.0^_1[12}@!(y15:flatten-idslist)",
|
||||
|
|
@ -139,11 +144,12 @@ char *t_code[] = {
|
|||
"}'(l1:y5:quote;)%l,.1A1?{.6,.3a,@(y11:xform-quote)[72}'(l1:y4:set!;)%l"
|
||||
",.1A1?{.6,.3da,.4a,@(y10:xform-set!)[73}'(l1:y5:begin;)%l,.1A1?{.6,.3,"
|
||||
"@(y11:xform-begin)[72}'(l1:y2:if;)%l,.1A1?{.6,.3,@(y8:xform-if)[72}'(l"
|
||||
"1:y6:lambda;)%l,.1A1?{.6,.3,@(y12:xform-lambda)[72}'(l1:y4:body;)%l,.1"
|
||||
"A1?{.6,.3,@(y10:xform-body)[72}'(l1:y6:define;)%l,.1A1?{.6,.3da,.4a,@("
|
||||
"y12:xform-define)[73}'(l1:y13:define-syntax;)%l,.1A1?{.6,.3da,.4a,@(y1"
|
||||
"9:xform-define-syntax)[73}t?{.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73"
|
||||
"}.6,.3,.3,@(y10:xform-call)[73}f]7}@!(y5:xform)",
|
||||
"1:y6:lambda;)%l,.1A1?{.6,.3,@(y12:xform-lambda)[72}'(l1:y7:lambda*;)%l"
|
||||
",.1A1?{.6,.3,@(y13:xform-lambda*)[72}'(l1:y4:body;)%l,.1A1?{.6,.3,@(y1"
|
||||
"0:xform-body)[72}'(l1:y6:define;)%l,.1A1?{.6,.3da,.4a,@(y12:xform-defi"
|
||||
"ne)[73}'(l1:y13:define-syntax;)%l,.1A1?{.6,.3da,.4a,@(y19:xform-define"
|
||||
"-syntax)[73}t?{.1K0?{.6,${.9,.9,.6[02},.6,@(y5:xform)[73}.6,.3,.3,@(y1"
|
||||
"0:xform-call)[73}f]7}@!(y5:xform)",
|
||||
|
||||
0,
|
||||
"&0{%2${.2,,#0.0,&1{%1${.2,@(y3:id?)[01}?{.0,@(y7:id->sym)[11}.0p?{${.2"
|
||||
|
|
@ -189,6 +195,13 @@ char *t_code[] = {
|
|||
"xform-body)[02},.2,.7A8L6,'(y6:lambda),l3]6}.!0.0^_1[23}'(s20:improper"
|
||||
" lambda body),'(y9:transform),@(y5:error)[22}@!(y12:xform-lambda)",
|
||||
|
||||
0,
|
||||
"&0{%2.0L0?{.1,&1{%1${.2,@(y6:list2?)[01}?{${:0,.3da,f,@(y5:xform)[03},"
|
||||
"${.3a,@(y15:normalize-arity)[01},l2]1}'(s23:improper lambda* clause),'"
|
||||
"(y9:transform),@(y5:error)[12},${.3,,#0.4,.1,&2{%1.0p?{${.2d,:0^[01},$"
|
||||
"{.3a,:1[01}c]1}n]1}.!0.0^_1[01}_1,'(y7:lambda*)c]2}'(s21:improper lamb"
|
||||
"da* form),'(y9:transform),@(y5:error)[22}@!(y13:xform-lambda*)",
|
||||
|
||||
0,
|
||||
"&0{%2.0u?{n,'(y5:begin)c]2}.0,n,n,n,.5,,#0.0,&1{%5.4p?{.4ap}{f}?{.4d,."
|
||||
"5a,.0a,${.5,.3,t,@(y5:xform)[03},.0,'(l1:y5:begin;)%l,.1A1?{.4,.4dL6,."
|
||||
|
|
@ -227,13 +240,14 @@ char *t_code[] = {
|
|||
|
||||
0,
|
||||
"@(y30:denotation-of-default-ellipsis),${'(y4:body),'(y4:body),@(y12:ma"
|
||||
"ke-binding)[02},${'(y6:lambda),'(y6:lambda),@(y12:make-binding)[02},${"
|
||||
"'(y2:if),'(y2:if),@(y12:make-binding)[02},${'(y5:begin),'(y5:begin),@("
|
||||
"y12:make-binding)[02},${'(y4:set!),'(y4:set!),@(y12:make-binding)[02},"
|
||||
"${'(y5:quote),'(y5:quote),@(y12:make-binding)[02},${'(y13:define-synta"
|
||||
"x),'(y13:define-syntax),@(y12:make-binding)[02},${'(y6:define),'(y6:de"
|
||||
"fine),@(y12:make-binding)[02},${'(y6:syntax),'(y6:syntax),@(y12:make-b"
|
||||
"inding)[02},l(i10)@!(y14:*transformers*)",
|
||||
"ke-binding)[02},${'(y7:lambda*),'(y7:lambda*),@(y12:make-binding)[02},"
|
||||
"${'(y6:lambda),'(y6:lambda),@(y12:make-binding)[02},${'(y2:if),'(y2:if"
|
||||
"),@(y12:make-binding)[02},${'(y5:begin),'(y5:begin),@(y12:make-binding"
|
||||
")[02},${'(y4:set!),'(y4:set!),@(y12:make-binding)[02},${'(y5:quote),'("
|
||||
"y5:quote),@(y12:make-binding)[02},${'(y13:define-syntax),'(y13:define-"
|
||||
"syntax),@(y12:make-binding)[02},${'(y6:define),'(y6:define),@(y12:make"
|
||||
"-binding)[02},${'(y6:syntax),'(y6:syntax),@(y12:make-binding)[02},l(i1"
|
||||
"1)@!(y14:*transformers*)",
|
||||
|
||||
0,
|
||||
"&0{%1${@(y14:*transformers*),.3,@(y16:find-top-binding)[02},${.2,@(y8:"
|
||||
|
|
@ -401,5 +415,10 @@ char *t_code[] = {
|
|||
"${'(l1:l2:py1:_;py4:test;y4:rest;;;l3:y2:if;l2:y3:not;y4:test;;py5:beg"
|
||||
"in;y4:rest;;;;),n,f,'(y6:unless),@(y26:install-transformer-rules!)[04}",
|
||||
|
||||
0,
|
||||
"${'(l1:l2:l3:y1:_;py4:args;y4:body;;y3:...;;l3:y7:lambda*;l2:y4:args;p"
|
||||
"y6:lambda;py4:args;y4:body;;;;y3:...;;;),n,f,'(y11:case-lambda),@(y26:"
|
||||
"install-transformer-rules!)[04}",
|
||||
|
||||
0, 0
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in a new issue