1 files changed, 512 insertions, 0 deletions
diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el
new file mode 100644
index 00000000000..19acec2716e
--- /dev/null
+++ b/test/src/comp-test-funcs.el
@@ -0,0 +1,512 @@
+;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <akrl@sdf.org>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(defvar comp-tests-var1 3)
+
+(defun comp-tests-varref-f ()
+  comp-tests-var1)
+
+(defun comp-tests-list-f ()
+  (list 1 2 3))
+(defun comp-tests-list2-f (a b c)
+  (list a b c))
+(defun comp-tests-car-f (x)
+  ;; Bcar
+  (car x))
+(defun comp-tests-cdr-f (x)
+  ;; Bcdr
+  (cdr x))
+(defun comp-tests-car-safe-f (x)
+  ;; Bcar_safe
+  (car-safe x))
+(defun comp-tests-cdr-safe-f (x)
+  ;; Bcdr_safe
+  (cdr-safe x))
+
+(defun comp-tests-cons-car-f ()
+  (car (cons 1 2)))
+(defun comp-tests-cons-cdr-f (x)
+  (cdr (cons 'foo x)))
+
+(defun comp-tests-hint-fixnum-f (n)
+  (1+ (comp-hint-fixnum n)))
+
+(defun comp-tests-hint-cons-f (c)
+  (car (comp-hint-cons c)))
+
+(defun comp-tests-varset0-f ()
+  (setq comp-tests-var1 55))
+(defun comp-tests-varset1-f ()
+  (setq comp-tests-var1 66)
+  4)
+
+(defun comp-tests-length-f ()
+  (length '(1 2 3)))
+
+(defun comp-tests-aref-aset-f ()
+  (let ((vec (make-vector 3 0)))
+    (aset vec 2 100)
+    (aref vec 2)))
+
+(defvar comp-tests-var2 3)
+(defun comp-tests-symbol-value-f ()
+  (symbol-value 'comp-tests-var2))
+
+(defun comp-tests-concat-f (x)
+  (concat "a" "b" "c" "d"
+          (concat "a" "b" "c" (concat "a" "b" (concat "foo" x)))))
+
+(defun comp-tests-ffuncall-callee-f (x y z)
+  (list x y z))
+
+(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d)
+  (list a b c d))
+
+(defun comp-tests-ffuncall-callee-rest-f (a b &rest c)
+  (list a b c))
+
+(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)
+  ;; More then 8 args.
+  (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10))
+
+(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 &rest p10)
+  ;; More then 8 args.
+  (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10))
+
+(defun comp-tests-ffuncall-native-f ()
+  "Call a primitive with no dedicate op."
+  (make-vector 1 nil))
+
+(defun comp-tests-ffuncall-native-rest-f ()
+  "Call a primitive with no dedicate op with &rest."
+  (vector 1 2 3))
+
+(defun comp-tests-ffuncall-apply-many-f (x)
+  (apply #'list x))
+
+(defun comp-tests-ffuncall-lambda-f (x)
+  (let ((fun (lambda (x)
+               (1+ x))))
+    (funcall fun x)))
+
+(defun comp-tests-jump-table-1-f (x)
+  (pcase x
+    ('x 'a)
+    ('y 'b)
+    (_ 'c)))
+
+(defun comp-tests-jump-table-2-f (x)
+  (pcase x
+    ("aaa" 'a)
+    ("bbb" 'b)))
+
+(defun comp-tests-conditionals-1-f (x)
+  ;; Generate goto-if-nil
+  (if x 1 2))
+(defun comp-tests-conditionals-2-f (x)
+  ;; Generate goto-if-nil-else-pop
+  (when x
+    1340))
+
+(defun comp-tests-fixnum-1-minus-f (x)
+  ;; Bsub1
+  (1- x))
+(defun comp-tests-fixnum-1-plus-f (x)
+  ;; Badd1
+  (1+ x))
+(defun comp-tests-fixnum-minus-f (x)
+  ;; Bnegate
+  (- x))
+
+(defun comp-tests-eqlsign-f (x y)
+  ;; Beqlsign
+  (= x y))
+(defun comp-tests-gtr-f (x y)
+  ;; Bgtr
+  (> x y))
+(defun comp-tests-lss-f (x y)
+  ;; Blss
+  (< x y))
+(defun comp-tests-les-f (x y)
+  ;; Bleq
+  (<= x y))
+(defun comp-tests-geq-f (x y)
+  ;; Bgeq
+  (>= x y))
+
+(defun comp-tests-setcar-f (x y)
+  (setcar x y)
+  x)
+(defun comp-tests-setcdr-f (x y)
+  (setcdr x y)
+  x)
+
+(defun comp-bubble-sort-f (list)
+  (let ((i (length list)))
+    (while (> i 1)
+      (let ((b list))
+        (while (cdr b)
+          (when (< (cadr b) (car b))
+            (setcar b (prog1 (cadr b)
+                        (setcdr b (cons (car b) (cddr b))))))
+          (setq b (cdr b))))
+      (setq i (1- i)))
+    list))
+
+(defun comp-tests-consp-f (x)
+  ;; Bconsp
+  (consp x))
+(defun comp-tests-setcar2-f (x)
+  ;; Bsetcar
+  (setcar x 3))
+
+(defun comp-tests-integerp-f (x)
+  ;; Bintegerp
+  (integerp x))
+(defun comp-tests-numberp-f (x)
+  ;; Bnumberp
+  (numberp x))
+
+(defun comp-tests-discardn-f (x)
+  ;; BdiscardN
+  (1+ (let ((a 1)
+            (_b)
+            (_c))
+        a)))
+(defun comp-tests-insertn-f (a b c d)
+  ;; Binsert
+  (insert a b c d))
+
+(defun comp-tests-err-arith-f ()
+  (/ 1 0))
+(defun comp-tests-err-foo-f ()
+  (error "foo"))
+
+(defun comp-tests-condition-case-0-f ()
+  ;; Bpushhandler Bpophandler
+  (condition-case
+      err
+      (comp-tests-err-arith-f)
+    (arith-error (concat "arith-error "
+                         (error-message-string err)
+                         " catched"))
+    (error (concat "error "
+                   (error-message-string err)
+                   " catched"))))
+(defun comp-tests-condition-case-1-f ()
+  ;; Bpushhandler Bpophandler
+  (condition-case
+      err
+      (comp-tests-err-foo-f)
+    (arith-error (concat "arith-error "
+                         (error-message-string err)
+                         " catched"))
+    (error (concat "error "
+                   (error-message-string err)
+                   " catched"))))
+(defun comp-tests-catch-f (f)
+  (catch 'foo
+    (funcall f)))
+(defun comp-tests-throw-f (x)
+  (throw 'foo x))
+
+(defun comp-tests-buff0-f ()
+  (with-temp-buffer
+    (insert "foo")
+    (buffer-string)))
+
+(defun comp-tests-lambda-return-f ()
+  (lambda (x) (1+ x)))
+
+(defun comp-tests-fib-f (n)
+  (cond ((= n 0) 0)
+	((= n 1) 1)
+	(t (+ (comp-tests-fib-f (- n 1))
+	      (comp-tests-fib-f (- n 2))))))
+
+(defmacro comp-tests-macro-m (x)
+  x)
+
+(defun comp-tests-string-trim-f (url)
+  (string-trim url))
+
+(defun comp-tests-trampoline-removal-f ()
+  (make-hash-table))
+
+(defun comp-tests-signal-f ()
+  (signal 'foo t))
+
+(defun comp-tests-func-call-removal-f ()
+  (let ((a 10)
+	(b 3))
+    (% a b)))
+
+(defun comp-tests-doc-f ()
+  "A nice docstring"
+  t)
+
+(defun comp-test-interactive-form0-f (dir)
+  (interactive "D")
+  dir)
+
+(defun comp-test-interactive-form1-f (x y)
+  (interactive '(1 2))
+  (+ x y))
+
+(defun comp-test-interactive-form2-f ()
+  (interactive))
+
+(defun comp-test-40187-2-f ()
+  'foo)
+
+(defalias 'comp-test-40187-1-f (symbol-function 'comp-test-40187-2-f))
+
+(defun comp-test-40187-2-f ()
+  'bar)
+
+(defun comp-test-speed--1-f ()
+  (declare (speed -1))
+  3)
+
+(defun comp-test-42360-f (str end-column
+		              &optional start-column padding ellipsis
+                              ellipsis-text-property)
+  ;; From `truncate-string-to-width'.  A large enough function to
+  ;; potentially use all registers and that is modifying local
+  ;; variables inside condition-case.
+  (let ((str-len (length str))
+	(str-width 14)
+	(ellipsis-width 3)
+	(idx 0)
+	(column 0)
+	(head-padding "") (tail-padding "")
+	ch last-column last-idx from-idx)
+    (condition-case nil
+	(while (< column start-column)
+	  (setq ch (aref str idx)
+		column (+ column (char-width ch))
+		idx (1+ idx)))
+      (args-out-of-range (setq idx str-len)))
+    (if (< column start-column)
+	(if padding (make-string end-column padding) "")
+      (when (and padding (> column start-column))
+	(setq head-padding (make-string (- column start-column) padding)))
+      (setq from-idx idx)
+      (when (>= end-column column)
+	(condition-case nil
+	    (while (< column end-column)
+	      (setq last-column column
+		    last-idx idx
+		    ch (aref str idx)
+		    column (+ column (char-width ch))
+		    idx (1+ idx)))
+	  (args-out-of-range (setq idx str-len)))
+	(when (> column end-column)
+	  (setq column last-column
+		idx last-idx))
+	(when (and padding (< column end-column))
+	  (setq tail-padding (make-string (- end-column column) padding))))
+      (if (and ellipsis-text-property
+               (not (equal ellipsis ""))
+               idx)
+	  (concat head-padding
+                  (substring str from-idx idx)
+	          (propertize (substring str idx) 'display (or ellipsis "")))
+        (concat head-padding (substring str from-idx idx)
+	        tail-padding ellipsis)))))
+
+(defun comp-test-primitive-advice-f (x y)
+  (declare (speed 2))
+  (+ x y))
+
+
+;;;;;;;;;;;;;;;;;;;;
+;; Tromey's tests ;;
+;;;;;;;;;;;;;;;;;;;;
+
+;; Test Bconsp.
+(defun comp-test-consp (x) (consp x))
+
+;; Test Blistp.
+(defun comp-test-listp (x) (listp x))
+
+;; Test Bstringp.
+(defun comp-test-stringp (x) (stringp x))
+
+;; Test Bsymbolp.
+(defun comp-test-symbolp (x) (symbolp x))
+
+;; Test Bintegerp.
+(defun comp-test-integerp (x) (integerp x))
+
+;; Test Bnumberp.
+(defun comp-test-numberp (x) (numberp x))
+
+;; Test Badd1.
+(defun comp-test-add1 (x) (1+ x))
+
+;; Test Bsub1.
+(defun comp-test-sub1 (x) (1- x))
+
+;; Test Bneg.
+(defun comp-test-negate (x) (- x))
+
+;; Test Bnot.
+(defun comp-test-not (x) (not x))
+
+;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max.
+(defun comp-test-bobp () (bobp))
+(defun comp-test-eobp () (eobp))
+(defun comp-test-point () (point))
+(defun comp-test-point-min () (point-min))
+(defun comp-test-point-max () (point-max))
+
+;; Test Bcar and Bcdr.
+(defun comp-test-car (x) (car x))
+(defun comp-test-cdr (x) (cdr x))
+
+;; Test Bcar_safe and Bcdr_safe.
+(defun comp-test-car-safe (x) (car-safe x))
+(defun comp-test-cdr-safe (x) (cdr-safe x))
+
+;; Test Beq.
+(defun comp-test-eq (x y) (eq x y))
+
+;; Test Bgotoifnil.
+(defun comp-test-if (x y) (if x x y))
+
+;; Test Bgotoifnilelsepop.
+(defun comp-test-and (x y) (and x y))
+
+;; Test Bgotoifnonnilelsepop.
+(defun comp-test-or (x y) (or x y))
+
+;; Test Bsave_excursion.
+(defun comp-test-save-excursion ()
+  (save-excursion
+    (insert "XYZ")))
+
+;; Test Bcurrent_buffer.
+(defun comp-test-current-buffer () (current-buffer))
+
+;; Test Bgtr.
+(defun comp-test-> (a b)
+  (> a b))
+
+;; Test Bpushcatch.
+(defun comp-test-catch (&rest l)
+  (catch 'done
+    (dolist (v l)
+      (when (> v 23)
+        (throw 'done v)))))
+
+;; Test Bmemq.
+(defun comp-test-memq (val list)
+  (memq val list))
+
+;; Test BlistN.
+(defun comp-test-listN (x)
+  (list x x x x x x x x x x x x x x x x))
+
+;; Test BconcatN.
+(defun comp-test-concatN (x)
+  (concat x x x x x x))
+
+;; Test optional and rest arguments.
+(defun comp-test-opt-rest (a &optional b &rest c)
+  (list a b c))
+
+;; Test for too many arguments.
+(defun comp-test-opt (a &optional b)
+  (cons a b))
+
+;; Test for unwind-protect.
+(defvar comp-test-up-val nil)
+(defun comp-test-unwind-protect (fun)
+  (setq comp-test-up-val nil)
+  (unwind-protect
+      (progn
+        (setq comp-test-up-val 23)
+        (funcall fun)
+        (setq comp-test-up-val 24))
+    (setq comp-test-up-val 999)))
+
+;; Non tested functions that proved just to be difficult to compile.
+
+(defun comp-test-callee (_ __) t)
+(defun comp-test-silly-frame1 (x)
+  ;; Check robustness against dead code.
+  (cl-case x
+    (0 (comp-test-callee
+        (pcase comp-tests-var1
+          (1 1)
+          (2 2))
+        3))))
+
+(defun comp-test-silly-frame2 (token)
+  ;; Check robustness against dead code.
+  (while c
+    (cl-case c
+      (?< 1)
+      (?> 2))))
+
+(defun comp-test-big-interactive (filename &optional force arg load)
+  ;; Check non trivial interactive form using `byte-recompile-file'.
+  (interactive
+   (let ((file buffer-file-name)
+	 (file-name nil)
+	 (file-dir nil))
+     (and file
+	  (derived-mode-p 'emacs-lisp-mode)
+	  (setq file-name (file-name-nondirectory file)
+		file-dir (file-name-directory file)))
+     (list (read-file-name (if current-prefix-arg
+			       "Byte compile file: "
+			     "Byte recompile file: ")
+			   file-dir file-name nil)
+	   current-prefix-arg)))
+  (let ((dest (byte-compile-dest-file filename))
+        ;; Expand now so we get the current buffer's defaults
+        (filename (expand-file-name filename)))
+    (if (if (file-exists-p dest)
+            ;; File was already compiled
+            ;; Compile if forced to, or filename newer
+            (or force
+                (file-newer-than-file-p filename dest))
+          (and arg
+               (or (eq 0 arg)
+                   (y-or-n-p (concat "Compile "
+                                     filename "? ")))))
+        (progn
+          (if (and noninteractive (not byte-compile-verbose))
+              (message "Compiling %s..." filename))
+          (byte-compile-file filename load))
+      (when load
+	(load (if (file-exists-p dest) dest filename)))
+      'no-byte-compile)))
+
+(provide 'comp-test-funcs)
+
+;;; comp-test-funcs.el ends here