test-suite/tests/elisp-compiler.test

   1 ;;;; elisp-compiler.test --- Test the compiler for Elisp.
   2 ;;;;
   3 ;;;; Copyright (C) 2009 Free Software Foundation, Inc.
   4 ;;;; Daniel Kraft
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-elisp-compiler)
  21   :use-module (test-suite lib)
  22   :use-module (system base compile)
  23   :use-module (language elisp runtime))
  24
  25
  26 ; Macros to handle the compilation conveniently.
  27
  28 (define-syntax compile-test
  29   (syntax-rules (pass-if pass-if-exception)
  30     ((_ (pass-if test-name exp))
  31      (pass-if test-name (compile 'exp #:from 'elisp #:to 'value)))
  32     ((_ (pass-if-equal test-name result exp))
  33      (pass-if test-name (equal? result
  34                                 (compile 'exp #:from 'elisp #:to 'value))))
  35     ((_ (pass-if-exception test-name exc exp))
  36      (pass-if-exception test-name exc
  37                         (compile 'exp #:from 'elisp #:to 'value)))))
  38
  39 (define-syntax with-test-prefix/compile
  40   (syntax-rules ()
  41     ((_ section-name exp ...)
  42      (with-test-prefix section-name (compile-test exp) ...))))
  43
  44
  45 ; Test control structures.
  46 ; ========================
  47
  48 (with-test-prefix/compile "Sequencing"
  49
  50   (pass-if-equal "progn" 1
  51     (progn (setq a 0)
  52            (setq a (1+ a))
  53            a)))
  54
  55 (with-test-prefix/compile "Conditionals"
  56
  57   (pass-if-equal "succeeding if" 1
  58     (if t 1 2))
  59   (pass-if-equal "failing if" 3
  60     (if nil
  61       1
  62       (setq a 2)
  63       (setq a (1+ a))
  64       a))
  65
  66   (pass-if-equal "empty cond" nil-value
  67     (cond))
  68   (pass-if-equal "all failing cond" nil-value
  69     (cond (nil) (nil)))
  70   (pass-if-equal "only condition" 5
  71     (cond (nil) (5)))
  72   (pass-if-equal "succeeding cond value" 42
  73     (cond (nil) (t 42) (t 0)))
  74   (pass-if-equal "succeeding cond side-effect" 42
  75     (progn (setq a 0)
  76            (cond (nil) (t (setq a 42) 1) (t (setq a 0)))
  77            a)))
  78
  79 (with-test-prefix/compile "Combining Conditions"
  80
  81   (pass-if-equal "empty and" t-value (and))
  82   (pass-if-equal "failing and" nil-value (and 1 2 nil 3))
  83   (pass-if-equal "succeeding and" 3 (and 1 2 3))
  84
  85   (pass-if-equal "empty or" nil-value (or))
  86   (pass-if-equal "failing or" nil-value (or nil nil nil))
  87   (pass-if-equal "succeeding or" 1 (or nil 1 nil 2 nil 3))
  88
  89   (pass-if-equal "not true" nil-value (not 1))
  90   (pass-if-equal "not false" t-value (not nil)))
  91
  92 (with-test-prefix/compile "Iteration"
  93
  94   (pass-if-equal "failing while" 0
  95     (progn (setq a 0)
  96            (while nil (setq a 1))
  97            a))
  98   (pass-if-equal "running while" 120
  99     (progn (setq prod 1
 100                  i 1)
 101            (while (<= i 5)
 102              (setq prod (* i prod))
 103              (setq i (1+ i)))
 104            prod)))
 105
 106
 107 ; Test handling of variables.
 108 ; ===========================
 109
 110 (with-test-prefix/compile "Variable Setting/Referencing"
 111
 112   ; TODO: Check for variable-void error
 113
 114   (pass-if-equal "setq and reference" 6
 115     (progn (setq a 1 b 2 c 3)
 116            (+ a b c)))
 117
 118   (pass-if-equal "setq value" 2
 119     (progn (setq a 1 b 2))))
 120
 121 (with-test-prefix/compile "Let and Let*"
 122
 123   (pass-if-equal "let without value" nil-value
 124     (let (a (b 5)) a))
 125   (pass-if-equal "basic let" 0
 126     (progn (setq a 0)
 127            (let ((a 1)
 128                  (b a))
 129              b)))
 130   (pass-if-equal "let*" 1
 131     (progn (setq a 0)
 132            (let* ((a 1)
 133                   (b a))
 134              b)))
 135
 136   (pass-if "local scope"
 137     (progn (setq a 0)
 138            (setq b (let (a)
 139                      (setq a 1)
 140                      a))
 141            (and (= a 0)
 142                 (= b 1)))))
 143
 144 (with-test-prefix/compile "defconst and defvar"
 145
 146   (pass-if-equal "defconst without docstring" 3.141
 147     (progn (setq pi 3)
 148            (defconst pi 3.141)
 149            pi))
 150   (pass-if-equal "defconst value" 'pi
 151     (defconst pi 3.141 "Pi"))
 152
 153   (pass-if-equal "defvar without value" 42
 154     (progn (setq a 42)
 155            (defvar a)
 156            a))
 157   (pass-if-equal "defvar on already defined variable" 42
 158     (progn (setq a 42)
 159            (defvar a 1 "Some docstring is also ok")
 160            a))
 161   ; FIXME: makunbound a!
 162   (pass-if-equal "defvar on undefined variable" 1
 163     (progn (defvar a 1)
 164            a))
 165   (pass-if-equal "defvar value" 'a
 166     (defvar a)))
 167
 168
 169 ; Functions and lambda expressions.
 170 ; =================================
 171
 172 (with-test-prefix/compile "Lambda Expressions"
 173
 174   (pass-if-equal "required arguments" 3
 175     ((lambda (a b c) c) 1 2 3))
 176
 177   (pass-if-equal "optional argument" 3
 178     ((function (lambda (a &optional b c) c)) 1 2 3))
 179   (pass-if-equal "optional missing" nil-value
 180     ((lambda (&optional a) a)))
 181
 182   (pass-if-equal "rest argument" '(3 4 5)
 183     ((lambda (a b &rest c) c) 1 2 3 4 5))
 184   (pass-if-equal "rest missing" nil-value
 185     ((lambda (a b &rest c) c) 1 2)))
 186
 187 (with-test-prefix/compile "Function Definitions"
 188
 189   (pass-if-equal "defun" 3
 190     (progn (defun test (a b) (+ a b))
 191            (test 1 2)))
 192   (pass-if-equal "defun value" 'test
 193     (defun test (a b) (+ a b))))
 194
 195 (with-test-prefix/compile "Calling Functions"
 196
 197   (pass-if-equal "recursion" 120
 198     (progn (defun factorial (n prod)
 199              (if (zerop n)
 200                prod
 201                (factorial (1- n) (* prod n))))
 202            (factorial 5 1)))
 203
 204   (pass-if "dynamic scoping"
 205     (progn (setq a 0)
 206            (defun foo ()
 207              (setq a (1+ a))
 208              a)
 209            (defun bar (a)
 210              (foo))
 211            (and (= 43 (bar 42))
 212                 (zerop a)))))
 213
 214
 215 ; Quoting and Backquotation.
 216 ; ==========================
 217
 218 (with-test-prefix/compile "Quotation"
 219
 220   (pass-if "quote"
 221     (and (equal '42 42) (equal '"abc" "abc")
 222          (equal '(1 2 (3 (4) x)) '(1 2 (3 (4) x)))
 223          (not (equal '(1 2 (3 4 (x))) '(1 2 3 4 x)))
 224          (equal '(1 2 . 3) '(1 2 . 3))))
 225
 226   (pass-if "simple backquote"
 227     (and (equal (\` 42) 42)
 228          (equal (\` (1 (a))) '(1 (a)))
 229          (equal (\` (1 . 2)) '(1 . 2))))
 230   (pass-if "unquote"
 231     (progn (setq a 42 l '(18 12))
 232            (and (equal (\` (\, a)) 42)
 233                 (equal (\` (1 a ((\, l)) . (\, a))) '(1 a ((18 12)) . 42)))))
 234   (pass-if "unquote splicing"
 235     (progn (setq l '(18 12) empty '())
 236            (and (equal (\` (\,@ l)) '(18 12))
 237                 (equal (\` (l 2 (3 (\,@ l)) ((\,@ l)) (\,@ l)))
 238                        '(l 2 (3 18 12) (18 12) 18 12))
 239                 (equal (\` (1 2 (\,@ empty) 3)) '(1 2 3))))))
 240
 241
 242
 243 ; Macros.
 244 ; =======
 245
 246 (with-test-prefix/compile "Macros"
 247
 248   (pass-if-equal "defmacro value" 'magic-number
 249     (defmacro magic-number () 42))
 250
 251   (pass-if-equal "macro expansion" 1
 252     (progn (defmacro take-first (a b) a)
 253            (take-first 1 (/ 1 0)))))
 254
 255
 256 ; Test the built-ins.
 257 ; ===================
 258
 259 (with-test-prefix/compile "Equivalence Predicates"
 260
 261   (pass-if "equal"
 262     (and (equal 2 2) (not (equal 1 2))
 263          (equal "abc" "abc") (not (equal "abc" "ABC"))
 264          (equal 'abc 'abc) (not (equal 'abc 'def))
 265          (equal '(1 2 (3 4) 5) '(1 2 (3 4) 5))
 266          (not (equal '(1 2 3 4 5) '(1 2 (3 4) 5)))))
 267
 268   (pass-if "eq"
 269     (progn (setq some-list '(1 2))
 270            (setq some-string "abc")
 271            (and (eq 2 2) (not (eq 1 2))
 272                 (eq 'abc 'abc) (not (eq 'abc 'def))
 273                 (eq some-string some-string) (not (eq some-string "abc"))
 274                 (eq some-list some-list) (not (eq some-list '(1 2)))))))
 275
 276 (with-test-prefix/compile "Number Built-Ins"
 277
 278   (pass-if "floatp"
 279     (and (floatp 1.0) (not (floatp 1)) (not (floatp 'a))))
 280   (pass-if "integerp"
 281     (and (integerp 42) (integerp -2) (not (integerp 1.0))))
 282   (pass-if "numberp"
 283     (and (numberp 1.0) (numberp -2) (not (numberp 'a))))
 284   (pass-if "wholenump"
 285     (and (wholenump 0) (not (wholenump -2)) (not (wholenump 1.0))))
 286   (pass-if "zerop"
 287     (and (zerop 0) (zerop 0.0) (not (zerop 1))))
 288
 289   (pass-if "comparisons"
 290     (and (= 1 1.0) (/= 0 1)
 291          (< 1 2) (> 2 1) (>= 1 1) (<= 1 1)
 292          (not (< 1 1)) (not (<= 2 1))))
 293
 294   (pass-if "max and min"
 295     (and (= (max -5 2 4.0 1) 4.0) (= (min -5 2 4.0 1) -5)
 296          (= (max 1) 1) (= (min 1) 1)))
 297   (pass-if "abs"
 298     (and (= (abs 1.0) 1.0) (= (abs -5) 5)))
 299
 300   (pass-if "float"
 301     (and (= (float 1) 1) (= (float 5.5) 5.5)
 302          (floatp (float 1))))
 303
 304   (pass-if-equal "basic arithmetic operators" -8.5
 305     (+ (1+ 0) (1- 0) (- 5.5) (* 2 -2) (- 2 1)))
 306   (pass-if "modulo"
 307     (= (% 5 3) 2))
 308
 309   (pass-if "floating point rounding"
 310     (and (= (ffloor 1.7) 1.0) (= (ffloor -1.2) -2.0) (= (ffloor 1.0) 1.0)
 311          (= (fceiling 1.2) 2.0) (= (fceiling -1.7) -1.0) (= (fceiling 1.0) 1.0)
 312          (= (ftruncate 1.6) 1.0) (= (ftruncate -1.7) -1.0)
 313          (= (fround 1.2) 1.0) (= (fround 1.7) 2.0) (= (fround -1.7) -2.0))))