From f7dc021916ba99c4dfda275e82e75a2378c79379 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Mon, 22 Sep 2003 23:56:54 +0000 Subject: [PATCH] Added restricted tests for ASH, TRUNCATE, ROUND, CEILING, FLOOR. Improved pruning. --- ansi-tests/random-int-form.lsp | 106 ++++++++++++++++++++++++++++++--- 1 file changed, 98 insertions(+), 8 deletions(-) diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index 57151521..2b4f1e08 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -122,16 +122,39 @@ (rcase ;; Unary ops (40 - (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn + (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor + ceiling truncate round integer-length logcount values)))) `(,op ,(make-random-integer-form (1- size) vars)))) + (2 `(isqrt (abs ,(make-random-integer-form (- size 2) vars)))) + (3 + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(ash ,(make-random-integer-form s1 vars) + (min ,(random 100) + ,(make-random-integer-form s2 vars))))) + + ;; binary floor, ceiling, truncate, round + (4 + (let ((op (random-from-seq #(floor ceiling truncate round))) + (op2 (random-from-seq #(max min)))) + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(,op ,(make-random-integer-form s1 vars) + (,op2 ,(if (eq op2 'max) + (1+ (random 100)) + (- (1+ (random 100)))) + ,(make-random-integer-form s2 vars)))))) + ;; Binary op (80 (let* ((op (random-from-seq '(+ - * * logand min max min max ;; gcd lcm - #-:allegro logandc1 ;; bug in ACL 6.2 makes this cause crashes + ;; #-:allegro + logandc1 logandc2 logeqv logior lognand lognor - #-:allegro logorc1 ;; another bug in ACL 6.2 + ;; #-:allegro + logorc1 logorc2 logxor)))) (destructuring-bind (leftsize rightsize) (random-partition (1- size) 2) @@ -153,7 +176,7 @@ ,(make-random-integer-form s1 vars) ,(make-random-byte-spec-form s2 vars) ,(make-random-integer-form s3 vars)))) - #-:allegro + ;; #-:allegro (10 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(,(random-from-seq '(ldb mask-field)) @@ -350,8 +373,6 @@ (let ((n1 (1+ (random (floor n p))))) (cons n1 (random-partition (- n n1) (1- p))))))) -;;; Interface to the form pruner - (defun make-optimized-lambda-form (form vars var-types) `(lambda ,vars (declare ,@(mapcar #'(lambda (tp var) @@ -418,13 +439,13 @@ (let ((unopt-result (handler-case - (multiple-value-list + (identity ;; multiple-value-list (apply unoptimized-compiled-fn vals)) (error (c) (declare (ignore c)) (%eval-error :unoptimized-form-error)))) (opt-result (handler-case - (multiple-value-list + (identity ;; multiple-value-list (apply optimized-compiled-fn vals)) (error (c) (declare (ignore c)) (%eval-error :optimized-form-error))))) @@ -439,6 +460,8 @@ opt-result unopt-result))))))))))) +;;; Interface to the form pruner + (defun prune-int-form (form vars var-types vals-list) "Conduct tests on selected simplified versions of FORM. Return the minimal form that still causes some kind of failure." @@ -524,6 +547,11 @@ ((ldb mask-field) (try (second args)) + (when (and (consp (first args)) + (eq 'byte (first (first args))) + (every #'numberp (cdr (first args))) + (numberp (second args))) + (try (eval form))) (prune-fn form try-fn)) ((ldb-test) @@ -560,6 +588,63 @@ ((case) (prune-case form try-fn)) + + ((isqrt) + (let ((arg (second form))) + (assert (null (cddr form))) + (assert (consp arg)) + (assert (eq (first arg) 'abs)) + (let ((arg2 (second arg))) + ;; Try to fold + (when (integerp arg2) + (try (isqrt (abs arg2)))) + ;; Otherwise, simplify arg2 + (prune arg2 #'(lambda (form) + (try `(isqrt (abs ,form)))))))) + + ((ash) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (try form2) + (prune form1 + #'(lambda (form) + (try `(ash ,form ,form2)))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (eq (first form2) 'min) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(ash ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((floor ceiling truncate round) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (when (cddr form) (try form2)) + (prune form1 + (if (cddr form) + #'(lambda (form) + (try `(,op ,form ,form2))) + #'(lambda (form) (try `(,op ,form))))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (member (first form2) '(max min)) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(,op ,form1 (,(first form2) ,(second form2) + ,form))))))))) (otherwise (prune-fn form try-fn)) @@ -573,6 +658,7 @@ (find-in-tree value (cdr tree)))))) (defun prune-list (list element-prune-fn list-try-fn) + (declare (type function element-prune-fn list-try-fn)) "Utility function for pruning in a list." (loop for i from 0 for e in list @@ -585,6 +671,7 @@ (subseq list (1+ i)))))))) (defun prune-case (form try-fn) + (declare (type function try-fn)) (let* ((op (first form)) (expr (second form)) (cases (cddr form))) @@ -607,6 +694,7 @@ ;; Assume each case has a single form (prune-list cases #'(lambda (case try-fn) + (declare (function try-fn)) (when (eql (length case) 2) (prune (cadr case) #'(lambda (form) @@ -643,6 +731,7 @@ ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) + (declare (function try-fn)) (prune (cadr binding) #'(lambda (form) (funcall try-fn @@ -679,6 +768,7 @@ ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) + (declare (function try-fn)) (prune (third binding) #'(lambda (form) (funcall try-fn -- GitLab