[bpt/guile.git] / test-suite / tests / rtl.test

;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (tests bytecode)
  #:use-module (test-suite lib)
  #:use-module (system vm assembler)
  #:use-module (system vm program)
  #:use-module (system vm loader)
  #:use-module (system vm linker)
  #:use-module (system vm debug))

(define (assemble-program instructions)
  "Take the sequence of instructions @var{instructions}, assemble them
into bytecode, link an image, and load that image from memory.  Returns
a procedure."
  (let ((asm (make-assembler)))
    (emit-text asm instructions)
    (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))

(define-syntax-rule (assert-equal val expr)
  (let ((x val))
    (pass-if (object->string x) (equal? expr x))))

(define (return-constant val)
  (assemble-program `((begin-program foo
                                     ((name . foo)))
                      (begin-standard-arity () 2 #f)
                      (load-constant 1 ,val)
                      (return 1)
                      (end-arity)
                      (end-program))))

(define-syntax-rule (assert-constants val ...)
  (begin
    (assert-equal val ((return-constant val)))
    ...))

(with-test-prefix "load-constant"
  (assert-constants
   1
   -1
   0
   most-positive-fixnum
   most-negative-fixnum
   #t
   #\c
   (integer->char 16000)
   3.14
   "foo"
   'foo
   #:foo
   "æ" ;; a non-ASCII Latin-1 string
   "λ" ;; non-ascii, non-latin-1
   '(1 . 2)
   '(1 2 3 4)
   #(1 2 3)
   #("foo" "bar" 'baz)
   #vu8()
   #vu8(1 2 3 4 128 129 130)
   #u32()
   #u32(1 2 3 4 128 129 130 255 1000)
   ;; FIXME: Add more tests for arrays (uniform and otherwise)
   ))

(with-test-prefix "static procedure"
  (assert-equal 42
                (((assemble-program `((begin-program foo
                                                     ((name . foo)))
                                      (begin-standard-arity () 2 #f)
                                      (load-static-procedure 1 bar)
                                      (return 1)
                                      (end-arity)
                                      (end-program)
                                      (begin-program bar
                                                     ((name . bar)))
                                      (begin-standard-arity () 2 #f)
                                      (load-constant 1 42)
                                      (return 1)
                                      (end-arity)
                                      (end-program)))))))

(with-test-prefix "loop"
  (assert-equal (* 999 500)
                (let ((sumto
                       (assemble-program
                        ;; 0: limit
                        ;; 1: n
                        ;; 2: accum
                        '((begin-program countdown
                                         ((name . countdown)))
                          (begin-standard-arity (x) 4 #f)
                          (definition x 1)
                          (br fix-body)
                          (label loop-head)
                          (br-if-= 2 1 #f out)
                          (add 3 2 3)
                          (add1 2 2)
                          (br loop-head)
                          (label fix-body)
                          (load-constant 2 0)
                          (load-constant 3 0)
                          (br loop-head)
                          (label out)
                          (return 3)
                          (end-arity)
                          (end-program)))))
                  (sumto 1000))))

(with-test-prefix "accum"
  (assert-equal (+ 1 2 3)
                (let ((make-accum
                       (assemble-program
                        ;; 0: elt
                        ;; 1: tail
                        ;; 2: head
                        '((begin-program make-accum
                                         ((name . make-accum)))
                          (begin-standard-arity () 3 #f)
                          (load-constant 1 0)
                          (box 1 1)
                          (make-closure 2 accum 1)
                          (free-set! 2 1 0)
                          (return 2)
                          (end-arity)
                          (end-program)
                          (begin-program accum
                                         ((name . accum)))
                          (begin-standard-arity (x) 4 #f)
                          (definition x 1)
                          (free-ref 2 0 0)
                          (box-ref 3 2)
                          (add 3 3 1)
                          (box-set! 2 3)
                          (return 3)
                          (end-arity)
                          (end-program)))))
                  (let ((accum (make-accum)))
                    (accum 1)
                    (accum 2)
                    (accum 3)))))

