Mercurial > hg > xemacs-beta
annotate tests/automated/byte-compiler-tests.el @ 5423:d88ad9ccfa66
Migrate the rest of tests/ to GPLv3.
- drag 'n drop was also done by Oliver Graf, so samy copyright
- with gtk-test.glade, the only question was where to actually stick
the attribution; inserted XML comment
| author | Mike Sperber <sperber@deinprogramm.de> |
|---|---|
| date | Sun, 31 Oct 2010 01:35:37 +0100 |
| parents | 308d34e9f07d |
| children | ac37a5f7e5be |
| rev | line source |
|---|---|
| 428 | 1 ;; Copyright (C) 1998 Free Software Foundation, Inc. |
| 2 | |
| 3 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Created: 1998 | |
| 6 ;; Keywords: tests | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
13 ;; option) any later version. |
| 428 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
18 ;; for more details. |
| 428 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5136
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 22 |
| 23 ;;; Synched up with: Not in FSF. | |
| 24 | |
| 25 ;;; Commentary: | |
| 26 | |
| 27 ;;; Test byte-compiler functionality | |
| 28 ;;; See test-harness.el | |
| 29 | |
| 30 (condition-case err | |
| 31 (require 'test-harness) | |
| 32 (file-error | |
| 33 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 34 (push (file-name-directory load-file-name) load-path) | |
| 35 (require 'test-harness)))) | |
| 36 | |
| 37 (require 'bytecomp) | |
| 38 | |
| 39 ;; test constant symbol warnings | |
| 40 (defmacro check-byte-compiler-message (message-regexp &rest body) | |
| 41 `(Check-Message ,message-regexp (byte-compile '(lambda () ,@body)))) | |
| 42 | |
| 43 (check-byte-compiler-message "Attempt to set non-symbol" (setq 1 1)) | |
| 44 (check-byte-compiler-message "Attempt to set constant symbol" (setq t 1)) | |
| 45 (check-byte-compiler-message "Attempt to set constant symbol" (setq nil 1)) | |
| 46 (check-byte-compiler-message "^$" (defconst :foo 1)) | |
| 47 | |
| 48 (check-byte-compiler-message "Attempt to let-bind non-symbol" (let ((1 'x)) 1)) | |
| 49 (check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((t 'x)) (foo))) | |
| 50 (check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((nil 'x)) (foo))) | |
| 51 (check-byte-compiler-message "Attempt to let-bind constant symbol" (let ((:foo 'x)) (foo))) | |
| 52 | |
| 53 | |
| 54 (check-byte-compiler-message "bound but not referenced" (let ((foo 'x)) 1)) | |
| 55 (Assert (not (boundp 'free-variable))) | |
| 56 (Assert (boundp 'byte-compile-warnings)) | |
| 57 (check-byte-compiler-message "assignment to free variable" (setq free-variable 1)) | |
| 58 (check-byte-compiler-message "reference to free variable" (car free-variable)) | |
| 59 (check-byte-compiler-message "called with 2 args, but requires 1" (car 'x 'y)) | |
| 60 | |
| 61 (check-byte-compiler-message "^$" (setq :foo 1)) | |
| 62 (let ((fun '(lambda () (setq :foo 1)))) | |
| 63 (fset 'test-byte-compiler-fun fun)) | |
| 64 (Check-Error setting-constant (test-byte-compiler-fun)) | |
| 65 (byte-compile 'test-byte-compiler-fun) | |
| 66 (Check-Error setting-constant (test-byte-compiler-fun)) | |
| 67 | |
| 68 (eval-when-compile (defvar setq-test-foo nil) (defvar setq-test-bar nil)) | |
| 69 (progn | |
| 70 (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo)) | |
| 71 (check-byte-compiler-message "set called with 1 arg, but requires 2" (setq setq-test-foo 1 setq-test-bar)) | |
| 72 (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo)) | |
| 73 (check-byte-compiler-message "set-default called with 1 arg, but requires 2" (setq-default setq-test-foo 1 setq-test-bar)) | |
| 74 ) | |
| 75 | |
| 76 ;;----------------------------------------------------- | |
| 77 ;; let, let* | |
| 78 ;;----------------------------------------------------- | |
| 79 | |
| 80 ;; Test interpreted and compiled lisp separately here | |
| 81 (check-byte-compiler-message "malformed let binding" (let ((x 1 2)) 3)) | |
| 82 (check-byte-compiler-message "malformed let binding" (let* ((x 1 2)) 3)) | |
| 83 | |
| 84 (Check-Error-Message | |
| 85 error "`let' bindings can have only one value-form" | |
| 86 (eval '(let ((x 1 2)) 3))) | |
| 87 | |
| 88 (Check-Error-Message | |
| 89 error "`let' bindings can have only one value-form" | |
| 90 (eval '(let* ((x 1 2)) 3))) | |
| 91 | |
| 434 | 92 (defmacro before-and-after-compile-equal (&rest form) |
|
5136
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
93 `(Assert (equal (funcall (quote (lambda () ,@form))) |
|
0f66906b6e37
Undo Assert-equal, Assert=, etc.; make `Assert' handle this automatically
Ben Wing <ben@xemacs.org>
parents:
4855
diff
changeset
|
94 (funcall (byte-compile (quote (lambda () ,@form))))))) |
| 434 | 95 |
| 96 (defvar simplyamarker (point-min-marker)) | |
| 97 | |
| 98 ;; The byte optimizer must be careful with +/- with a single argument. | |
| 99 | |
| 100 (before-and-after-compile-equal (+)) | |
| 101 (before-and-after-compile-equal (+ 2 2)) | |
| 102 (before-and-after-compile-equal (+ 2 1)) | |
| 103 (before-and-after-compile-equal (+ 1 2)) | |
| 104 ;; (+ 1) is OK. but (+1) signals an error. | |
| 105 (before-and-after-compile-equal (+ 1)) | |
| 106 (before-and-after-compile-equal (+ 3)) | |
| 107 (before-and-after-compile-equal (+ simplyamarker 1)) | |
| 108 ;; The optimization (+ m) --> m is invalid when m is a marker. | |
| 109 ;; Currently the following test fails - controversial. | |
| 110 ;; (before-and-after-compile-equal (+ simplyamarker)) | |
| 111 ;; Same tests for minus. | |
| 112 (before-and-after-compile-equal (- 2 2)) | |
| 113 (before-and-after-compile-equal (- 2 1)) | |
| 114 (before-and-after-compile-equal (- 1 2)) | |
| 115 (before-and-after-compile-equal (- 1)) | |
| 116 (before-and-after-compile-equal (- 3)) | |
| 117 (before-and-after-compile-equal (- simplyamarker 1)) | |
| 118 (before-and-after-compile-equal (- simplyamarker)) | |
| 444 | 119 |
| 452 | 120 (before-and-after-compile-equal (let ((z 1)) (or (setq z 42)) z)) |
| 121 | |
| 444 | 122 ;; byte-after-unbind-ops |
| 123 | |
| 124 ;; byte-constant | |
| 125 ;; byte-dup | |
| 126 | |
| 127 ;; byte-symbolp | |
| 128 (before-and-after-compile-equal | |
| 129 (let ((x 's)) | |
| 130 (unwind-protect | |
| 131 (symbolp x) | |
| 132 (setq x 1)))) | |
| 133 | |
| 134 ;; byte-consp | |
| 135 (before-and-after-compile-equal | |
| 136 (let ((x '(a b))) | |
| 137 (unwind-protect | |
| 138 (consp x) | |
| 139 (setq x 1)))) | |
| 140 | |
| 141 ;; byte-stringp | |
| 142 (before-and-after-compile-equal | |
| 143 (let ((x "a")) | |
| 144 (unwind-protect | |
| 145 (stringp x) | |
| 146 (setq x 1)))) | |
| 147 | |
| 148 ;; byte-listp | |
| 149 (before-and-after-compile-equal | |
| 150 (let ((x '(a b c))) | |
| 151 (unwind-protect | |
| 152 (listp x) | |
| 153 (setq x 1)))) | |
| 154 | |
| 155 ;; byte-numberp | |
| 156 (before-and-after-compile-equal | |
| 157 (let ((x 1)) | |
| 158 (unwind-protect | |
| 159 (numberp x) | |
| 160 (setq x nil)))) | |
| 161 | |
| 162 ;; byte-integerp | |
| 163 (before-and-after-compile-equal | |
| 164 (let ((x 1)) | |
| 165 (unwind-protect | |
| 166 (integerp x) | |
| 167 (setq x nil)))) | |
| 168 | |
| 169 ;; byte-equal | |
| 170 (before-and-after-compile-equal | |
| 171 (let ((x 'a) | |
| 172 (y 'a)) | |
| 173 (unwind-protect | |
| 174 (eq x y) | |
| 175 (setq x 'c)))) | |
| 176 | |
| 177 ;; byte-not | |
| 178 (before-and-after-compile-equal | |
| 179 (let (x) | |
| 180 (unwind-protect | |
| 181 (not x) | |
| 182 (setq x t)))) | |
| 183 | |
| 184 ;; byte-cons | |
| 185 (before-and-after-compile-equal | |
| 186 (equal '(1 . 2) | |
| 187 (let ((x 1) | |
| 188 (y 2)) | |
| 189 (unwind-protect | |
| 190 (cons x y) | |
| 191 (setq x t))))) | |
| 192 | |
| 193 ;; byte-list1 | |
| 194 (before-and-after-compile-equal | |
| 195 (equal '(1) | |
| 196 (let ((x 1)) | |
| 197 (unwind-protect | |
| 198 (list x) | |
| 199 (setq x t))))) | |
| 200 | |
| 201 ;; byte-list2 | |
| 202 (before-and-after-compile-equal | |
| 203 (equal '(1 . 2) | |
| 204 (let ((x 1) | |
| 205 (y 2)) | |
| 206 (unwind-protect | |
| 207 (list x y) | |
| 208 (setq x t))))) | |
| 209 | |
| 210 ;; byte-interactive-p | |
| 211 | |
| 212 ;; byte-equal | |
| 213 (before-and-after-compile-equal | |
| 214 (let (x y) | |
| 215 (setq x '(1 . 2)) | |
| 216 (setq y '(1 . 2)) | |
| 217 (unwind-protect | |
| 218 (equal x y) | |
| 219 (setq y '(1 . 3))))) |