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

steps on the way to have the callee check the number of arguments

Browse source 
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.

* libguile/vm-i-system.c (assert-nargs-ee, assert-nargs-ge)
  (push-rest-list): New instructions, which for now don't actually do
  anything. Renumber the rest of the ops in this file.

* module/language/glil.scm (<glil-arity>): New GLIL type, an entity that
  checks the number of args for a block, optionally consing a rest list,
  and either branching or erroring if the arity doesn't match.

* module/language/glil/compile-assembly.scm (glil->assembly): Compile
  <glil-arity> to assembly. Some of these VM ops are not implemented --
  notably the branching case.

* module/language/tree-il/compile-glil.scm (flatten-lambda): Emit
  <glil-arity>.

* test-suite/tests/tree-il.test: Update.
This commit is contained in:
Andy Wingo 2009-09-27 18:16:56 -04:00
parent 04c68c0391
commit 1e2a8c266d
6 changed files with 172 additions and 104 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 E #define SCM_OBJCODE_MINOR_VERSION F
#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 \

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

@ -476,7 +476,46 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 3, 0, 0)
* Subprogram call * Subprogram call
*/ */
VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3) VM_DEFINE_INSTRUCTION (38, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
#if 0
if (sp - fp != n)
goto vm_error_wrong_num_args;
#endif
NEXT;
}
VM_DEFINE_INSTRUCTION (39, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
#if 0
if (sp - fp < n)
goto vm_error_wrong_num_args;
#endif
NEXT;
}
VM_DEFINE_INSTRUCTION (40, push_rest_list, "push-rest-list", 2, -1, -1)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
#if 0
SCM rest = SCM_EOL;
while (sp - fp >= n)
/* No need to check for underflow. */
CONS (rest, *sp--, rest);
PUSH (rest);
#endif
NEXT;
}
VM_DEFINE_INSTRUCTION (41, new_frame, "new-frame", 0, 0, 3)
{ {
PUSH ((SCM)fp); /* dynamic link */ PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */ PUSH (0); /* mvra */
@ -484,7 +523,7 @@ VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) VM_DEFINE_INSTRUCTION (42, call, "call", 1, -1, 1)
{ {
SCM x; SCM x;
nargs = FETCH (); nargs = FETCH ();
@ -546,7 +585,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply; goto vm_error_wrong_type_apply;
} }
VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) VM_DEFINE_INSTRUCTION (43, goto_args, "goto/args", 1, -1, 1)
{ {
register SCM x; register SCM x;
nargs = FETCH (); nargs = FETCH ();
@ -625,7 +664,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply; goto vm_error_wrong_type_apply;
} }
VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1) VM_DEFINE_INSTRUCTION (44, goto_nargs, "goto/nargs", 0, 0, 1)
{ {
SCM x; SCM x;
POP (x); POP (x);
@ -634,7 +673,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args; goto vm_goto_args;
} }
VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1) VM_DEFINE_INSTRUCTION (45, call_nargs, "call/nargs", 0, 0, 1)
{ {
SCM x; SCM x;
POP (x); POP (x);
@ -643,7 +682,7 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call; goto vm_call;
} }
VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1) VM_DEFINE_INSTRUCTION (46, mv_call, "mv-call", 4, -1, 1)
{ {
SCM x; SCM x;
scm_t_int32 offset; scm_t_int32 offset;
@ -706,7 +745,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
goto vm_error_wrong_type_apply; goto vm_error_wrong_type_apply;
} }
VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1) VM_DEFINE_INSTRUCTION (47, apply, "apply", 1, -1, 1)
{ {
int len; int len;
SCM ls; SCM ls;
@ -725,7 +764,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
goto vm_call; goto vm_call;
} }
VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1) VM_DEFINE_INSTRUCTION (48, goto_apply, "goto/apply", 1, -1, 1)
{ {
int len; int len;
SCM ls; SCM ls;
@ -744,7 +783,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args; goto vm_goto_args;
} }
VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1) VM_DEFINE_INSTRUCTION (49, call_cc, "call/cc", 0, 1, 1)
{ {
int first; int first;
SCM proc, cont; SCM proc, cont;
@ -781,7 +820,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
} }
} }
VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1) VM_DEFINE_INSTRUCTION (50, goto_cc, "goto/cc", 0, 1, 1)
{ {
int first; int first;
SCM proc, cont; SCM proc, cont;
@ -813,7 +852,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
} }
} }
VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) VM_DEFINE_INSTRUCTION (51, return, "return", 0, 1, 1)
{ {
vm_return: vm_return:
EXIT_HOOK (); EXIT_HOOK ();
@ -850,7 +889,7 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1) VM_DEFINE_INSTRUCTION (52, 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. */
@ -907,7 +946,7 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1) VM_DEFINE_INSTRUCTION (53, return_values_star, "return/values*", 1, -1, -1)
{ {
SCM l; SCM l;
@ -930,7 +969,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values; goto vm_return_values;
} }
VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) VM_DEFINE_INSTRUCTION (54, truncate_values, "truncate-values", 2, -1, -1)
{ {
SCM x; SCM x;
int nbinds, rest; int nbinds, rest;
@ -953,7 +992,7 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0) VM_DEFINE_INSTRUCTION (55, box, "box", 1, 1, 0)
{ {
SCM val; SCM val;
POP (val); POP (val);
@ -967,7 +1006,7 @@ VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
(set! a (lambda () (b ...))) (set! a (lambda () (b ...)))
...) ...)
*/ */
VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0) VM_DEFINE_INSTRUCTION (56, empty_box, "empty-box", 1, 0, 0)
{ {
SYNC_BEFORE_GC (); SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (), LOCAL_SET (FETCH (),
@ -975,7 +1014,7 @@ VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (57, 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);
@ -983,7 +1022,7 @@ VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0) VM_DEFINE_INSTRUCTION (58, local_boxed_set, "local-boxed-set", 1, 1, 0)
{ {
SCM v, val; SCM v, val;
v = LOCAL_REF (FETCH ()); v = LOCAL_REF (FETCH ());
@ -993,7 +1032,7 @@ VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (59, free_ref, "free-ref", 1, 0, 1)
{ {
scm_t_uint8 idx = FETCH (); scm_t_uint8 idx = FETCH ();
@ -1004,7 +1043,7 @@ VM_DEFINE_INSTRUCTION (56, 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 (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (60, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{ {
SCM v; SCM v;
scm_t_uint8 idx = FETCH (); scm_t_uint8 idx = FETCH ();
@ -1015,7 +1054,7 @@ VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0) VM_DEFINE_INSTRUCTION (61, 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 ();
@ -1027,7 +1066,7 @@ VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1) VM_DEFINE_INSTRUCTION (62, make_closure, "make-closure", 0, 2, 1)
{ {
SCM vect; SCM vect;
POP (vect); POP (vect);
@ -1038,7 +1077,7 @@ VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1) VM_DEFINE_INSTRUCTION (63, make_variable, "make-variable", 0, 0, 1)
{ {
SYNC_BEFORE_GC (); SYNC_BEFORE_GC ();
/* fixme underflow */ /* fixme underflow */
@ -1046,7 +1085,7 @@ VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1) VM_DEFINE_INSTRUCTION (64, fix_closure, "fix-closure", 2, 0, 1)
{ {
SCM x, vect; SCM x, vect;
unsigned int i = FETCH (); unsigned int i = FETCH ();
@ -1060,7 +1099,7 @@ VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2) VM_DEFINE_INSTRUCTION (65, define, "define", 0, 0, 2)
{ {
SCM sym, val; SCM sym, val;
POP (sym); POP (sym);
@ -1072,7 +1111,7 @@ VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1) VM_DEFINE_INSTRUCTION (66, make_keyword, "make-keyword", 0, 1, 1)
{ {
CHECK_UNDERFLOW (); CHECK_UNDERFLOW ();
SYNC_REGISTER (); SYNC_REGISTER ();
@ -1080,7 +1119,7 @@ VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
NEXT; NEXT;
} }
VM_DEFINE_INSTRUCTION (64, make_symbol, "make-symbol", 0, 1, 1) VM_DEFINE_INSTRUCTION (67, make_symbol, "make-symbol", 0, 1, 1)
{ {
CHECK_UNDERFLOW (); CHECK_UNDERFLOW ();
SYNC_REGISTER (); SYNC_REGISTER ();

6
module/language/glil.scm
View file

@ -27,6 +27,9 @@
glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body glil-program-meta glil-program-body
<glil-arity> make-glil-arity glil-arity?
glil-arity-nargs glil-arity-nrest glil-arity-label
<glil-bind> make-glil-bind glil-bind? <glil-bind> make-glil-bind glil-bind?
glil-bind-vars glil-bind-vars
@ -72,6 +75,7 @@
(define-type (<glil> #:printer print-glil) (define-type (<glil> #:printer print-glil)
;; Meta operations ;; Meta operations
(<glil-program> nargs nrest nlocs meta body) (<glil-program> nargs nrest nlocs meta body)
(<glil-arity> nargs nrest label)
(<glil-bind> vars) (<glil-bind> vars)
(<glil-mv-bind> vars rest) (<glil-mv-bind> vars rest)
(<glil-unbind>) (<glil-unbind>)
@ -95,6 +99,7 @@
(pmatch x (pmatch x
((program ,nargs ,nrest ,nlocs ,meta . ,body) ((program ,nargs ,nrest ,nlocs ,meta . ,body)
(make-glil-program nargs nrest nlocs meta (map parse-glil body))) (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((arity ,nargs ,nrest ,label) (make-glil-arity nargs nrest 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))
@ -116,6 +121,7 @@
;; meta ;; meta
((<glil-program> nargs nrest nlocs meta body) ((<glil-program> nargs nrest nlocs meta body)
`(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body))) `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-arity> nargs nrest label) `(arity ,nargs ,nrest ,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))

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

@ -356,6 +356,26 @@
((<glil-branch> inst label) ((<glil-branch> inst label)
(emit-code `((,inst ,label)))) (emit-code `((,inst ,label))))
((<glil-arity> nargs nrest label)
(emit-code (if label
(if (zero? nrest)
`((br-if-nargs-ne ,(quotient nargs 256) ,label))
`(,@(if (> nargs 1)
`((br-if-nargs-lt ,(quotient (1- nargs) 256)
,(modulo (1- nargs 256))
,label))
'())
(push-rest-list ,(quotient (1- nargs) 256))))
(if (zero? nrest)
`((assert-nargs-ee ,(quotient nargs 256)
,(modulo nargs 256)))
`(,@(if (> nargs 1)
`((assert-nargs-ge ,(quotient (1- nargs) 256)
,(modulo (1- nargs) 256)))
'())
(push-rest-list ,(quotient (1- nargs) 256)
,(modulo (1- nargs) 256)))))))
;; nargs is number of stack args to insn. probably should rename. ;; nargs is number of stack args to insn. probably should rename.
((<glil-call> inst nargs) ((<glil-call> inst nargs)
(if (not (instruction? inst)) (if (not (instruction? inst))

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

@ -189,14 +189,17 @@
nargs nrest nlocs (lambda-meta x) nargs nrest nlocs (lambda-meta x)
(with-output-to-code (with-output-to-code
(lambda (emit-code) (lambda (emit-code)
;; emit label for self tail calls ;; write source info for proc
(if self-label
(emit-code #f (make-glil-label self-label)))
;; write bindings and source debugging info
(if (not (null? ids))
(emit-bindings #f ids vars allocation x emit-code))
(if (lambda-src x) (if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x)))) (emit-code #f (make-glil-source (lambda-src x))))
;; check arity, potentially consing a rest list
(emit-code #f (make-glil-arity nargs nrest #f))
;; write bindings info
(if (not (null? ids))
(emit-bindings #f ids vars allocation x emit-code))
;; emit post-prelude label for self tail calls
(if self-label
(emit-code #f (make-glil-label self-label)))
;; box args if necessary ;; box args if necessary
(for-each (for-each
(lambda (v) (lambda (v)

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

@ -69,21 +69,21 @@
(with-test-prefix "void" (with-test-prefix "void"
(assert-tree-il->glil (assert-tree-il->glil
(void) (void)
(program 0 0 0 () (void) (call return 1))) (program 0 0 0 () (arity 0 0 #f) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (void) (const 1)) (begin (void) (const 1))
(program 0 0 0 () (const 1) (call return 1))) (program 0 0 0 () (arity 0 0 #f) (const 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive +) (void) (const 1)) (apply (primitive +) (void) (const 1))
(program 0 0 0 () (void) (call add1 1) (call return 1)))) (program 0 0 0 () (arity 0 0 #f) (void) (call add1 1) (call return 1))))
(with-test-prefix "application" (with-test-prefix "application"
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (const 1)) (apply (toplevel foo) (const 1))
(program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1)))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(begin (apply (toplevel foo) (const 1)) (void)) (begin (apply (toplevel foo) (const 1)) (void))
(program 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (program 0 0 0 () (arity 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (call drop 1) (branch br ,l2)
(label ,l3) (mv-bind () #f) (unbind) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -91,26 +91,26 @@
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar))) (apply (toplevel foo) (apply (toplevel bar)))
(program 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) (program 0 0 0 () (arity 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call goto/args 1)))) (call goto/args 1))))
(with-test-prefix "conditional" (with-test-prefix "conditional"
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(if (const #t) (const 1) (const 2)) (if (const #t) (const 1) (const 2))
(program 0 0 0 () (const #t) (branch br-if-not ,l1) (program 0 0 0 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1)
(const 1) (call return 1) (const 1) (call return 1)
(label ,l2) (const 2) (call return 1)) (label ,l2) (const 2) (call return 1))
(eq? l1 l2)) (eq? l1 l2))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(begin (if (const #t) (const 1) (const 2)) (const #f)) (begin (if (const #t) (const 1) (const 2)) (const #f))
(program 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) (program 0 0 0 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1)) (label ,l3) (label ,l4) (const #f) (call return 1))
(eq? l1 l3) (eq? l2 l4)) (eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(apply (primitive null?) (if (const #t) (const 1) (const 2))) (apply (primitive null?) (if (const #t) (const 1) (const 2)))
(program 0 0 0 () (const #t) (branch br-if-not ,l1) (program 0 0 0 () (arity 0 0 #f) (const #t) (branch br-if-not ,l1)
(const 1) (branch br ,l2) (const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4) (label ,l3) (const 2) (label ,l4)
(call null? 1) (call return 1)) (call null? 1) (call return 1))
@ -119,35 +119,35 @@
(with-test-prefix "primitive-ref" (with-test-prefix "primitive-ref"
(assert-tree-il->glil (assert-tree-il->glil
(primitive +) (primitive +)
(program 0 0 0 () (toplevel ref +) (call return 1))) (program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (primitive +) (const #f)) (begin (primitive +) (const #f))
(program 0 0 0 () (const #f) (call return 1))) (program 0 0 0 () (arity 0 0 #f) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (primitive +)) (apply (primitive null?) (primitive +))
(program 0 0 0 () (toplevel ref +) (call null? 1) (program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call null? 1)
(call return 1)))) (call return 1))))
(with-test-prefix "lexical refs" (with-test-prefix "lexical refs"
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (lexical x y)) (let (x) (y) ((const 1)) (lexical x y))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1) (const #f) (call return 1)
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1) (lexical #t #f ref 0) (call null? 1) (call return 1)
(unbind)))) (unbind))))
@ -157,7 +157,7 @@
;; unreferenced sets may be optimized away -- make sure they are ref'd ;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))) (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(void) (call return 1) (void) (call return 1)
@ -167,7 +167,7 @@
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
(lexical x y))) (lexical x y)))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
(lexical #t #t ref 0) (call return 1) (lexical #t #t ref 0) (call return 1)
@ -177,7 +177,7 @@
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(apply (primitive null?) (apply (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))) (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
(call null? 1) (call return 1) (call null? 1) (call return 1)
@ -186,205 +186,205 @@
(with-test-prefix "module refs" (with-test-prefix "module refs"
(assert-tree-il->glil (assert-tree-il->glil
(@ (foo) bar) (@ (foo) bar)
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(module public ref (foo) bar) (module public ref (foo) bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (@ (foo) bar) (const #f)) (begin (@ (foo) bar) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(module public ref (foo) bar) (call drop 1) (module public ref (foo) bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar)) (apply (primitive null?) (@ (foo) bar))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(module public ref (foo) bar) (module public ref (foo) bar)
(call null? 1) (call return 1))) (call null? 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(@@ (foo) bar) (@@ (foo) bar)
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(module private ref (foo) bar) (module private ref (foo) bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (@@ (foo) bar) (const #f)) (begin (@@ (foo) bar) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(module private ref (foo) bar) (call drop 1) (module private ref (foo) bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar)) (apply (primitive null?) (@@ (foo) bar))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(module private ref (foo) bar) (module private ref (foo) bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
(with-test-prefix "module sets" (with-test-prefix "module sets"
(assert-tree-il->glil (assert-tree-il->glil
(set! (@ (foo) bar) (const 2)) (set! (@ (foo) bar) (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (@ (foo) bar) (const 2)) (const #f)) (begin (set! (@ (foo) bar) (const 2)) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2))) (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1))) (void) (call null? 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(set! (@@ (foo) bar) (const 2)) (set! (@@ (foo) bar) (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (@@ (foo) bar) (const 2)) (const #f)) (begin (set! (@@ (foo) bar) (const 2)) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2))) (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel refs" (with-test-prefix "toplevel refs"
(assert-tree-il->glil (assert-tree-il->glil
(toplevel bar) (toplevel bar)
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(toplevel ref bar) (toplevel ref bar)
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (toplevel bar) (const #f)) (begin (toplevel bar) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(toplevel ref bar) (call drop 1) (toplevel ref bar) (call drop 1)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (toplevel bar)) (apply (primitive null?) (toplevel bar))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(toplevel ref bar) (toplevel ref bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
(with-test-prefix "toplevel sets" (with-test-prefix "toplevel sets"
(assert-tree-il->glil (assert-tree-il->glil
(set! (toplevel bar) (const 2)) (set! (toplevel bar) (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (set! (toplevel bar) (const 2)) (const #f)) (begin (set! (toplevel bar) (const 2)) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2))) (apply (primitive null?) (set! (toplevel bar) (const 2)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
(with-test-prefix "toplevel defines" (with-test-prefix "toplevel defines"
(assert-tree-il->glil (assert-tree-il->glil
(define bar (const 2)) (define bar (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call return 1))) (void) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (define bar (const 2)) (const #f)) (begin (define bar (const 2)) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (define bar (const 2))) (apply (primitive null?) (define bar (const 2)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
(with-test-prefix "constants" (with-test-prefix "constants"
(assert-tree-il->glil (assert-tree-il->glil
(const 2) (const 2)
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (call return 1))) (const 2) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (const 2) (const #f)) (begin (const 2) (const #f))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (const 2)) (apply (primitive null?) (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
(with-test-prefix "lambda" (with-test-prefix "lambda"
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (y) () (const 2)) (lambda (x) (y) () (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 1 0 0 () (program 1 0 0 () (arity 1 0 #f)
(bind (x #f 0)) (bind (x #f 0))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x x1) (y y1) () (const 2)) (lambda (x x1) (y y1) () (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 2 0 0 () (program 2 0 0 () (arity 2 0 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda x y () (const 2)) (lambda x y () (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 1 1 0 () (program 1 1 0 () (arity 1 1 #f)
(bind (x #f 0)) (bind (x #f 0))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (const 2)) (lambda (x . x1) (y . y1) () (const 2))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 2 1 0 () (program 2 1 0 () (arity 2 1 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(const 2) (call return 1)) (const 2) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x y)) (lambda (x . x1) (y . y1) () (lexical x y))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 2 1 0 () (program 2 1 0 () (arity 2 1 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(lexical #t #f ref 0) (call return 1)) (lexical #t #f ref 0) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x . x1) (y . y1) () (lexical x1 y1)) (lambda (x . x1) (y . y1) () (lexical x1 y1))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 2 1 0 () (program 2 1 0 () (arity 2 1 #f)
(bind (x #f 0) (x1 #f 1)) (bind (x #f 0) (x1 #f 1))
(lexical #t #f ref 1) (call return 1)) (lexical #t #f ref 1) (call return 1))
(call return 1))) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(program 1 0 0 () (program 1 0 0 () (arity 1 0 #f)
(bind (x #f 0)) (bind (x #f 0))
(program 1 0 0 () (program 1 0 0 () (arity 1 0 #f)
(bind (y #f 0)) (bind (y #f 0))
(lexical #f #f ref 0) (call return 1)) (lexical #f #f ref 0) (call return 1))
(lexical #t #f ref 0) (lexical #t #f ref 0)
@ -396,12 +396,12 @@
(with-test-prefix "sequence" (with-test-prefix "sequence"
(assert-tree-il->glil (assert-tree-il->glil
(begin (begin (const 2) (const #f)) (const #t)) (begin (begin (const 2) (const #f)) (const #t))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const #t) (call return 1))) (const #t) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2))) (apply (primitive null?) (begin (const #f) (const 2)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
;; FIXME: binding info for or-hacked locals might bork the disassembler, ;; FIXME: binding info for or-hacked locals might bork the disassembler,
@ -413,7 +413,7 @@
(lexical x y) (lexical x y)
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical a b)))) (lexical a b))))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
@ -431,7 +431,7 @@
(lexical x y) (lexical x y)
(let (a) (b) ((const 2)) (let (a) (b) ((const 2))
(lexical x y)))) (lexical x y))))
(program 0 0 1 () (program 0 0 1 () (arity 0 0 #f)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (branch br-if-not ,l1) (lexical #t #f ref 0) (branch br-if-not ,l1)
(lexical #t #f ref 0) (call return 1) (lexical #t #f ref 0) (call return 1)
@ -443,10 +443,10 @@
(with-test-prefix "apply" (with-test-prefix "apply"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar)) (apply (primitive @apply) (toplevel foo) (toplevel bar))
(program 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -454,7 +454,7 @@
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(toplevel ref foo) (toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
(call goto/args 1)))) (call goto/args 1))))
@ -462,10 +462,10 @@
(with-test-prefix "call/cc" (with-test-prefix "call/cc"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo)) (apply (primitive @call-with-current-continuation) (toplevel foo))
(program 0 0 0 () (toplevel ref foo) (call goto/cc 1))) (program 0 0 0 () (arity 0 0 #f) (toplevel ref foo) (call goto/cc 1)))
(assert-tree-il->glil/pmatch (assert-tree-il->glil/pmatch
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
(label ,l4) (label ,l4)
@ -474,7 +474,7 @@
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar))) (apply (toplevel @call-with-current-continuation) (toplevel bar)))
(program 0 0 0 () (program 0 0 0 () (arity 0 0 #f)
(toplevel ref foo) (toplevel ref foo)
(toplevel ref bar) (call call/cc 1) (toplevel ref bar) (call call/cc 1)
(call goto/args 1)))) (call goto/args 1))))