/[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.9 by pfdietz, Mon Sep 22 23:56:54 2003 UTC revision 1.10 by pfdietz, Tue Sep 23 01:00:15 2003 UTC
# Line 123  Line 123 
123       ;; Unary ops       ;; Unary ops
124       (40       (40
125        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor        (let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor
126                                       ceiling truncate round                                       ceiling truncate round realpart imagpart
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))))       (2 `(isqrt (abs ,(make-random-integer-form (- size 2) vars))))
# Line 136  Line 136 
136            
137       ;; binary floor, ceiling, truncate, round       ;; binary floor, ceiling, truncate, round
138       (4       (4
139        (let ((op (random-from-seq #(floor ceiling truncate round)))        (let ((op (random-from-seq #(floor ceiling truncate round mod rem)))
140              (op2 (random-from-seq #(max min))))              (op2 (random-from-seq #(max min))))
141          (destructuring-bind (s1 s2)          (destructuring-bind (s1 s2)
142            (random-partition (- size 2) 2)            (random-partition (- size 2) 2)
# Line 511  Line 511 
511          (case op          (case op
512                    
513           ((signum integer-length logcount           ((signum integer-length logcount
514                    gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2)                    gcd lcm logandc1 logandc2 lognand lognor logorc1 logorc2
515                      realpart imagpart)
516            (mapc #'try args)            (mapc #'try args)
517            (try 0)            (try 0)
518            (try 1)            (try 1)
# Line 595  Line 596 
596              (assert (consp arg))              (assert (consp arg))
597              (assert (eq (first arg) 'abs))              (assert (eq (first arg) 'abs))
598              (let ((arg2 (second arg)))              (let ((arg2 (second arg)))
599                  (try arg2)
600                ;; Try to fold                ;; Try to fold
601                (when (integerp arg2)                (when (integerp arg2)
602                  (try (isqrt (abs arg2))))                  (try (isqrt (abs arg2))))
# Line 623  Line 625 
625                              `(ash ,form1 (,(first form2) ,(second form2)                              `(ash ,form1 (,(first form2) ,(second form2)
626                                            ,form)))))))))                                            ,form)))))))))
627    
628           ((floor ceiling truncate round)           ((floor ceiling truncate round mod rem)
629            (let ((form1 (second form))            (let ((form1 (second form))
630                  (form2 (third form)))                  (form2 (third form)))
631              (try form1)              (try form1)
# Line 672  Line 674 
674    
675  (defun prune-case (form try-fn)  (defun prune-case (form try-fn)
676    (declare (type function try-fn))    (declare (type function try-fn))
677    (let* ((op (first form))    (flet ((try (e) (funcall try-fn e)))
678           (expr (second form))      (let* ((op (first form))
679           (cases (cddr form)))             (expr (second form))
680               (cases (cddr form)))
681      ;; Try just the top expression        
682      (funcall try-fn expr)        ;; Try just the top expression
683          (try expr)
684      ;; Try simplifying the expr        
685      (prune expr        ;; Try simplifying the expr
686             #'(lambda (form)        (prune expr
687                 (funcall try-fn `(,op ,form ,@cases))))               #'(lambda (form)
688                     (try `(,op ,form ,@cases))))
689      ;; Try deleting individual cases        
690      (loop for i from 0 below (1- (length cases))        ;; Try individual cases
691            do (funcall try-fn `(,op ,expr        (loop for case in cases
692                                    ,@(subseq cases 0 i)              do (try (first (last (rest case)))))
693                                    ,@(subseq cases (1+ i)))))        
694          ;; Try deleting individual cases
695      ;; Try simplifying the cases        (loop for i from 0 below (1- (length cases))
696      ;; Assume each case has a single form              do (try `(,op ,expr
697      (prune-list cases                            ,@(subseq cases 0 i)
698                  #'(lambda (case try-fn)                            ,@(subseq cases (1+ i)))))
699                      (declare (function try-fn))        
700                      (when (eql (length case) 2)        ;; Try simplifying the cases
701                        (prune (cadr case)        ;; Assume each case has a single form
702                               #'(lambda (form)        (prune-list cases
703                                   (funcall try-fn                    #'(lambda (case try-fn)
704                                            (list (car case) form))))))                        (declare (function try-fn))
705                  #'(lambda (cases)                        (when (eql (length case) 2)
706                      (funcall try-fn `(,op ,expr ,@cases))))))                          (prune (cadr case)
707                                       #'(lambda (form)
708                                       (funcall try-fn
709                                                (list (car case) form))))))
710                      #'(lambda (cases)
711                          (try `(,op ,expr ,@cases)))))))
712    
713  (defun prune-fn (form try-fn)  (defun prune-fn (form try-fn)
714    "Attempt to simplify a function call form.  It is considered    "Attempt to simplify a function call form.  It is considered

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

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