test-suite/tests/rtl-compilation.test

   1 ;;;; rtl-compilation.test --- test suite for compiling via bytecode   -*- scheme -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2013 Free Software Foundation, Inc.
   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
  19 (define-module (test-suite bytecode-compilation)
  20   #:use-module (test-suite lib)
  21   #:use-module (system base compile)
  22   #:use-module (system vm loader))
  23
  24 (define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module)))
  25   (load-thunk-from-memory
  26    (compile exp #:env env #:to 'bytecode
  27             #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
  28
  29 (define* (run-bytecode exp #:key (env (make-fresh-user-module)))
  30   (let ((thunk (compile-via-bytecode exp #:env env)))
  31     (save-module-excursion
  32      (lambda ()
  33        (set-current-module env)
  34        (thunk)))))
  35
  36 (with-test-prefix "tail context"
  37   (pass-if-equal 1
  38       (run-bytecode '(let ((x 1)) x)))
  39
  40   (pass-if-equal 1
  41       (run-bytecode 1))
  42
  43   (pass-if-equal (if #f #f)
  44       (run-bytecode '(if #f #f)))
  45
  46   (pass-if-equal "top-level define"
  47       (list (if #f #f) 1)
  48     (let ((mod (make-fresh-user-module)))
  49       (let ((result (run-bytecode '(define v 1) #:env mod)))
  50         (list result (module-ref mod 'v)))))
  51
  52   (pass-if-equal "top-level set!"
  53       (list (if #f #f) 1)
  54     (let ((mod (make-fresh-user-module)))
  55       (module-define! mod 'v #f)
  56       (let ((result (run-bytecode '(set! v 1) #:env mod)))
  57         (list result (module-ref mod 'v)))))
  58
  59   (pass-if-equal "top-level apply [single value]"
  60       8
  61     (let ((mod (make-fresh-user-module)))
  62       (module-define! mod 'args '(2 3))
  63       (run-bytecode '(apply expt args) #:env mod)))
  64
  65   (pass-if-equal "top-level apply [zero values]"
  66       '()
  67     (let ((mod (make-fresh-user-module)))
  68       (module-define! mod 'proc (lambda () (values)))
  69       (module-define! mod 'args '())
  70       (call-with-values
  71           (lambda () (run-bytecode '(apply proc args) #:env mod))
  72         list)))
  73
  74   (pass-if-equal "top-level apply [two values]"
  75       '(1 2)
  76     (let ((mod (make-fresh-user-module)))
  77       (module-define! mod 'proc (lambda (n d) (floor/ n d)))
  78       (module-define! mod 'args '(5 3))
  79       (call-with-values
  80           (lambda () (run-bytecode '(apply proc args) #:env mod))
  81         list)))
  82
  83   (pass-if-equal "call-with-values"
  84       '(1 2 3)
  85     ((run-bytecode '(lambda (n d)
  86                  (call-with-values (lambda () (floor/ n d))
  87                    (lambda (q r) (list q r (+ q r))))))
  88      5 3))
  89
  90   (pass-if-equal cons
  91       (run-bytecode 'cons))
  92
  93   (pass-if-equal 1
  94       ((run-bytecode '(lambda () 1))))
  95
  96   (pass-if-equal 1
  97       ((run-bytecode '(lambda (x) 1)) 2))
  98
  99   (pass-if-equal 1
 100       ((run-bytecode '(lambda (x) x)) 1))
 101
 102   (pass-if-equal 6
 103       ((((run-bytecode '(lambda (x)
 104                      (lambda (y)
 105                        (lambda (z)
 106                          (+ x y z))))) 1) 2) 3))
 107
 108   (pass-if-equal 1
 109       (run-bytecode '(identity 1)))
 110
 111   (pass-if-equal '(1 . 2)
 112       (run-bytecode '(cons 1 2)))
 113
 114   (pass-if-equal '(1 2)
 115       (call-with-values (lambda () (run-bytecode '(values 1 2))) list))
 116
 117   (pass-if-equal 28
 118       ((run-bytecode '(lambda (x y z rest) (apply + x y z rest)))
 119        2 3 5 '(7 11)))
 120
 121   ;; prompts
 122   )
 123
 124 (with-test-prefix "value context"
 125   1
 126   )
 127
 128 (with-test-prefix "drop context"
 129   1
 130   )
 131
 132 (with-test-prefix "test context"
 133   1
 134   )
 135
 136 (with-test-prefix "values context"
 137   (pass-if-equal '(3 . 1)
 138       (run-bytecode
 139        '(let ((rat (lambda (n d)
 140                      (call-with-values
 141                          (lambda () (floor/ n d))
 142                        (lambda (q r)
 143                          (cons q r))))))
 144           (rat 10 3)))))
 145
 146 (with-test-prefix "contification"
 147   (pass-if ((run-bytecode '(lambda (x)
 148                         (define (even? x)
 149                           (if (null? x) #t (odd? (cdr x))))
 150                         (define (odd? x)
 151                           (if (null? x) #f (even? (cdr x))))
 152                         (even? x)))
 153             '(1 2 3 4)))
 154
 155   (pass-if (not ((run-bytecode '(lambda (x)
 156                              (define (even? x)
 157                                (if (null? x) #t (odd? (cdr x))))
 158                              (define (odd? x)
 159                                (if (null? x) #f (even? (cdr x))))
 160                              (even? x)))
 161                  '(1 2 3))))
 162
 163   (pass-if-equal '(#t)
 164       ((run-bytecode '(lambda (x)
 165                    (define (even? x)
 166                      (if (null? x) #t (odd? (cdr x))))
 167                    (define (odd? x)
 168                      (if (null? x) #f (even? (cdr x))))
 169                    (list (even? x))))
 170        '(1 2 3 4)))
 171
 172   ;; An irreducible loop between even? and odd?.
 173   (pass-if-equal '#t
 174       ((run-bytecode '(lambda (x do-even?)
 175                    (define (even? x)
 176                      (if (null? x) #t (odd? (cdr x))))
 177                    (define (odd? x)
 178                      (if (null? x) #f (even? (cdr x))))
 179                    (if do-even? (even? x) (odd? x))))
 180        '(1 2 3 4)
 181        #t)))
 182
 183 (with-test-prefix "case-lambda"
 184   (pass-if-equal "simple"
 185       '(0 3 9 28)
 186     (let ((proc (run-bytecode '(case-lambda
 187                             (() 0)
 188                             ((x) x)
 189                             ((x y) (+ x y))
 190                             ((x y z . rest) (apply + x y z rest))))))
 191       (map (lambda (args) (apply proc args))
 192            '(() (3) (2 7) (2 3 5 7 11)))))
 193
 194   (pass-if-exception "no match"
 195       exception:wrong-num-args
 196     ((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y))))
 197      1 2 3))
 198
 199   (pass-if-exception "zero clauses called with no args"
 200       exception:wrong-num-args
 201     ((run-bytecode '(case-lambda))))
 202
 203   (pass-if-exception "zero clauses called with args"
 204       exception:wrong-num-args
 205     ((run-bytecode '(case-lambda)) 1)))
 206
 207 (with-test-prefix "mixed contexts"
 208   (pass-if-equal "sequences" '(3 4 5)
 209     (let* ((pair (cons 1 2))
 210            (result ((run-bytecode '(lambda (pair)
 211                                 (set-car! pair 3)
 212                                 (set-cdr! pair 4)
 213                                 5))
 214                     pair)))
 215       (list (car pair)
 216             (cdr pair)
 217             result)))
 218
 219   (pass-if-equal "mutable lexicals" 2
 220     (run-bytecode '(let ((n 1)) (set! n 2) n))))