(with-test-prefix "call"
  (assert-equal 42
                (let ((call ;; (lambda (x) (x))
                       (assemble-program
                        '((begin-program call
                                         ((name . call)))
                          (begin-standard-arity (f) 7 #f)
                          (definition f 1)
                          (mov 5 1)
                          (call 5 1)
                          (receive 2 5 7)
                          (return 2)
                          (end-arity)
                          (end-program)))))
                  (call (lambda () 42))))

  (assert-equal 6
                (let ((call-with-3 ;; (lambda (x) (x 3))
                       (assemble-program
                        '((begin-program call-with-3
                                         ((name . call-with-3)))
                          (begin-standard-arity (f) 7 #f)
                          (definition f 1)
                          (mov 5 1)
                          (load-constant 6 3)
                          (call 5 2)
                          (receive 2 5 7)
                          (return 2)
                          (end-arity)
                          (end-program)))))
                  (call-with-3 (lambda (x) (* x 2))))))

(with-test-prefix "tail-call"
  (assert-equal 3
                (let ((call ;; (lambda (x) (x))
                       (assemble-program
                        '((begin-program call
                                         ((name . call)))
                          (begin-standard-arity (f) 2 #f)
                          (definition f 1)
                          (mov 0 1)
                          (tail-call 1)
                          (end-arity)
                          (end-program)))))
                  (call (lambda () 3))))

  (assert-equal 6
                (let ((call-with-3 ;; (lambda (x) (x 3))
                       (assemble-program
                        '((begin-program call-with-3
                                         ((name . call-with-3)))
                          (begin-standard-arity (f) 2 #f)
                          (definition f 1)
                          (mov 0 1) ;; R0 <- R1
                          (load-constant 1 3) ;; R1 <- 3
                          (tail-call 2)
                          (end-arity)
                          (end-program)))))
                  (call-with-3 (lambda (x) (* x 2))))))

(with-test-prefix "cached-toplevel-ref"
  (assert-equal 5.0
                (let ((get-sqrt-trampoline
                       (assemble-program
                        '((begin-program get-sqrt-trampoline
                                         ((name . get-sqrt-trampoline)))
                          (begin-standard-arity () 2 #f)
                          (current-module 1)
                          (cache-current-module! 1 sqrt-scope)
                          (load-static-procedure 1 sqrt-trampoline)
                          (return 1)
                          (end-arity)
                          (end-program)

                          (begin-program sqrt-trampoline
                                         ((name . sqrt-trampoline)))
                          (begin-standard-arity (x) 3 #f)
                          (definition x 1)
                          (cached-toplevel-box 2 sqrt-scope sqrt #t)
                          (box-ref 0 2)
                          (tail-call 2)
                          (end-arity)
                          (end-program)))))
                  ((get-sqrt-trampoline) 25.0))))

(define *top-val* 0)

(with-test-prefix "cached-toplevel-set!"
  (let ((prev *top-val*))
    (assert-equal (1+ prev)
                  (let ((make-top-incrementor
                         (assemble-program
                          '((begin-program make-top-incrementor
                                           ((name . make-top-incrementor)))
                            (begin-standard-arity () 2 #f)
                            (current-module 1)
                            (cache-current-module! 1 top-incrementor)
                            (load-static-procedure 1 top-incrementor)
                            (return 1)
                            (end-arity)
                            (end-program)

                            (begin-program top-incrementor
                                           ((name . top-incrementor)))
                            (begin-standard-arity () 3 #f)
                            (cached-toplevel-box 1 top-incrementor *top-val* #t)
                            (box-ref 2 1)
                            (add1 2 2)
                            (box-set! 1 2)
                            (reset-frame 1)
                            (return-values)
                            (end-arity)
                            (end-program)))))
                    ((make-top-incrementor))
                    *top-val*))))

(with-test-prefix "cached-module-ref"
  (assert-equal 5.0
                (let ((get-sqrt-trampoline
                       (assemble-program
                        '((begin-program get-sqrt-trampoline
                                         ((name . get-sqrt-trampoline)))
                          (begin-standard-arity () 2 #f)
                          (load-static-procedure 1 sqrt-trampoline)
                          (return 1)
                          (end-arity)
                          (end-program)

                          (begin-program sqrt-trampoline
                                         ((name . sqrt-trampoline)))
                          (begin-standard-arity (x) 3 #f)
                          (definition x 1)
                          (cached-module-box 2 (guile) sqrt #t #t)
                          (box-ref 0 2)
                          (tail-call 2)
                          (end-arity)
                          (end-program)))))
                  ((get-sqrt-trampoline) 25.0))))

(with-test-prefix "cached-module-set!"
  (let ((prev *top-val*))
    (assert-equal (1+ prev)
                  (let ((make-top-incrementor
                         (assemble-program
                          '((begin-program make-top-incrementor
                                           ((name . make-top-incrementor)))
                            (begin-standard-arity () 2 #f)
                            (load-static-procedure 1 top-incrementor)
                            (return 1)
                            (end-arity)
                            (end-program)

                            (begin-program top-incrementor
                                           ((name . top-incrementor)))
                            (begin-standard-arity () 3 #f)
                            (cached-module-box 1 (tests bytecode) *top-val* #f #t)
                            (box-ref 2 1)
                            (add1 2 2)
                            (box-set! 1 2)
                            (return 2)
                            (end-arity)
                            (end-program)))))
                    ((make-top-incrementor))
                    *top-val*))))

(with-test-prefix "debug contexts"
  (let ((return-3 (assemble-program
                   '((begin-program return-3 ((name . return-3)))
                     (begin-standard-arity () 2 #f)
                     (load-constant 1 3)
                     (return 1)
                     (end-arity)
                     (end-program)))))
    (pass-if "program name"
      (and=> (find-program-debug-info (program-code return-3))
             (lambda (pdi)
               (equal? (program-debug-info-name pdi)
                       'return-3))))

    (pass-if "program address"
      (and=> (find-program-debug-info (program-code return-3))
             (lambda (pdi)
               (equal? (program-debug-info-addr pdi)
                       (program-code return-3)))))))

(with-test-prefix "procedure name"
  (pass-if-equal 'foo
      (procedure-name
       (assemble-program
        '((begin-program foo ((name . foo)))
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program))))))

(with-test-prefix "simple procedure arity"
  (pass-if-equal "#<procedure foo ()>"
      (object->string
       (assemble-program
        '((begin-program foo ((name . foo)))
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program)))))
  (pass-if-equal "#<procedure foo (x y)>"
      (object->string
       (assemble-program
        '((begin-program foo ((name . foo)))
          (begin-standard-arity (x y) 3 #f)
          (definition x 1)
          (definition y 2)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program)))))

  (pass-if-equal "#<procedure foo (x #:optional y . z)>"
      (object->string
       (assemble-program
        '((begin-program foo ((name . foo)))
          (begin-opt-arity (x) (y) z 4 #f)
          (definition x 1)
          (definition y 2)
          (definition z 3)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program))))))

(with-test-prefix "procedure docstrings"
  (pass-if-equal "qux qux"
      (procedure-documentation
       (assemble-program
        '((begin-program foo ((name . foo) (documentation . "qux qux")))
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program))))))

