mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-15 18:20:42 +02:00
Code Activity

more work towards compiling and interpreting keyword args

Browse source 
* 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 2009-10-19 22:13:08 +02:00
parent 7e01997e88
commit 899d37a6cf
8 changed files with 2373 additions and 2197 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/_scm.h
View file

@ -172,7 +172,7 @@
/* Major and minor versions must be single characters. */ /* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0 #define SCM_OBJCODE_MAJOR_VERSION 0
#define SCM_OBJCODE_MINOR_VERSION I #define SCM_OBJCODE_MINOR_VERSION J
#define SCM_OBJCODE_MAJOR_VERSION_STRING \ #define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \ #define SCM_OBJCODE_MINOR_VERSION_STRING \

74
libguile/vm-i-system.c
View file

@ -624,7 +624,7 @@ VM_DEFINE_INSTRUCTION (45, bind_kwargs, "bind-kwargs", 5, 0, 0)
NEXT; 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_t_ptrdiff n;
SCM rest = SCM_EOL; SCM rest = SCM_EOL;
@ -637,7 +637,23 @@ VM_DEFINE_INSTRUCTION (46, bind_rest, "bind-rest", 2, -1, -1)
NEXT; 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 *old_sp;
scm_t_int32 n; scm_t_int32 n;
@ -658,7 +674,7 @@ VM_DEFINE_INSTRUCTION (47, reserve_locals, "reserve-locals", 2, -1, -1)
NEXT; 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 */ /* NB: if you change this, see frames.c:vm-frame-num-locals */
/* and frames.h, vm-engine.c, etc of course */ /* 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; NEXT;
} }
VM_DEFINE_INSTRUCTION (49, call, "call", 1, -1, 1) VM_DEFINE_INSTRUCTION (50, call, "call", 1, -1, 1)
{ {
SCM x; SCM x;
nargs = FETCH (); nargs = FETCH ();
@ -729,7 +745,7 @@ VM_DEFINE_INSTRUCTION (49, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply; 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; register SCM x;
nargs = FETCH (); nargs = FETCH ();
@ -802,7 +818,7 @@ VM_DEFINE_INSTRUCTION (50, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply; 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; SCM x;
POP (x); POP (x);
@ -811,7 +827,7 @@ VM_DEFINE_INSTRUCTION (51, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args; 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; SCM x;
POP (x); POP (x);
@ -820,7 +836,7 @@ VM_DEFINE_INSTRUCTION (52, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call; 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 x;
scm_t_int32 offset; 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; 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; int len;
SCM ls; SCM ls;
@ -901,7 +917,7 @@ VM_DEFINE_INSTRUCTION (54, apply, "apply", 1, -1, 1)
goto vm_call; 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; int len;
SCM ls; SCM ls;
@ -920,7 +936,7 @@ VM_DEFINE_INSTRUCTION (55, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args; 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; int first;
SCM proc, cont; 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; int first;
SCM proc, cont; 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: vm_return:
EXIT_HOOK (); EXIT_HOOK ();
@ -1025,7 +1041,7 @@ VM_DEFINE_INSTRUCTION (58, return, "return", 0, 1, 1)
NEXT; 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 /* 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. */ 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; 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; SCM l;
@ -1103,7 +1119,7 @@ VM_DEFINE_INSTRUCTION (60, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values; 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; SCM x;
int nbinds, rest; int nbinds, rest;
@ -1126,7 +1142,7 @@ VM_DEFINE_INSTRUCTION (61, truncate_values, "truncate-values", 2, -1, -1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (62, box, "box", 1, 1, 0) VM_DEFINE_INSTRUCTION (63, box, "box", 1, 1, 0)
{ {
SCM val; SCM val;
POP (val); POP (val);
@ -1140,7 +1156,7 @@ VM_DEFINE_INSTRUCTION (62, box, "box", 1, 1, 0)
(set! a (lambda () (b ...))) (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 (); SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (), LOCAL_SET (FETCH (),
@ -1148,7 +1164,7 @@ VM_DEFINE_INSTRUCTION (63, empty_box, "empty-box", 1, 0, 0)
NEXT; 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 ()); SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v); ASSERT_BOUND_VARIABLE (v);
@ -1156,7 +1172,7 @@ VM_DEFINE_INSTRUCTION (64, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT; 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; SCM v, val;
v = LOCAL_REF (FETCH ()); v = LOCAL_REF (FETCH ());
@ -1166,7 +1182,7 @@ VM_DEFINE_INSTRUCTION (65, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT; 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 (); 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 */ /* 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 v;
scm_t_uint8 idx = FETCH (); scm_t_uint8 idx = FETCH ();
@ -1188,7 +1204,7 @@ VM_DEFINE_INSTRUCTION (67, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT; 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 v, val;
scm_t_uint8 idx = FETCH (); scm_t_uint8 idx = FETCH ();
@ -1200,7 +1216,7 @@ VM_DEFINE_INSTRUCTION (68, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT; 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; SCM vect;
POP (vect); POP (vect);
@ -1211,7 +1227,7 @@ VM_DEFINE_INSTRUCTION (69, make_closure, "make-closure", 0, 2, 1)
NEXT; 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 (); SYNC_BEFORE_GC ();
/* fixme underflow */ /* fixme underflow */
@ -1219,7 +1235,7 @@ VM_DEFINE_INSTRUCTION (70, make_variable, "make-variable", 0, 0, 1)
NEXT; 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; SCM x, vect;
unsigned int i = FETCH (); unsigned int i = FETCH ();
@ -1233,7 +1249,7 @@ VM_DEFINE_INSTRUCTION (71, fix_closure, "fix-closure", 2, 0, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (72, define, "define", 0, 0, 2) VM_DEFINE_INSTRUCTION (73, define, "define", 0, 0, 2)
{ {
SCM sym, val; SCM sym, val;
POP (sym); POP (sym);
@ -1245,7 +1261,7 @@ VM_DEFINE_INSTRUCTION (72, define, "define", 0, 0, 2)
NEXT; 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 (); CHECK_UNDERFLOW ();
SYNC_REGISTER (); SYNC_REGISTER ();
@ -1253,7 +1269,7 @@ VM_DEFINE_INSTRUCTION (73, make_keyword, "make-keyword", 0, 1, 1)
NEXT; 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 (); CHECK_UNDERFLOW ();
SYNC_REGISTER (); SYNC_REGISTER ();

4294
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

62
module/ice-9/psyntax.scm
View file

@ -482,26 +482,64 @@
src))))) src)))))
(define build-lambda-case (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) (lambda (src req opt rest kw vars predicate body else-case)
(case (fluid-ref *mode*) (case (fluid-ref *mode*)
((c) ((c)
((@ (language tree-il) make-lambda-case) ((@ (language tree-il) make-lambda-case)
src req opt rest kw vars predicate body else-case)) src req opt rest kw vars predicate body else-case))
(else (else
(let ((nkw (map (lambda (x) ;; Very much like the logic of (language tree-il compile-glil).
`(list ,(car x) (let* ((nreq (length req))
;; grr (nopt (if opt (length opt) 0))
,(let lp ((vars vars) (i 0)) (rest-idx (and rest (+ nreq nopt)))
(cond ((null? vars) (error "bad kwarg" x)) (opt-inits (map (lambda (x) `(lambda ,vars ,(cdr x)))
((eq? (cadr x) (car vars)) i) (or opt '())))
(else (lp (cdr vars) (1+ i))))) (allow-other-keys? (if kw (car kw) #f))
(lambda () ,(caddr x)))) (kw-indices (map (lambda (x)
kw))) ;; (,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 (decorate-source
`((((@@ (ice-9 optargs) parse-lambda-case) `((((@@ (ice-9 optargs) parse-lambda-case)
(list ,(length req) ,(length opt) ,(and rest #t) ,nkw '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices)
,(if predicate (error "not yet implemented") #f)) (list ,@opt-inits ,@kw-inits)
,(if predicate `(lambda ,vars ,predicate) #f)
%%args) %%args)
=> (lambda ,vars ,body)) => (lambda ,vars ,body))
,@(or else-case ,@(or else-case

24
module/language/glil.scm
View file

@ -30,12 +30,12 @@
glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label 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> 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-opt-prelude-nlocs glil-opt-prelude-else-label
<glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude? <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-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-kw-prelude-nlocs glil-kw-prelude-else-label
<glil-bind> make-glil-bind glil-bind? <glil-bind> make-glil-bind glil-bind?
@ -84,8 +84,8 @@
;; Meta operations ;; Meta operations
(<glil-program> meta body) (<glil-program> meta body)
(<glil-std-prelude> nreq nlocs else-label) (<glil-std-prelude> nreq nlocs else-label)
(<glil-opt-prelude> nreq nopt rest? 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-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label)
(<glil-bind> vars) (<glil-bind> vars)
(<glil-mv-bind> vars rest) (<glil-mv-bind> vars rest)
(<glil-unbind>) (<glil-unbind>)
@ -111,10 +111,10 @@
(make-glil-program meta (map parse-glil body))) (make-glil-program meta (map parse-glil body)))
((std-prelude ,nreq ,nlocs ,else-label) ((std-prelude ,nreq ,nlocs ,else-label)
(make-glil-std-prelude nreq nlocs else-label)) (make-glil-std-prelude nreq nlocs else-label))
((opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label) ((opt-prelude ,nreq ,nopt ,rest ,nlocs ,else-label)
(make-glil-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) ((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)) (make-glil-kw-prelude nreq nopt rest kw allow-other-keys? nlocs else-label))
((bind . ,vars) (make-glil-bind vars)) ((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest)) ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind)) ((unbind) (make-glil-unbind))
@ -138,10 +138,10 @@
`(program ,meta ,@(map unparse-glil body))) `(program ,meta ,@(map unparse-glil body)))
((<glil-std-prelude> nreq nlocs else-label) ((<glil-std-prelude> nreq nlocs else-label)
`(std-prelude ,nreq ,nlocs ,else-label)) `(std-prelude ,nreq ,nlocs ,else-label))
((<glil-opt-prelude> nreq nopt rest? nlocs else-label) ((<glil-opt-prelude> nreq nopt rest nlocs else-label)
`(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) ((<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)) `(kw-prelude ,nreq ,nopt ,rest ,kw ,allow-other-keys? ,nlocs ,else-label))
((<glil-bind> vars) `(bind ,@vars)) ((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest)) ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind)) ((<glil-unbind>) `(unbind))

30
module/language/glil/compile-assembly.scm
View file

@ -134,12 +134,12 @@
(and (not (null? objects)) (and (not (null? objects))
(list->vector (cons #f objects)))) (list->vector (cons #f objects))))
;; arities := ((ip nreq [[nopt] [[rest?] [kw]]]]) ...) ;; arities := ((ip nreq [[nopt] [[rest] [kw]]]]) ...)
(define (begin-arity addr nreq nopt rest? kw arities) (define (begin-arity addr nreq nopt rest kw arities)
(cons (cons
(cond (cond
(kw (list addr nreq nopt rest? kw)) (kw (list addr nreq nopt rest kw))
(rest? (list addr nreq nopt rest?)) (rest (list addr nreq nopt rest))
(nopt (list addr nreq nopt)) (nopt (list addr nreq nopt))
(nreq (list addr nreq)) (nreq (list addr nreq))
(else (list addr))) (else (list addr)))
@ -151,9 +151,9 @@
(values x bindings source-alist label-alist object-alist arities)) (values x bindings source-alist label-alist object-alist arities))
(define (emit-code/object x object-alist) (define (emit-code/object x object-alist)
(values x bindings source-alist label-alist object-alist arities)) (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 (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 (record-case glil
((<glil-program> meta body) ((<glil-program> meta body)
@ -230,7 +230,7 @@
,(modulo nlocs 256))) ,(modulo nlocs 256)))
nreq #f #f #f)) 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 (let ((bind-required
(if else-label (if else-label
`((br-if-nargs-lt ,(quotient nreq 256) `((br-if-nargs-lt ,(quotient nreq 256)
@ -245,8 +245,8 @@
,(modulo (+ nreq nopt) 256))))) ,(modulo (+ nreq nopt) 256)))))
(bind-rest (bind-rest
(cond (cond
(rest? (rest
`((bind-rest ,(quotient (+ nreq nopt) 256) `((push-rest ,(quotient (+ nreq nopt) 256)
,(modulo (+ nreq nopt) 256)))) ,(modulo (+ nreq nopt) 256))))
(else (else
(if else-label (if else-label
@ -261,9 +261,9 @@
,@bind-rest ,@bind-rest
(reserve-locals ,(quotient nlocs 256) (reserve-locals ,(quotient nlocs 256)
,(modulo 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) (receive (kw-idx object-alist)
(object-index-and-alist object-alist kw) (object-index-and-alist object-alist kw)
(let ((bind-required (let ((bind-required
@ -293,9 +293,11 @@
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256) ,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)
,(if allow-other-keys? 1 0)))) ,(if allow-other-keys? 1 0))))
(bind-rest (bind-rest
(if rest? (if rest
`((bind-rest ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256) `((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 (let ((code `(,@bind-required
@ -305,7 +307,7 @@
(reserve-locals ,(quotient nlocs 256) (reserve-locals ,(quotient nlocs 256)
,(modulo nlocs 256))))) ,(modulo nlocs 256)))))
(values code bindings source-alist label-alist object-alist (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) ((<glil-bind> vars)
(values '() (values '()

76
module/language/tree-il/compile-glil.scm
View file

@ -600,32 +600,65 @@
(maybe-emit-return)) (maybe-emit-return))
((<lambda-case> src req opt rest kw vars predicate else body) ((<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/~
(else-label (and else (make-label)))) ;; 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, ;; the prelude, to check args & reset the stack pointer,
;; allowing room for locals ;; allowing room for locals
(emit-code (emit-code
src src
(cond (cond
;; kw := (allow-other-keys? (#:key name var) ...)
(kw (kw
(make-glil-kw-prelude (make-glil-kw-prelude nreq nopt rest-idx kw-indices
(length req) (length (or opt '())) (and rest #t) allow-other-keys? nlocs else-label))
(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))
((or rest opt) ((or rest opt)
(make-glil-opt-prelude (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
(length req) (length (or opt '())) (and rest #t) nlocs else-label))
(#t (#t
(make-glil-std-prelude (length req) nlocs else-label)))) (make-glil-std-prelude nreq nlocs else-label))))
;; box args if necessary ;; box args if necessary
(for-each (for-each
(lambda (v) (lambda (v)
@ -641,11 +674,12 @@
(let lp ((kw (if kw (cdr kw) '())) (let lp ((kw (if kw (cdr kw) '()))
(names (append (if opt (reverse opt) '()) (names (append (if opt (reverse opt) '())
(reverse req))) (reverse req)))
(vars (list-tail vars (+ (length req) (vars (list-tail vars (+ nreq nopt
(if opt (length opt) 0)
(if rest 1 0))))) (if rest 1 0)))))
(pmatch kw (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) (((,key ,name ,var) . ,kw)
(if (memq var vars) (if (memq var vars)
(lp kw (cons name names) (delq var vars)) (lp kw (cons name names) (delq var vars))

8
test-suite/tests/tree-il.test
View file

@ -349,7 +349,7 @@
(lambda-case ((() #f x #f (y) #f) (const 2)) (lambda-case ((() #f x #f (y) #f) (const 2))
#f)) #f))
(program () (std-prelude 0 0 #f) (label _) (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 _) (bind (x #f 0)) (label _)
(const 2) (call return 1) (const 2) (call return 1)
(unbind)) (unbind))
@ -360,7 +360,7 @@
(lambda-case (((x) #f x1 #f (y y1) #f) (const 2)) (lambda-case (((x) #f x1 #f (y y1) #f) (const 2))
#f)) #f))
(program () (std-prelude 0 0 #f) (label _) (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 _) (bind (x #f 0) (x1 #f 1)) (label _)
(const 2) (call return 1) (const 2) (call return 1)
(unbind)) (unbind))
@ -371,7 +371,7 @@
(lambda-case (((x) #f x1 #f (y y1) #f) (lexical x y)) (lambda-case (((x) #f x1 #f (y y1) #f) (lexical x y))
#f)) #f))
(program () (std-prelude 0 0 #f) (label _) (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 _) (bind (x #f 0) (x1 #f 1)) (label _)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(unbind)) (unbind))
@ -382,7 +382,7 @@
(lambda-case (((x) #f x1 #f (y y1) #f) (lexical x1 y1)) (lambda-case (((x) #f x1 #f (y y1) #f) (lexical x1 y1))
#f)) #f))
(program () (std-prelude 0 0 #f) (label _) (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 _) (bind (x #f 0) (x1 #f 1)) (label _)
(lexical #t #f ref 1) (call return 1) (lexical #t #f ref 1) (call return 1)
(unbind)) (unbind))