/[gcl]/gcl/ansi-tests/random-int-form.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/random-int-form.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by pfdietz, Sun Sep 21 17:23:43 2003 UTC revision 1.9 by pfdietz, Mon Sep 22 23:56:54 2003 UTC
# Line 122  Line 122 
122      (rcase      (rcase
123       ;; Unary ops       ;; Unary ops
124       (40       (40
125        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor
126                                         ceiling truncate round
127                                       integer-length logcount values))))                                       integer-length logcount values))))
128          `(,op ,(make-random-integer-form (1- size) vars))))          `(,op ,(make-random-integer-form (1- size) vars))))
129         (2 `(isqrt (abs ,(make-random-integer-form (- size 2) vars))))
130         (3
131          (destructuring-bind (s1 s2)
132              (random-partition (- size 2) 2)
133            `(ash ,(make-random-integer-form s1 vars)
134                  (min ,(random 100)
135                       ,(make-random-integer-form s2 vars)))))
136        
137         ;; binary floor, ceiling, truncate, round
138         (4
139          (let ((op (random-from-seq #(floor ceiling truncate round)))
140                (op2 (random-from-seq #(max min))))
141            (destructuring-bind (s1 s2)
142              (random-partition (- size 2) 2)
143              `(,op  ,(make-random-integer-form s1 vars)
144                     (,op2  ,(if (eq op2 'max)
145                                 (1+ (random 100))
146                               (- (1+ (random 100))))
147                            ,(make-random-integer-form s2 vars))))))
148                
149       ;; Binary op       ;; Binary op
150       (80       (80
151        (let* ((op (random-from-seq        (let* ((op (random-from-seq
152                    '(+ - * * logand min max min max ;; gcd lcm                    '(+ - * * logand min max min max ;; gcd lcm
153                        #-:allegro logandc1  ;; bug in ACL 6.2 makes this cause crashes                        ;; #-:allegro
154                          logandc1
155                        logandc2 logeqv logior lognand lognor                        logandc2 logeqv logior lognand lognor
156                        #-:allegro logorc1 ;; another bug in ACL 6.2                        ;; #-:allegro
157                          logorc1
158                        logorc2 logxor))))                        logorc2 logxor))))
159          (destructuring-bind (leftsize rightsize)          (destructuring-bind (leftsize rightsize)
160              (random-partition (1- size) 2)              (random-partition (1- size) 2)
# Line 153  Line 176 
176            ,(make-random-integer-form s1 vars)            ,(make-random-integer-form s1 vars)
177            ,(make-random-byte-spec-form s2 vars)            ,(make-random-byte-spec-form s2 vars)
178            ,(make-random-integer-form s3 vars))))            ,(make-random-integer-form s3 vars))))
179       #-:allegro       ;; #-:allegro
180       (10       (10
181        (destructuring-bind (s1 s2) (random-partition (1- size) 2)        (destructuring-bind (s1 s2) (random-partition (1- size) 2)
182            `(,(random-from-seq '(ldb mask-field))            `(,(random-from-seq '(ldb mask-field))
# Line 350  Line 373 
373      (let ((n1 (1+ (random (floor n p)))))      (let ((n1 (1+ (random (floor n p)))))
374        (cons n1 (random-partition (- n n1) (1- p)))))))        (cons n1 (random-partition (- n n1) (1- p)))))))
375    
 ;;; Interface to the form pruner  
   
376  (defun make-optimized-lambda-form (form vars var-types)  (defun make-optimized-lambda-form (form vars var-types)
377    `(lambda ,vars    `(lambda ,vars
378       (declare ,@(mapcar #'(lambda (tp var)       (declare ,@(mapcar #'(lambda (tp var)
# Line 418  Line 439 
439                                
440              (let ((unopt-result              (let ((unopt-result
441                     (handler-case                     (handler-case
442                      (multiple-value-list                      (identity ;; multiple-value-list
443                       (apply unoptimized-compiled-fn vals))                       (apply unoptimized-compiled-fn vals))
444                      (error (c) (declare (ignore c))                      (error (c) (declare (ignore c))
445                             (%eval-error :unoptimized-form-error))))                             (%eval-error :unoptimized-form-error))))
446                    (opt-result                    (opt-result
447                     (handler-case                     (handler-case
448                      (multiple-value-list                      (identity ;; multiple-value-list
449                       (apply optimized-compiled-fn vals))                       (apply optimized-compiled-fn vals))
450                      (error (c) (declare (ignore c))                      (error (c) (declare (ignore c))
451                             (%eval-error :optimized-form-error)))))                             (%eval-error :optimized-form-error)))))
# Line 439  Line 460 
460                                       opt-result                                       opt-result
461                                       unopt-result)))))))))))                                       unopt-result)))))))))))
462    
463    ;;; Interface to the form pruner
464    
465  (defun prune-int-form (form vars var-types vals-list)  (defun prune-int-form (form vars var-types vals-list)
466    "Conduct tests on selected simplified versions of FORM.  Return the    "Conduct tests on selected simplified versions of FORM.  Return the
467     minimal form that still causes some kind of failure."     minimal form that still causes some kind of failure."
# Line 524  Line 547 
547    
548           ((ldb mask-field)           ((ldb mask-field)
549            (try (second args))            (try (second args))
550              (when (and (consp (first args))
551                         (eq 'byte (first (first args)))
552                         (every #'numberp (cdr (first args)))
553                         (numberp (second args)))
554                (try (eval form)))
555            (prune-fn form try-fn))            (prune-fn form try-fn))
556    
557           ((ldb-test)           ((ldb-test)
# Line 560  Line 588 
588    
589           ((case)           ((case)
590            (prune-case form try-fn))            (prune-case form try-fn))
591    
592             ((isqrt)
593              (let ((arg (second form)))
594                (assert (null (cddr form)))
595                (assert (consp arg))
596                (assert (eq (first arg) 'abs))
597                (let ((arg2 (second arg)))
598                  ;; Try to fold
599                  (when (integerp arg2)
600                    (try (isqrt (abs arg2))))
601                  ;; Otherwise, simplify arg2
602                  (prune arg2 #'(lambda (form)
603                                  (try `(isqrt (abs ,form))))))))
604    
605             ((ash)
606              (let ((form1 (second form))
607                    (form2 (third form)))
608                (try form1)
609                (try form2)
610                (prune form1
611                       #'(lambda (form)
612                           (try `(ash ,form ,form2))))
613                (when (and (consp form2)
614                           (= (length form2) 3))
615                  (when (and (integerp form1)
616                             (eq (first form2) 'min)
617                             (every #'integerp (cdr form2)))
618                    (try (eval form)))
619                  (let ((form3 (third form2)))
620                    (prune form3
621                           #'(lambda (form)
622                               (try
623                                `(ash ,form1 (,(first form2) ,(second form2)
624                                              ,form)))))))))
625    
626             ((floor ceiling truncate round)
627              (let ((form1 (second form))
628                    (form2 (third form)))
629                (try form1)
630                (when (cddr form) (try form2))
631                (prune form1
632                       (if (cddr form)
633                           #'(lambda (form)
634                               (try `(,op ,form ,form2)))
635                         #'(lambda (form) (try `(,op ,form)))))
636                (when (and (consp form2)
637                           (= (length form2) 3))
638                  (when (and (integerp form1)
639                             (member (first form2) '(max min))
640                             (every #'integerp (cdr form2)))
641                    (try (eval form)))
642                  (let ((form3 (third form2)))
643                    (prune form3
644                           #'(lambda (form)
645                               (try
646                                `(,op ,form1 (,(first form2) ,(second form2)
647                                              ,form)))))))))
648                    
649           (otherwise           (otherwise
650            (prune-fn form try-fn))            (prune-fn form try-fn))
# Line 573  Line 658 
658                 (find-in-tree value (cdr tree))))))                 (find-in-tree value (cdr tree))))))
659    
660  (defun prune-list (list element-prune-fn list-try-fn)  (defun prune-list (list element-prune-fn list-try-fn)
661      (declare (type function element-prune-fn list-try-fn))
662    "Utility function for pruning in a list."    "Utility function for pruning in a list."
663      (loop for i from 0      (loop for i from 0
664            for e in list            for e in list
# Line 585  Line 671 
671                                             (subseq list (1+ i))))))))                                             (subseq list (1+ i))))))))
672    
673  (defun prune-case (form try-fn)  (defun prune-case (form try-fn)
674      (declare (type function try-fn))
675    (let* ((op (first form))    (let* ((op (first form))
676           (expr (second form))           (expr (second form))
677           (cases (cddr form)))           (cases (cddr form)))
# Line 607  Line 694 
694      ;; Assume each case has a single form      ;; Assume each case has a single form
695      (prune-list cases      (prune-list cases
696                  #'(lambda (case try-fn)                  #'(lambda (case try-fn)
697                        (declare (function try-fn))
698                      (when (eql (length case) 2)                      (when (eql (length case) 2)
699                        (prune (cadr case)                        (prune (cadr case)
700                               #'(lambda (form)                               #'(lambda (form)
# Line 643  Line 731 
731      ;; Try to simplify the forms in the RHS of the bindings      ;; Try to simplify the forms in the RHS of the bindings
732      (prune-list binding-list      (prune-list binding-list
733                  #'(lambda (binding try-fn)                  #'(lambda (binding try-fn)
734                        (declare (function try-fn))
735                      (prune (cadr binding)                      (prune (cadr binding)
736                             #'(lambda (form)                             #'(lambda (form)
737                                 (funcall try-fn                                 (funcall try-fn
# Line 679  Line 768 
768      ;; Try to simplify the forms in the RHS of the bindings      ;; Try to simplify the forms in the RHS of the bindings
769      (prune-list binding-list      (prune-list binding-list
770                  #'(lambda (binding try-fn)                  #'(lambda (binding try-fn)
771                        (declare (function try-fn))
772                      (prune (third binding)                      (prune (third binding)
773                             #'(lambda (form)                             #'(lambda (form)
774                                 (funcall try-fn                                 (funcall try-fn

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26