mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-15 18:20:42 +02:00
more work towards compiling and interpreting keyword args
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bumparoo * libguile/vm-i-system.c (push-rest, bind-rest): Logically there are actually two rest binders -- one that pops, conses, and pushes, and one that pops, conses, and local-sets. The latter is used on keyword arguments, because the keyword arguments themselves have been shuffled up on the stack. Renumber ops again. * module/language/tree-il/compile-glil.scm (flatten): Attempt to handle compilation of lambda-case with keyword arguments. Might need some help. * module/ice-9/psyntax.scm (build-lambda-case): An attempt to handle the interpreted case correctly. This might need a couple iterations, but at least it looks like the compile-glil code. * module/ice-9/psyntax-pp.scm: Regenerated. * module/language/glil.scm (<glil>): Rename "rest?" to "rest" in <glil-opt-prelude> and <glil-kw-prelude>, as it is no longer a simple boolean, but if true is an integer: the index of the local variable to which the rest should be bound. * module/language/glil/compile-assembly.scm (glil->assembly): Adapt to "rest" vs "rest?". In the keyword case, use "bind-rest" instead of "push-rest". * test-suite/tests/tree-il.test: Update for opt-prelude change.
This commit is contained in:
Andy Wingo
parent
7e01997e88
commit
899d37a6cf
8 changed files with 2373 additions and 2197 deletions
|
|
@ -172,7 +172,7 @@
|
|||
|
||||
/* Major and minor versions must be single characters. */
|
||||
#define SCM_OBJCODE_MAJOR_VERSION 0
|
||||
#define SCM_OBJCODE_MINOR_VERSION I
|
||||
#define SCM_OBJCODE_MINOR_VERSION J
|
||||
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
|
||||
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
|
||||
#define SCM_OBJCODE_MINOR_VERSION_STRING \
|
||||
|
|
|
|||
|
|
@ -624,7 +624,7 @@ VM_DEFINE_INSTRUCTION (45, bind_kwargs, "bind-kwargs", 5, 0, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (46, bind_rest, "bind-rest", 2, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (46, push_rest, "push-rest", 2, -1, -1)
|
||||
{
|
||||
scm_t_ptrdiff n;
|
||||
SCM rest = SCM_EOL;
|
||||
|
|
@ -637,7 +637,23 @@ VM_DEFINE_INSTRUCTION (46, bind_rest, "bind-rest", 2, -1, -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (47, reserve_locals, "reserve-locals", 2, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (47, bind_rest, "bind-rest", 4, -1, -1)
|
||||
{
|
||||
scm_t_ptrdiff n;
|
||||
scm_t_uint32 i;
|
||||
SCM rest = SCM_EOL;
|
||||
n = FETCH () << 8;
|
||||
n += FETCH ();
|
||||
i = FETCH () << 8;
|
||||
i += FETCH ();
|
||||
while (sp - (fp - 1) > n)
|
||||
/* No need to check for underflow. */
|
||||
CONS (rest, *sp--, rest);
|
||||
LOCAL_SET (i, rest);
|
||||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (48, reserve_locals, "reserve-locals", 2, -1, -1)
|
||||
{
|
||||
SCM *old_sp;
|
||||
scm_t_int32 n;
|
||||
|
|
@ -658,7 +674,7 @@ VM_DEFINE_INSTRUCTION (47, reserve_locals, "reserve-locals", 2, -1, -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (48, new_frame, "new-frame", 0, 0, 3)
|
||||
VM_DEFINE_INSTRUCTION (49, new_frame, "new-frame", 0, 0, 3)
|
||||
{
|
||||
/* NB: if you change this, see frames.c:vm-frame-num-locals */
|
||||
/* and frames.h, vm-engine.c, etc of course */
|
||||
|
|
@ -668,7 +684,7 @@ VM_DEFINE_INSTRUCTION (48, new_frame, "new-frame", 0, 0, 3)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (49, call, "call", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (50, call, "call", 1, -1, 1)
|
||||
{
|
||||
SCM x;
|
||||
nargs = FETCH ();
|
||||
|
|
@ -729,7 +745,7 @@ VM_DEFINE_INSTRUCTION (49, call, "call", 1, -1, 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (50, goto_args, "goto/args", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (51, goto_args, "goto/args", 1, -1, 1)
|
||||
{
|
||||
register SCM x;
|
||||
nargs = FETCH ();
|
||||
|
|
@ -802,7 +818,7 @@ VM_DEFINE_INSTRUCTION (50, goto_args, "goto/args", 1, -1, 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (51, goto_nargs, "goto/nargs", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (52, goto_nargs, "goto/nargs", 0, 0, 1)
|
||||
{
|
||||
SCM x;
|
||||
POP (x);
|
||||
|
|
@ -811,7 +827,7 @@ VM_DEFINE_INSTRUCTION (51, goto_nargs, "goto/nargs", 0, 0, 1)
|
|||
goto vm_goto_args;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (52, call_nargs, "call/nargs", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (53, call_nargs, "call/nargs", 0, 0, 1)
|
||||
{
|
||||
SCM x;
|
||||
POP (x);
|
||||
|
|
@ -820,7 +836,7 @@ VM_DEFINE_INSTRUCTION (52, call_nargs, "call/nargs", 0, 0, 1)
|
|||
goto vm_call;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (53, mv_call, "mv-call", 4, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (54, mv_call, "mv-call", 4, -1, 1)
|
||||
{
|
||||
SCM x;
|
||||
scm_t_int32 offset;
|
||||
|
|
@ -882,7 +898,7 @@ VM_DEFINE_INSTRUCTION (53, mv_call, "mv-call", 4, -1, 1)
|
|||
goto vm_error_wrong_type_apply;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (54, apply, "apply", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (55, apply, "apply", 1, -1, 1)
|
||||
{
|
||||
int len;
|
||||
SCM ls;
|
||||
|
|
@ -901,7 +917,7 @@ VM_DEFINE_INSTRUCTION (54, apply, "apply", 1, -1, 1)
|
|||
goto vm_call;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (55, goto_apply, "goto/apply", 1, -1, 1)
|
||||
VM_DEFINE_INSTRUCTION (56, goto_apply, "goto/apply", 1, -1, 1)
|
||||
{
|
||||
int len;
|
||||
SCM ls;
|
||||
|
|
@ -920,7 +936,7 @@ VM_DEFINE_INSTRUCTION (55, goto_apply, "goto/apply", 1, -1, 1)
|
|||
goto vm_goto_args;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (56, call_cc, "call/cc", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (57, call_cc, "call/cc", 0, 1, 1)
|
||||
{
|
||||
int first;
|
||||
SCM proc, cont;
|
||||
|
|
@ -957,7 +973,7 @@ VM_DEFINE_INSTRUCTION (56, call_cc, "call/cc", 0, 1, 1)
|
|||
}
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (57, goto_cc, "goto/cc", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (58, goto_cc, "goto/cc", 0, 1, 1)
|
||||
{
|
||||
int first;
|
||||
SCM proc, cont;
|
||||
|
|
@ -989,7 +1005,7 @@ VM_DEFINE_INSTRUCTION (57, goto_cc, "goto/cc", 0, 1, 1)
|
|||
}
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (58, return, "return", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (59, return, "return", 0, 1, 1)
|
||||
{
|
||||
vm_return:
|
||||
EXIT_HOOK ();
|
||||
|
|
@ -1025,7 +1041,7 @@ VM_DEFINE_INSTRUCTION (58, return, "return", 0, 1, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (59, return_values, "return/values", 1, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (60, return_values, "return/values", 1, -1, -1)
|
||||
{
|
||||
/* nvalues declared at top level, because for some reason gcc seems to think
|
||||
that perhaps it might be used without declaration. Fooey to that, I say. */
|
||||
|
|
@ -1080,7 +1096,7 @@ VM_DEFINE_INSTRUCTION (59, return_values, "return/values", 1, -1, -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (60, return_values_star, "return/values*", 1, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (61, return_values_star, "return/values*", 1, -1, -1)
|
||||
{
|
||||
SCM l;
|
||||
|
||||
|
|
@ -1103,7 +1119,7 @@ VM_DEFINE_INSTRUCTION (60, return_values_star, "return/values*", 1, -1, -1)
|
|||
goto vm_return_values;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (61, truncate_values, "truncate-values", 2, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (62, truncate_values, "truncate-values", 2, -1, -1)
|
||||
{
|
||||
SCM x;
|
||||
int nbinds, rest;
|
||||
|
|
@ -1126,7 +1142,7 @@ VM_DEFINE_INSTRUCTION (61, truncate_values, "truncate-values", 2, -1, -1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (62, box, "box", 1, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (63, box, "box", 1, 1, 0)
|
||||
{
|
||||
SCM val;
|
||||
POP (val);
|
||||
|
|
@ -1140,7 +1156,7 @@ VM_DEFINE_INSTRUCTION (62, box, "box", 1, 1, 0)
|
|||
(set! a (lambda () (b ...)))
|
||||
...)
|
||||
*/
|
||||
VM_DEFINE_INSTRUCTION (63, empty_box, "empty-box", 1, 0, 0)
|
||||
VM_DEFINE_INSTRUCTION (64, empty_box, "empty-box", 1, 0, 0)
|
||||
{
|
||||
SYNC_BEFORE_GC ();
|
||||
LOCAL_SET (FETCH (),
|
||||
|
|
@ -1148,7 +1164,7 @@ VM_DEFINE_INSTRUCTION (63, empty_box, "empty-box", 1, 0, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (64, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (65, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
|
||||
{
|
||||
SCM v = LOCAL_REF (FETCH ());
|
||||
ASSERT_BOUND_VARIABLE (v);
|
||||
|
|
@ -1156,7 +1172,7 @@ VM_DEFINE_INSTRUCTION (64, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (65, local_boxed_set, "local-boxed-set", 1, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (66, local_boxed_set, "local-boxed-set", 1, 1, 0)
|
||||
{
|
||||
SCM v, val;
|
||||
v = LOCAL_REF (FETCH ());
|
||||
|
|
@ -1166,7 +1182,7 @@ VM_DEFINE_INSTRUCTION (65, local_boxed_set, "local-boxed-set", 1, 1, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (66, free_ref, "free-ref", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (67, free_ref, "free-ref", 1, 0, 1)
|
||||
{
|
||||
scm_t_uint8 idx = FETCH ();
|
||||
|
||||
|
|
@ -1177,7 +1193,7 @@ VM_DEFINE_INSTRUCTION (66, free_ref, "free-ref", 1, 0, 1)
|
|||
|
||||
/* no free-set -- if a var is assigned, it should be in a box */
|
||||
|
||||
VM_DEFINE_INSTRUCTION (67, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (68, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
|
||||
{
|
||||
SCM v;
|
||||
scm_t_uint8 idx = FETCH ();
|
||||
|
|
@ -1188,7 +1204,7 @@ VM_DEFINE_INSTRUCTION (67, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (68, free_boxed_set, "free-boxed-set", 1, 1, 0)
|
||||
VM_DEFINE_INSTRUCTION (69, free_boxed_set, "free-boxed-set", 1, 1, 0)
|
||||
{
|
||||
SCM v, val;
|
||||
scm_t_uint8 idx = FETCH ();
|
||||
|
|
@ -1200,7 +1216,7 @@ VM_DEFINE_INSTRUCTION (68, free_boxed_set, "free-boxed-set", 1, 1, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (69, make_closure, "make-closure", 0, 2, 1)
|
||||
VM_DEFINE_INSTRUCTION (70, make_closure, "make-closure", 0, 2, 1)
|
||||
{
|
||||
SCM vect;
|
||||
POP (vect);
|
||||
|
|
@ -1211,7 +1227,7 @@ VM_DEFINE_INSTRUCTION (69, make_closure, "make-closure", 0, 2, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (70, make_variable, "make-variable", 0, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (71, make_variable, "make-variable", 0, 0, 1)
|
||||
{
|
||||
SYNC_BEFORE_GC ();
|
||||
/* fixme underflow */
|
||||
|
|
@ -1219,7 +1235,7 @@ VM_DEFINE_INSTRUCTION (70, make_variable, "make-variable", 0, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (71, fix_closure, "fix-closure", 2, 0, 1)
|
||||
VM_DEFINE_INSTRUCTION (72, fix_closure, "fix-closure", 2, 0, 1)
|
||||
{
|
||||
SCM x, vect;
|
||||
unsigned int i = FETCH ();
|
||||
|
|
@ -1233,7 +1249,7 @@ VM_DEFINE_INSTRUCTION (71, fix_closure, "fix-closure", 2, 0, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (72, define, "define", 0, 0, 2)
|
||||
VM_DEFINE_INSTRUCTION (73, define, "define", 0, 0, 2)
|
||||
{
|
||||
SCM sym, val;
|
||||
POP (sym);
|
||||
|
|
@ -1245,7 +1261,7 @@ VM_DEFINE_INSTRUCTION (72, define, "define", 0, 0, 2)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (73, make_keyword, "make-keyword", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (74, make_keyword, "make-keyword", 0, 1, 1)
|
||||
{
|
||||
CHECK_UNDERFLOW ();
|
||||
SYNC_REGISTER ();
|
||||
|
|
@ -1253,7 +1269,7 @@ VM_DEFINE_INSTRUCTION (73, make_keyword, "make-keyword", 0, 1, 1)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (74, make_symbol, "make-symbol", 0, 1, 1)
|
||||
VM_DEFINE_INSTRUCTION (75, make_symbol, "make-symbol", 0, 1, 1)
|
||||
{
|
||||
CHECK_UNDERFLOW ();
|
||||
SYNC_REGISTER ();
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
|
|
@ -482,26 +482,64 @@
|
|||
src)))))
|
||||
|
||||
(define build-lambda-case
|
||||
;; kw: ((keyword var init) ...)
|
||||
;; req := (name ...)
|
||||
;; opt := ((name init) ...) | #f
|
||||
;; rest := name | #f
|
||||
;; kw: (allow-other-keys? (keyword name var [init]) ...) | #f
|
||||
;; vars: (sym ...)
|
||||
;; vars map to named arguments in the following order:
|
||||
;; required, optional (positional), rest, keyword.
|
||||
;; predicate: something you can stuff in a (lambda ,vars ,pred), already expanded
|
||||
;; the body of a lambda: anything, already expanded
|
||||
;; else: lambda-case | #f
|
||||
(lambda (src req opt rest kw vars predicate body else-case)
|
||||
(case (fluid-ref *mode*)
|
||||
((c)
|
||||
((@ (language tree-il) make-lambda-case)
|
||||
src req opt rest kw vars predicate body else-case))
|
||||
(else
|
||||
(let ((nkw (map (lambda (x)
|
||||
`(list ,(car x)
|
||||
;; grr
|
||||
,(let lp ((vars vars) (i 0))
|
||||
(cond ((null? vars) (error "bad kwarg" x))
|
||||
((eq? (cadr x) (car vars)) i)
|
||||
(else (lp (cdr vars) (1+ i)))))
|
||||
(lambda () ,(caddr x))))
|
||||
kw)))
|
||||
;; Very much like the logic of (language tree-il compile-glil).
|
||||
(let* ((nreq (length req))
|
||||
(nopt (if opt (length opt) 0))
|
||||
(rest-idx (and rest (+ nreq nopt)))
|
||||
(opt-inits (map (lambda (x) `(lambda ,vars ,(cdr x)))
|
||||
(or opt '())))
|
||||
(allow-other-keys? (if kw (car kw) #f))
|
||||
(kw-indices (map (lambda (x)
|
||||
;; (,key ,name ,var . _)
|
||||
(cons (car x) (list-index vars (caddr x))))
|
||||
(if kw (cdr kw) '())))
|
||||
(kw-inits (sort
|
||||
(filter
|
||||
identity
|
||||
(map (lambda (x)
|
||||
(if (pair? (cdddr x))
|
||||
;; (,key ,name ,var ,init)
|
||||
(let ((i (list-index vars (caddr x))))
|
||||
(if (> (+ nreq nopt) i)
|
||||
(error "kw init for rest arg" x)
|
||||
(if (and rest (= (+ nreq nopt) i))
|
||||
(error "kw init for positional arg" x)
|
||||
`(lambda ,vars ,(cadddr x)))))
|
||||
;; (,key ,name ,var)
|
||||
(let ((i (list-index vars (caddr x))))
|
||||
(if (< (+ nreq nopt) i)
|
||||
#f
|
||||
(error "missing init for kw arg" x)))))
|
||||
(if kw (cdr kw) '())))
|
||||
(lambda (x y) (< (cdr x) (cdr y)))))
|
||||
(nargs (apply max (pk (+ nreq nopt (if rest 1 0)))
|
||||
(map cdr kw-indices))))
|
||||
(or (= nargs
|
||||
(length vars)
|
||||
(+ nreq (length opt-inits) (if rest 1 0) (length kw-inits)))
|
||||
(error "something went wrong"
|
||||
req opt rest kw vars nreq nopt kw-indices kw-inits nargs))
|
||||
(decorate-source
|
||||
`((((@@ (ice-9 optargs) parse-lambda-case)
|
||||
(list ,(length req) ,(length opt) ,(and rest #t) ,nkw
|
||||
,(if predicate (error "not yet implemented") #f))
|
||||
'(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
|
||||
(list ,@opt-inits ,@kw-inits)
|
||||
,(if predicate `(lambda ,vars ,predicate) #f)
|
||||
%%args)
|
||||
=> (lambda ,vars ,body))
|
||||
,@(or else-case
|
||||
|
|
|
|||
|
|
@ -30,12 +30,12 @@
|
|||
glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
|
||||
|
||||
<glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
|
||||
glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest?
|
||||
glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest
|
||||
glil-opt-prelude-nlocs glil-opt-prelude-else-label
|
||||
|
||||
<glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
|
||||
glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
|
||||
glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest?
|
||||
glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest
|
||||
glil-kw-prelude-nlocs glil-kw-prelude-else-label
|
||||
|
||||
<glil-bind> make-glil-bind glil-bind?
|
||||
|
|
@ -84,8 +84,8 @@
|
|||
;; Meta operations
|
||||
(<glil-program> meta body)
|
||||
(<glil-std-prelude> nreq nlocs else-label)
|
||||
(<glil-opt-prelude> nreq nopt rest? nlocs else-label)
|
||||
(<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
|
||||
(<glil-opt-prelude> nreq nopt rest nlocs else-label)
|
||||
(<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
|
||||
(<glil-bind> vars)
|
||||
(<glil-mv-bind> vars rest)
|
||||
(<glil-unbind>)
|
||||
|
|
@ -111,10 +111,10 @@
|
|||
(make-glil-program meta (map parse-glil body)))
|
||||
((std-prelude ,nreq ,nlocs ,else-label)
|
||||
(make-glil-std-prelude nreq nlocs else-label))
|
||||
((opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label)
|
||||
(make-glil-opt-prelude nreq nopt rest? nlocs else-label))
|
||||
((kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label)
|
||||
(make-glil-kw-prelude nreq nopt rest? kw allow-other-keys? nlocs else-label))
|
||||
((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
|
||||
(make-glil-opt-prelude nreq nopt rest nlocs else-label))
|
||||
((kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label)
|
||||
(make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
|
||||
((bind . ,vars) (make-glil-bind vars))
|
||||
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
|
||||
((unbind) (make-glil-unbind))
|
||||
|
|
@ -138,10 +138,10 @@
|
|||
`(program ,meta ,@(map unparse-glil body)))
|
||||
((<glil-std-prelude> nreq nlocs else-label)
|
||||
`(std-prelude ,nreq ,nlocs ,else-label))
|
||||
((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
|
||||
`(opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label))
|
||||
((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
|
||||
`(kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label))
|
||||
((<glil-opt-prelude> nreq nopt rest nlocs else-label)
|
||||
`(opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label))
|
||||
((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
|
||||
`(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
|
||||
((<glil-bind> vars) `(bind ,@vars))
|
||||
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
|
||||
((<glil-unbind>) `(unbind))
|
||||
|
|
|
|||
|
|
@ -134,12 +134,12 @@
|
|||
(and (not (null? objects))
|
||||
(list->vector (cons #f objects))))
|
||||
|
||||
;; arities := ((ip nreq [[nopt] [[rest?] [kw]]]]) ...)
|
||||
(define (begin-arity addr nreq nopt rest? kw arities)
|
||||
;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
|
||||
(define (begin-arity addr nreq nopt rest kw arities)
|
||||
(cons
|
||||
(cond
|
||||
(kw (list addr nreq nopt rest? kw))
|
||||
(rest? (list addr nreq nopt rest?))
|
||||
(kw (list addr nreq nopt rest kw))
|
||||
(rest (list addr nreq nopt rest))
|
||||
(nopt (list addr nreq nopt))
|
||||
(nreq (list addr nreq))
|
||||
(else (list addr)))
|
||||
|
|
@ -151,9 +151,9 @@
|
|||
(values x bindings source-alist label-alist object-alist arities))
|
||||
(define (emit-code/object x object-alist)
|
||||
(values x bindings source-alist label-alist object-alist arities))
|
||||
(define (emit-code/arity x nreq nopt rest? kw)
|
||||
(define (emit-code/arity x nreq nopt rest kw)
|
||||
(values x bindings source-alist label-alist object-alist
|
||||
(begin-arity (addr+ addr x) nreq nopt rest? kw arities)))
|
||||
(begin-arity (addr+ addr x) nreq nopt rest kw arities)))
|
||||
|
||||
(record-case glil
|
||||
((<glil-program> meta body)
|
||||
|
|
@ -230,7 +230,7 @@
|
|||
,(modulo nlocs 256)))
|
||||
nreq #f #f #f))
|
||||
|
||||
((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
|
||||
((<glil-opt-prelude> nreq nopt rest nlocs else-label)
|
||||
(let ((bind-required
|
||||
(if else-label
|
||||
`((br-if-nargs-lt ,(quotient nreq 256)
|
||||
|
|
@ -245,8 +245,8 @@
|
|||
,(modulo (+ nreq nopt) 256)))))
|
||||
(bind-rest
|
||||
(cond
|
||||
(rest?
|
||||
`((bind-rest ,(quotient (+ nreq nopt) 256)
|
||||
(rest
|
||||
`((push-rest ,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256))))
|
||||
(else
|
||||
(if else-label
|
||||
|
|
@ -261,9 +261,9 @@
|
|||
,@bind-rest
|
||||
(reserve-locals ,(quotient nlocs 256)
|
||||
,(modulo nlocs 256)))
|
||||
nreq nopt rest? #f)))
|
||||
nreq nopt rest #f)))
|
||||
|
||||
((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
|
||||
((<glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
|
||||
(receive (kw-idx object-alist)
|
||||
(object-index-and-alist object-alist kw)
|
||||
(let ((bind-required
|
||||
|
|
@ -293,9 +293,11 @@
|
|||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(if allow-other-keys? 1 0))))
|
||||
(bind-rest
|
||||
(if rest?
|
||||
(if rest
|
||||
`((bind-rest ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)))
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(quotient rest 256)
|
||||
,(modulo rest 256)))
|
||||
'())))
|
||||
|
||||
(let ((code `(,@bind-required
|
||||
|
|
@ -305,7 +307,7 @@
|
|||
(reserve-locals ,(quotient nlocs 256)
|
||||
,(modulo nlocs 256)))))
|
||||
(values code bindings source-alist label-alist object-alist
|
||||
(begin-arity (addr+ addr code) nreq nopt rest? kw arities))))))
|
||||
(begin-arity (addr+ addr code) nreq nopt rest kw arities))))))
|
||||
|
||||
((<glil-bind> vars)
|
||||
(values '()
|
||||
|
|
|
|||
|
|
@ -600,32 +600,65 @@
|
|||
(maybe-emit-return))
|
||||
|
||||
((<lambda-case> src req opt rest kw vars predicate else body)
|
||||
(let ((nlocs (cdr (hashq-ref allocation x)))
|
||||
;; o/~ feature on top of feature o/~
|
||||
;; req := (name ...)
|
||||
;; opt := ((name init) ...) | #f
|
||||
;; rest := name | #f
|
||||
;; kw: (allow-other-keys? (keyword name var [init]) ...) | #f
|
||||
;; vars: (sym ...)
|
||||
;; predicate: tree-il in context of vars
|
||||
;; init: tree-il in context of vars
|
||||
;; vars map to named arguments in the following order:
|
||||
;; required, optional (positional), rest, keyword.
|
||||
(let* ((nreq (length req))
|
||||
(nopt (if opt (length opt) 0))
|
||||
(rest-idx (and rest (+ nreq nopt)))
|
||||
(opt-inits (map cdr (or opt '())))
|
||||
(allow-other-keys? (if kw (car kw) #f))
|
||||
(kw-indices (map (lambda (x)
|
||||
(pmatch x
|
||||
((,key ,name ,var . _)
|
||||
(cons key (list-index vars var)))
|
||||
(else (error "bad kwarg" x))))
|
||||
(if kw (cdr kw) '())))
|
||||
(kw-inits (filter
|
||||
identity
|
||||
(map (lambda (x)
|
||||
(pmatch x
|
||||
((,key ,name ,var ,init)
|
||||
(let ((i (list-index vars var)))
|
||||
(if (> (+ nreq nopt) i)
|
||||
(error "kw init for rest arg" x)
|
||||
(if (and rest (= rest-idx i))
|
||||
(error "kw init for positional arg" x)
|
||||
(cons i init)))))
|
||||
((,key ,name ,var)
|
||||
(let ((i (list-index vars var)))
|
||||
(if (< (+ nreq nopt) i)
|
||||
#f
|
||||
(error "missing init for kw arg" x))))
|
||||
(else (error "bad kwarg" x))))
|
||||
(if kw (cdr kw) '()))))
|
||||
(nargs (apply max (+ nreq nopt (if rest 1 0)) (map cdr kw-indices)))
|
||||
(nlocs (cdr (hashq-ref allocation x)))
|
||||
(else-label (and else (make-label))))
|
||||
(or (= nargs
|
||||
(length vars)
|
||||
(+ nreq (length opt-inits) (if rest 1 0) (length kw-inits)))
|
||||
(error "something went wrong"
|
||||
req opt rest kw vars nreq nopt kw-indices kw-inits nargs))
|
||||
;; the prelude, to check args & reset the stack pointer,
|
||||
;; allowing room for locals
|
||||
(emit-code
|
||||
src
|
||||
(cond
|
||||
;; kw := (allow-other-keys? (#:key name var) ...)
|
||||
(kw
|
||||
(make-glil-kw-prelude
|
||||
(length req) (length (or opt '())) (and rest #t)
|
||||
(map (lambda (x)
|
||||
(pmatch x
|
||||
((,key ,name ,var)
|
||||
(cons key
|
||||
(pmatch (hashq-ref (hashq-ref allocation var) self)
|
||||
((#t ,boxed . ,n) n)
|
||||
(,a (error "bad keyword allocation" x a)))))
|
||||
(,x (error "bad keyword" x))))
|
||||
(cdr kw))
|
||||
(car kw) nlocs else-label))
|
||||
(make-glil-kw-prelude nreq nopt rest-idx kw-indices
|
||||
allow-other-keys? nlocs else-label))
|
||||
((or rest opt)
|
||||
(make-glil-opt-prelude
|
||||
(length req) (length (or opt '())) (and rest #t) nlocs else-label))
|
||||
(make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
|
||||
(#t
|
||||
(make-glil-std-prelude (length req) nlocs else-label))))
|
||||
(make-glil-std-prelude nreq nlocs else-label))))
|
||||
;; box args if necessary
|
||||
(for-each
|
||||
(lambda (v)
|
||||
|
|
@ -641,11 +674,12 @@
|
|||
(let lp ((kw (if kw (cdr kw) '()))
|
||||
(names (append (if opt (reverse opt) '())
|
||||
(reverse req)))
|
||||
(vars (list-tail vars (+ (length req)
|
||||
(if opt (length opt) 0)
|
||||
(vars (list-tail vars (+ nreq nopt
|
||||
(if rest 1 0)))))
|
||||
(pmatch kw
|
||||
(() (reverse (if rest (cons rest names) names)))
|
||||
(()
|
||||
;; fixme: check that vars is empty
|
||||
(reverse (if rest (cons rest names) names)))
|
||||
(((,key ,name ,var) . ,kw)
|
||||
(if (memq var vars)
|
||||
(lp kw (cons name names) (delq var vars))
|
||||
|
|
|
|||
|
|
@ -349,7 +349,7 @@
|
|||
(lambda-case ((() #f x #f (y) #f) (const 2))
|
||||
#f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(program () (opt-prelude 0 0 #t 1 #f)
|
||||
(program () (opt-prelude 0 0 0 1 #f)
|
||||
(bind (x #f 0)) (label _)
|
||||
(const 2) (call return 1)
|
||||
(unbind))
|
||||
|
|
@ -360,7 +360,7 @@
|
|||
(lambda-case (((x) #f x1 #f (y y1) #f) (const 2))
|
||||
#f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(program () (opt-prelude 1 0 #t 2 #f)
|
||||
(program () (opt-prelude 1 0 1 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1)) (label _)
|
||||
(const 2) (call return 1)
|
||||
(unbind))
|
||||
|
|
@ -371,7 +371,7 @@
|
|||
(lambda-case (((x) #f x1 #f (y y1) #f) (lexical x y))
|
||||
#f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(program () (opt-prelude 1 0 #t 2 #f)
|
||||
(program () (opt-prelude 1 0 1 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1)) (label _)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind))
|
||||
|
|
@ -382,7 +382,7 @@
|
|||
(lambda-case (((x) #f x1 #f (y y1) #f) (lexical x1 y1))
|
||||
#f))
|
||||
(program () (std-prelude 0 0 #f) (label _)
|
||||
(program () (opt-prelude 1 0 #t 2 #f)
|
||||
(program () (opt-prelude 1 0 1 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1)) (label _)
|
||||
(lexical #t #f ref 1) (call return 1)
|
||||
(unbind))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue