Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-26 21:58:51 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

lambda*/case-lambda: initial implementation

Browse source
This commit is contained in:
ESL 2023-03-07 13:11:46 -05:00
parent 25196416c7
commit 109aaef590
4 changed files with 2645 additions and 1569 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

68
i.c
View file

@ -372,6 +372,21 @@ 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;
@ -474,6 +489,33 @@ define_instruction(save) {
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);
rx = obj_from_fixnum(0);
callsubi();
}
gonexti();
}
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);
rx = obj_from_fixnum(0);
callsubi();
}
gonexti();
}
define_instruction(jdref) {
int i = fixnum_from_obj(*ip++);
rd = dref(i); ckx(rd);
rx = obj_from_fixnum(0);
callsubi();
}
define_instruction(call) {
int n = fixnum_from_obj(*ip++);
ckx(ac); rd = ac; rx = obj_from_fixnum(0);
@ -542,6 +584,11 @@ define_instruction(shrarg) {
gonexti();
}
define_instruction(aerr) {
fail("argument count error on entry");
gonexti();
}
define_instruction(shlit) { spush(ac); ac = *ip++; gonexti(); }
define_instruction(shi0) { spush(ac); ac = obj_from_fixnum(0); gonexti(); }
@ -3118,6 +3165,27 @@ 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);

6
i.h
View file

@ -51,6 +51,8 @@ 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)
@ -62,6 +64,9 @@ declare_instruction(rcmv, "K5", 0, NULL, 0, NULL)
declare_instruction(sdmv, "K6", 0, NULL, 0, NULL)
declare_instruction(save, "$", 's', NULL, 0, NULL)
declare_instruction(push, ",", 0, NULL, 0, NULL)
declare_instruction(jdceq, "|", 2, NULL, 0, NULL)
declare_instruction(jdcge, "|!", 2, NULL, 0, NULL)
declare_instruction(jdref, "|!0", 1, NULL, 0, NULL)
declare_instruction(call, "[0", 1, NULL, 0, NULL)
declare_instruction(scall, "[", 2, NULL, 0, NULL)
declare_instruction(return, "]0", 0, NULL, 0, NULL)
@ -70,6 +75,7 @@ declare_instruction(adrop, "_", 1, NULL, 0, NULL)
declare_instruction(pop, "_!", 0, NULL, 0, NULL)
declare_instruction(atest, "%", 1, NULL, 0, NULL)
declare_instruction(shrarg, "%!", 1, NULL, 0, NULL)
declare_instruction(aerr, "%%", 0, NULL, 0, NULL)
/* popular instruction combos */
declare_instruction(shlit, ",'", 1, NULL, 0, NULL)

4088
k.c
View file

File diff suppressed because it is too large Load diff

52
src/k.sf
View file

@ -142,9 +142,10 @@
; <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> ...)
; <core> -> (call <core> <core> ...)
; NB: (begin) is legit, returns unspecified value
; on top level, these two extra core forms are legal:
@ -152,6 +153,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)
@ -166,7 +176,6 @@
(fx+ 1 (idslist-req-count (cdr ilist)))
0)))
;---------------------------------------------------------------------------------------------
; Macro transformer (from Scheme to Scheme Core) derived from Al Petrofsky's EIOD 1.17
;---------------------------------------------------------------------------------------------
@ -234,6 +243,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)]
@ -303,6 +313,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)
@ -373,6 +394,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))
@ -639,6 +661,10 @@
(syntax-rules ()
[(_ test . rest) (if (not test) (begin . rest))]))
(install-sr-transformer! 'case-lambda
(syntax-rules ()
[(_ [args . body] ...) (lambda* [args (lambda args . body)] ...)]))
;---------------------------------------------------------------------------------------------
; Runtime
@ -754,6 +780,8 @@
(find-free exp b))]
[lambda (idsi exp)
(find-free exp (set-union (flatten-idslist idsi) b))]
[lambda* clauses
(find-free* (map cadr clauses) b)]
[if (test then else)
(set-union
(find-free test b)
@ -784,6 +812,8 @@
(find-sets x v))]
[lambda (idsi exp)
(find-sets exp (set-minus v (flatten-idslist idsi)))]
[lambda* clauses
(find-sets* (map cadr clauses) v)]
[begin exps
(find-sets* exps v)]
[if (test then else)
@ -899,6 +929,24 @@
g (length ids) port)
(write-char #\} port))
(when k (write-char #\] port) (write-serialized-arg k port))]
[lambda* clauses
(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 #\& port)
(write-serialized-arg (length clauses) port)
(write-char #\{ port)
(do ([clauses clauses (cdr clauses)] [i 0 (fx+ i 1)])
[(null? clauses)]
(let* ([arity (caar clauses)] [cnt (car arity)] [rest? (cadr arity)])
(write-char #\| port)
(if rest? (write-char #\! port))
(write-serialized-arg cnt port)
(write-serialized-arg i port)))
(write-char #\% port) (write-char #\% port)
(write-char #\} port)
(when k (write-char #\] port) (write-serialized-arg k port))]
[call (exp . args)
(cond [(and (eq? (car exp) 'lambda) (list? (cadr exp))
(fx=? (length args) (length (cadr exp))))