(with-test-prefix "procedure properties"
  ;; No properties.
  (pass-if-equal '()
      (procedure-properties
       (assemble-program
        '((begin-program foo ())
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program)))))

  ;; Name and docstring (which actually don't go out to procprops).
  (pass-if-equal '((name . foo)
                   (documentation . "qux qux"))
      (procedure-properties
       (assemble-program
        '((begin-program foo ((name . foo) (documentation . "qux qux")))
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program)))))

  ;; A property that actually needs serialization.
  (pass-if-equal '((name . foo)
                   (documentation . "qux qux")
                   (moo . "mooooooooooooo"))
      (procedure-properties
       (assemble-program
        '((begin-program foo ((name . foo)
                              (documentation . "qux qux")
                              (moo . "mooooooooooooo")))
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program)))))

  ;; Procedure-name still works in this case.
  (pass-if-equal 'foo
      (procedure-name
       (assemble-program
        '((begin-program foo ((name . foo)
                              (documentation . "qux qux")
                              (moo . "mooooooooooooo")))
          (begin-standard-arity () 2 #f)
          (load-constant 1 42)
          (return 1)
          (end-arity)
          (end-program))))))
Commit	Line	Data
691697de	1	;;;; Low-level tests of the bytecode assembler -- mode: scheme; coding: utf-8; --
e78991aa	2	;;;;
4cbe4d72	3	;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
e78991aa AW	4	;;;;
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
691697de	19	(define-module (tests bytecode)
e78991aa	20	#:use-module (test-suite lib)
cb86cbd7 AW	21	#:use-module (system vm assembler)
cb86cbd7 AW	22	#:use-module (system vm program)
4cbc95f1	23	#:use-module (system vm loader)
4dfae1bf	24	#:use-module (system vm linker)
cb86cbd7	25	#:use-module (system vm debug))
e78991aa	26
4dfae1bf AW	27	(define (assemble-program instructions)
4dfae1bf AW	28	"Take the sequence of instructions @var{instructions}, assemble them
691697de	29	into bytecode, link an image, and load that image from memory. Returns
4dfae1bf AW	30	a procedure."
	31	(let ((asm (make-assembler)))
	32	(emit-text asm instructions)
	33	(load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
	34
e78991aa AW	35	(define-syntax-rule (assert-equal val expr)
	36	(let ((x val))
	37	(pass-if (object->string x) (equal? expr x))))
	38
	39	(define (return-constant val)
2a4daafd AW	40	(assemble-program `((begin-program foo
2a4daafd AW	41	((name . foo)))
7396d216 AW	42	(begin-standard-arity () 2 #f)
	43	(load-constant 1 ,val)
	44	(return 1)
3185c907	45	(end-arity)
e78991aa AW	46	(end-program))))
	47
	48	(define-syntax-rule (assert-constants val ...)
	49	(begin
	50	(assert-equal val ((return-constant val)))
	51	...))
	52
	53	(with-test-prefix "load-constant"
	54	(assert-constants
	55	1
	56	-1
	57	0
	58	most-positive-fixnum
	59	most-negative-fixnum
	60	#t
	61	#\c
	62	(integer->char 16000)
	63	3.14
	64	"foo"
	65	'foo
	66	#:foo
	67	"æ" ;; a non-ASCII Latin-1 string
	68	"λ" ;; non-ascii, non-latin-1
	69	'(1 . 2)
	70	'(1 2 3 4)
	71	#(1 2 3)
	72	#("foo" "bar" 'baz)
7bfbc7b1 AW	73	#vu8()
	74	#vu8(1 2 3 4 128 129 130)
	75	#u32()
	76	#u32(1 2 3 4 128 129 130 255 1000)
	77	;; FIXME: Add more tests for arrays (uniform and otherwise)
e78991aa AW	78	))
	79
	80	(with-test-prefix "static procedure"
	81	(assert-equal 42
2a4daafd AW	82	(((assemble-program `((begin-program foo
2a4daafd AW	83	((name . foo)))
7396d216 AW	84	(begin-standard-arity () 2 #f)
	85	(load-static-procedure 1 bar)
	86	(return 1)
3185c907	87	(end-arity)
e78991aa	88	(end-program)
2a4daafd AW	89	(begin-program bar
2a4daafd AW	90	((name . bar)))
7396d216 AW	91	(begin-standard-arity () 2 #f)
	92	(load-constant 1 42)
	93	(return 1)
3185c907	94	(end-arity)
e78991aa AW	95	(end-program)))))))
	96
	97	(with-test-prefix "loop"
	98	(assert-equal (* 999 500)
	99	(let ((sumto
	100	(assemble-program
	101	;; 0: limit
	102	;; 1: n
	103	;; 2: accum
2a4daafd AW	104	'((begin-program countdown
2a4daafd AW	105	((name . countdown)))
7396d216	106	(begin-standard-arity (x) 4 #f)
4cbe4d72	107	(definition x 1)
e78991aa AW	108	(br fix-body)
e78991aa AW	109	(label loop-head)
af95414f	110	(br-if-= 2 1 #f out)
7396d216 AW	111	(add 3 2 3)
7396d216 AW	112	(add1 2 2)
e78991aa AW	113	(br loop-head)
e78991aa AW	114	(label fix-body)
e78991aa	115	(load-constant 2 0)
7396d216	116	(load-constant 3 0)
e78991aa AW	117	(br loop-head)
e78991aa AW	118	(label out)
7396d216	119	(return 3)
3185c907	120	(end-arity)
e78991aa AW	121	(end-program)))))
	122	(sumto 1000))))
	123
	124	(with-test-prefix "accum"
	125	(assert-equal (+ 1 2 3)
	126	(let ((make-accum
	127	(assemble-program
	128	;; 0: elt
	129	;; 1: tail
	130	;; 2: head
2a4daafd AW	131	'((begin-program make-accum
2a4daafd AW	132	((name . make-accum)))
7396d216 AW	133	(begin-standard-arity () 3 #f)
	134	(load-constant 1 0)
	135	(box 1 1)
	136	(make-closure 2 accum 1)
	137	(free-set! 2 1 0)
	138	(return 2)
3185c907	139	(end-arity)
e78991aa	140	(end-program)
2a4daafd AW	141	(begin-program accum
2a4daafd AW	142	((name . accum)))
7396d216	143	(begin-standard-arity (x) 4 #f)
4cbe4d72	144	(definition x 1)
7396d216 AW	145	(free-ref 2 0 0)
	146	(box-ref 3 2)
	147	(add 3 3 1)
	148	(box-set! 2 3)
	149	(return 3)
3185c907	150	(end-arity)
e78991aa AW	151	(end-program)))))
	152	(let ((accum (make-accum)))
	153	(accum 1)
	154	(accum 2)
	155	(accum 3)))))
	156
	157	(with-test-prefix "call"
	158	(assert-equal 42
	159	(let ((call ;; (lambda (x) (x))
	160	(assemble-program
2a4daafd AW	161	'((begin-program call
2a4daafd AW	162	((name . call)))
af95414f	163	(begin-standard-arity (f) 7 #f)
4cbe4d72	164	(definition f 1)
286a0fb3	165	(mov 5 1)
af95414f AW	166	(call 5 1)
	167	(receive 2 5 7)
	168	(return 2)
3185c907	169	(end-arity)
e78991aa AW	170	(end-program)))))
	171	(call (lambda () 42))))
	172
	173	(assert-equal 6
	174	(let ((call-with-3 ;; (lambda (x) (x 3))
	175	(assemble-program
2a4daafd AW	176	'((begin-program call-with-3
2a4daafd AW	177	((name . call-with-3)))
af95414f	178	(begin-standard-arity (f) 7 #f)
4cbe4d72	179	(definition f 1)
286a0fb3 AW	180	(mov 5 1)
286a0fb3 AW	181	(load-constant 6 3)
af95414f AW	182	(call 5 2)
	183	(receive 2 5 7)
	184	(return 2)
3185c907	185	(end-arity)
e78991aa AW	186	(end-program)))))
	187	(call-with-3 (lambda (x) (* x 2))))))
	188
	189	(with-test-prefix "tail-call"
	190	(assert-equal 3
	191	(let ((call ;; (lambda (x) (x))
	192	(assemble-program
2a4daafd AW	193	'((begin-program call
2a4daafd AW	194	((name . call)))
7396d216	195	(begin-standard-arity (f) 2 #f)
4cbe4d72	196	(definition f 1)
af95414f AW	197	(mov 0 1)
af95414f AW	198	(tail-call 1)
3185c907	199	(end-arity)
e78991aa AW	200	(end-program)))))
	201	(call (lambda () 3))))
	202
	203	(assert-equal 6
	204	(let ((call-with-3 ;; (lambda (x) (x 3))
	205	(assemble-program
2a4daafd AW	206	'((begin-program call-with-3
2a4daafd AW	207	((name . call-with-3)))
af95414f	208	(begin-standard-arity (f) 2 #f)
4cbe4d72	209	(definition f 1)
af95414f AW	210	(mov 0 1) ;; R0 <- R1
	211	(load-constant 1 3) ;; R1 <- 3
	212	(tail-call 2)
3185c907	213	(end-arity)
e78991aa AW	214	(end-program)))))
	215	(call-with-3 (lambda (x) (* x 2))))))
	216
	217	(with-test-prefix "cached-toplevel-ref"
	218	(assert-equal 5.0
	219	(let ((get-sqrt-trampoline
	220	(assemble-program
2a4daafd AW	221	'((begin-program get-sqrt-trampoline
2a4daafd AW	222	((name . get-sqrt-trampoline)))
7396d216	223	(begin-standard-arity () 2 #f)
af95414f	224	(current-module 1)
7396d216 AW	225	(cache-current-module! 1 sqrt-scope)
	226	(load-static-procedure 1 sqrt-trampoline)
	227	(return 1)
3185c907	228	(end-arity)
e78991aa AW	229	(end-program)
e78991aa AW	230
2a4daafd AW	231	(begin-program sqrt-trampoline
2a4daafd AW	232	((name . sqrt-trampoline)))
7396d216	233	(begin-standard-arity (x) 3 #f)
4cbe4d72	234	(definition x 1)
af95414f AW	235	(cached-toplevel-box 2 sqrt-scope sqrt #t)
	236	(box-ref 0 2)
	237	(tail-call 2)
3185c907	238	(end-arity)
e78991aa AW	239	(end-program)))))
	240	((get-sqrt-trampoline) 25.0))))
	241
	242	(define top-val 0)
	243
	244	(with-test-prefix "cached-toplevel-set!"
	245	(let ((prev top-val))
	246	(assert-equal (1+ prev)
	247	(let ((make-top-incrementor
	248	(assemble-program
2a4daafd AW	249	'((begin-program make-top-incrementor
2a4daafd AW	250	((name . make-top-incrementor)))
7396d216	251	(begin-standard-arity () 2 #f)
af95414f	252	(current-module 1)
7396d216 AW	253	(cache-current-module! 1 top-incrementor)
	254	(load-static-procedure 1 top-incrementor)
	255	(return 1)
3185c907	256	(end-arity)
e78991aa AW	257	(end-program)
e78991aa AW	258
2a4daafd AW	259	(begin-program top-incrementor
2a4daafd AW	260	((name . top-incrementor)))
af95414f AW	261	(begin-standard-arity () 3 #f)
	262	(cached-toplevel-box 1 top-incrementor top-val #t)
	263	(box-ref 2 1)
	264	(add1 2 2)
	265	(box-set! 1 2)
84cc4127 MW	266	(reset-frame 1)
84cc4127 MW	267	(return-values)
3185c907	268	(end-arity)
e78991aa AW	269	(end-program)))))
	270	((make-top-incrementor))
	271	top-val))))
	272
	273	(with-test-prefix "cached-module-ref"
	274	(assert-equal 5.0
	275	(let ((get-sqrt-trampoline
	276	(assemble-program
2a4daafd AW	277	'((begin-program get-sqrt-trampoline
2a4daafd AW	278	((name . get-sqrt-trampoline)))
7396d216 AW	279	(begin-standard-arity () 2 #f)
	280	(load-static-procedure 1 sqrt-trampoline)
	281	(return 1)
3185c907	282	(end-arity)
e78991aa AW	283	(end-program)
e78991aa AW	284
2a4daafd AW	285	(begin-program sqrt-trampoline
2a4daafd AW	286	((name . sqrt-trampoline)))
7396d216	287	(begin-standard-arity (x) 3 #f)
4cbe4d72	288	(definition x 1)
af95414f AW	289	(cached-module-box 2 (guile) sqrt #t #t)
	290	(box-ref 0 2)
	291	(tail-call 2)
3185c907	292	(end-arity)
e78991aa AW	293	(end-program)))))
	294	((get-sqrt-trampoline) 25.0))))
	295
	296	(with-test-prefix "cached-module-set!"
	297	(let ((prev top-val))
	298	(assert-equal (1+ prev)
	299	(let ((make-top-incrementor
	300	(assemble-program
2a4daafd AW	301	'((begin-program make-top-incrementor
2a4daafd AW	302	((name . make-top-incrementor)))
7396d216 AW	303	(begin-standard-arity () 2 #f)
	304	(load-static-procedure 1 top-incrementor)
	305	(return 1)
3185c907	306	(end-arity)
e78991aa AW	307	(end-program)
e78991aa AW	308
2a4daafd AW	309	(begin-program top-incrementor
2a4daafd AW	310	((name . top-incrementor)))
af95414f	311	(begin-standard-arity () 3 #f)
691697de	312	(cached-module-box 1 (tests bytecode) top-val #f #t)
af95414f AW	313	(box-ref 2 1)
	314	(add1 2 2)
	315	(box-set! 1 2)
	316	(return 2)
3185c907	317	(end-arity)
e78991aa AW	318	(end-program)))))
	319	((make-top-incrementor))
	320	top-val))))
cb86cbd7 AW	321
	322	(with-test-prefix "debug contexts"
	323	(let ((return-3 (assemble-program
2a4daafd	324	'((begin-program return-3 ((name . return-3)))
7396d216 AW	325	(begin-standard-arity () 2 #f)
	326	(load-constant 1 3)
	327	(return 1)
3185c907	328	(end-arity)
cb86cbd7 AW	329	(end-program)))))
cb86cbd7 AW	330	(pass-if "program name"
d1100525	331	(and=> (find-program-debug-info (program-code return-3))
cb86cbd7 AW	332	(lambda (pdi)
	333	(equal? (program-debug-info-name pdi)
	334	'return-3))))
	335
	336	(pass-if "program address"
d1100525	337	(and=> (find-program-debug-info (program-code return-3))
cb86cbd7 AW	338	(lambda (pdi)
cb86cbd7 AW	339	(equal? (program-debug-info-addr pdi)
d1100525	340	(program-code return-3)))))))
e65f80af AW	341
	342	(with-test-prefix "procedure name"
	343	(pass-if-equal 'foo
	344	(procedure-name
	345	(assemble-program
2a4daafd	346	'((begin-program foo ((name . foo)))
7396d216 AW	347	(begin-standard-arity () 2 #f)
	348	(load-constant 1 42)
	349	(return 1)
3185c907	350	(end-arity)
e65f80af	351	(end-program))))))
eb2bc00f	352
4cbe4d72	353	(with-test-prefix "simple procedure arity"
eb2bc00f AW	354	(pass-if-equal "#<procedure foo ()>"
	355	(object->string
	356	(assemble-program
	357	'((begin-program foo ((name . foo)))
7396d216 AW	358	(begin-standard-arity () 2 #f)
	359	(load-constant 1 42)
	360	(return 1)
eb2bc00f AW	361	(end-arity)
	362	(end-program)))))
	363	(pass-if-equal "#<procedure foo (x y)>"
	364	(object->string
	365	(assemble-program
	366	'((begin-program foo ((name . foo)))
7396d216	367	(begin-standard-arity (x y) 3 #f)
4cbe4d72 AW	368	(definition x 1)
4cbe4d72 AW	369	(definition y 2)
7396d216 AW	370	(load-constant 1 42)
7396d216 AW	371	(return 1)
eb2bc00f AW	372	(end-arity)
	373	(end-program)))))
	374
	375	(pass-if-equal "#<procedure foo (x #:optional y . z)>"
	376	(object->string
	377	(assemble-program
	378	'((begin-program foo ((name . foo)))
7396d216	379	(begin-opt-arity (x) (y) z 4 #f)
4cbe4d72 AW	380	(definition x 1)
	381	(definition y 2)
	382	(definition z 3)
7396d216 AW	383	(load-constant 1 42)
7396d216 AW	384	(return 1)
eb2bc00f AW	385	(end-arity)
eb2bc00f AW	386	(end-program))))))
bf8328ec AW	387
	388	(with-test-prefix "procedure docstrings"
	389	(pass-if-equal "qux qux"
	390	(procedure-documentation
	391	(assemble-program
	392	'((begin-program foo ((name . foo) (documentation . "qux qux")))
7396d216 AW	393	(begin-standard-arity () 2 #f)
	394	(load-constant 1 42)
	395	(return 1)
bf8328ec AW	396	(end-arity)
bf8328ec AW	397	(end-program))))))
c4c098e3 AW	398
	399	(with-test-prefix "procedure properties"
	400	;; No properties.
	401	(pass-if-equal '()
	402	(procedure-properties
	403	(assemble-program
	404	'((begin-program foo ())
7396d216 AW	405	(begin-standard-arity () 2 #f)
	406	(load-constant 1 42)
	407	(return 1)
c4c098e3 AW	408	(end-arity)
	409	(end-program)))))
	410
	411	;; Name and docstring (which actually don't go out to procprops).
	412	(pass-if-equal '((name . foo)
	413	(documentation . "qux qux"))
	414	(procedure-properties
	415	(assemble-program
	416	'((begin-program foo ((name . foo) (documentation . "qux qux")))
7396d216 AW	417	(begin-standard-arity () 2 #f)
	418	(load-constant 1 42)
	419	(return 1)
c4c098e3 AW	420	(end-arity)
	421	(end-program)))))
	422
	423	;; A property that actually needs serialization.
	424	(pass-if-equal '((name . foo)
	425	(documentation . "qux qux")
	426	(moo . "mooooooooooooo"))
	427	(procedure-properties
	428	(assemble-program
	429	'((begin-program foo ((name . foo)
	430	(documentation . "qux qux")
	431	(moo . "mooooooooooooo")))
7396d216 AW	432	(begin-standard-arity () 2 #f)
	433	(load-constant 1 42)
	434	(return 1)
c4c098e3 AW	435	(end-arity)
	436	(end-program)))))
	437
	438	;; Procedure-name still works in this case.
	439	(pass-if-equal 'foo
	440	(procedure-name
	441	(assemble-program
	442	'((begin-program foo ((name . foo)
	443	(documentation . "qux qux")
	444	(moo . "mooooooooooooo")))
7396d216 AW	445	(begin-standard-arity () 2 #f)
	446	(load-constant 1 42)
	447	(return 1)
c4c098e3 AW	448	(end-arity)
c4c098e3 AW	449	(end-program))))))