Commit c8094476 authored by camm's avatar camm

Update changes from 2.6.2pre for Debian test autobuild

parent f6cb6842
......@@ -1426,3 +1426,32 @@ the condition to go uncaught if it cannot be classified."
(unsigned-byte 32) float short-float
single-float double-float long-float
nil character base-char symbol boolean null))
(defun random-partition (n p)
"Partition n into p numbers, each >= 1. Return list of numbers."
(assert (<= 1 p))
((= p 1) (list n))
((< n p) (make-list p :initial-element 1))
(let ((n1 (1+ (random (floor n p)))))
(cons n1 (random-partition (- n n1) (1- p)))))))
((= p 1) (list n))
((= n 0) (make-list p :initial-element 0))
(t (let* ((r (random p))
(n1 (random (1+ n))))
((= r 0)
(cons n1 (random-partition (- n n1) (1- p))))
((= r (1- p))
(append (random-partition (- n n1) (1- p)) (list n1)))
(let* ((n2 (random (1+ (- n n1))))
(n3 (- n n1 n2)))
(append (random-partition n2 r)
(list n1)
(random-partition n3 (- p 1 r))))))))))
......@@ -2145,6 +2145,9 @@
(defparameter *cl-function-or-accessor-symbols*
(append *cl-function-symbols* *cl-accessor-symbols*))
(defparameter *cl-non-variable-constant-symbols*
......@@ -6,6 +6,28 @@
(load "cl-test-package.lsp")
(in-package :cl-test)
(load "universe.lsp")
(compile-and-load "random-aux.lsp")
(compile-and-load "ansi-aux.lsp")
;;; (unless (probe-file "ansi-aux.o") (compile-file "ansi-aux.lsp"))
;;; (load "ansi-aux.o")
(load "cl-symbol-names.lsp")
;(load "notes.lsp")
(setq *compile-verbose* nil
*compile-print* nil
*load-verbose* nil)
#+cmu (setq ext:*gc-verbose* nil)
#+gcl (setq compiler:*suppress-compiler-notes* t
compiler:*suppress-compiler-warnings* t
compiler:*compile-verbose* nil
compiler:*compile-print* nil)
#+lispworks (setq compiler::*compiler-warnings* nil)
#+ecl (setq c:*suppress-compiler-warnings* t
c:*suppress-compiler-notes* t)
#+clisp (setq custom::*warn-on-floating-point-contagion* nil)
......@@ -62,11 +62,6 @@
(defun p (i) (write (elt $y i) :pretty t :escape t) (values))
(defun load-failures (&key (pathname "failures.lsp"))
(length (setq $y (with-open-file (s pathname :direction :input)
(loop for x = (read s nil)
while x collect x)))))
(defun tn (n &optional (size 100))
(length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n))))))
......@@ -267,17 +262,6 @@
:key #'var-desc-name))
(return desc)))))
(defun is-zero-rank-integer-array-type (type)
"This function was introduced because of a bug in ACL 6.2"
; (subtypep type '(array integer 0))
(and (consp type)
(eq (car type) 'array)
(cddr type)
(or (eq (cadr type) '*)
(subtypep (cadr type) 'integer))
(or (eql (caddr type) 0)
(null (caddr type)))))
(defun make-random-integer-form (size)
"Generate a random legal lisp form of size SIZE (roughly)."
......@@ -293,9 +277,7 @@
(name (var-desc-name desc)))
((subtypep type 'integer) name)
(; (subtypep type '(array integer 0))
(is-zero-rank-integer-array-type type)
`(aref ,name))
((subtypep type '(array integer nil)) `(aref ,name))
((subtypep type '(cons integer integer))
(rcase (1 `(car ,name))
(1 `(cdr ,name))))
......@@ -315,14 +297,11 @@
return it)
;; (> size 1)
;; flet call
#-(or armedbear)
(30 ;; 5
(make-random-integer-flet-call-form size))
(5 (make-random-aref-form size))
;; Unary ops
(let ((op (random-from-seq '(- abs signum 1+ 1- conjugate
......@@ -510,6 +489,7 @@
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
`(block ,name ,(make-random-integer-form (1- size)))))
#-(or armedbear)
(let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
......@@ -573,27 +553,6 @@
(defun make-random-aref-form (size)
(when *vars*
(let* ((desc (random-var-desc))
(type (var-desc-type desc))
(name (var-desc-name desc)))
((null type) nil)
((subtypep type '(array integer (*)))
`(aref ,name (min ,(1- (first (third type)))
(max 0 ,(make-random-integer-form (- size 2))))))
((subtypep type '(array integer (* *)))
(destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
`(aref ,name
(min ,(1- (first (third type)))
(max 0 ,(make-random-integer-form s1)))
(min ,(1- (second (third type)))
(max 0 ,(make-random-integer-form s2))))))
(t nil))))
(make-random-integer-form size)))
(defun make-random-integer-flet-call-form (size)
(if *flet-names*
(let* ((flet-entry (random-from-seq *flet-names*))
......@@ -661,20 +620,9 @@
(var-desc-type desc))
(t (rcase
(4 '(integer * *))
(1 (setq e1 `(make-array nil :initial-element ,e1
(2 (setq e1 `(make-array nil :initial-element ,e1
,@(rcase (1 nil) (1 '(:adjustable t)))))
'(array integer nil))
(1 (let ((size (1+ (random 10))))
(setq e1 `(make-array '(,size):initial-element ,e1
,@(rcase (1 nil) (1 '(:adjustable t)))))
`(array integer (,size))))
(1 (let ((size1 (1+ (random 10)))
(size2 (1+ (random 10))))
(setq e1 `(make-array '(,size1 ,size2):initial-element ,e1
,@(rcase (1 nil) (1 '(:adjustable t)))))
`(array integer (,size1 ,size2))))
(1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1)))
'(cons integer integer))
(1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1))
......@@ -793,31 +741,11 @@
(setq op 'multiple-value-setq)
(setq var (list var)))
`(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil))
((and (subtypep '(array integer nil) type))
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
(when (eq op 'setq)
(setq op (random-from-seq #(setf shiftf))))
`(,op (aref ,var) ,(make-random-integer-form (- size 2))))
((and type (subtypep type '(array integer (*))))
(when (eq op 'setq)
(setq op (random-from-seq #(setf shiftf))))
(destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
`(,op (aref ,var (min ,(1- (first (third type)))
(max 0
,(make-random-integer-form s1))))
,(make-random-integer-form s2))))
((and type (subtypep type '(array integer (* *))))
(when (eq op 'setq)
(setq op (random-from-seq #(setf shiftf))))
(destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3)
`(,op (aref ,var
(min ,(1- (first (third type)))
(max 0
,(make-random-integer-form s1)))
(min ,(1- (second (third type)))
(max 0
,(make-random-integer-form s2))))
,(make-random-integer-form s3))))
;; Abort -- can't assign
(t (make-random-integer-form size))))
(make-random-integer-form size)))
......@@ -1430,18 +1358,6 @@
(when (cddr args)
(prune (car args) #'(lambda (form) (try `(/ ,form ,(second args)))))))
((expt rationalize rational numberator denominator)
(try 0)
(mapc try-fn args)
(prune-fn form try-fn))
(try 0)
(try (car args))
(prune #'(lambda (form) (try `(coerce ,form ,(cadr args))))
(car args)))
;; Simplify usual case
(when (= nargs 2)
......@@ -1470,7 +1386,6 @@
(eql (car arg2) 'min)
(integerp (cadr arg2)))
(let ((arg2.2 (caddr arg2)))
(try arg2.2)
(when (and (consp arg2.2)
(eql (car arg2.2) 'max)
(integerp (cadr arg2.2)))
......@@ -1958,13 +1873,10 @@
(let* ((op (car form))
(binding-list (cadr form))
(body (cddr form))
(body-len (length body))
(len (length binding-list))
;; (body-len (length body))
;; (len (length binding-list))
(when (> body-len 1)
(funcall try-fn `(,op ,binding-list ,@(cdr body))))
;; Try to simplify (let ((<name> <form>)) ...) to <form>
(when (and (>= len 1)
......@@ -1977,18 +1889,6 @@
(funcall try-fn val-form))))
(when (>= len 1)
(let ((val-form (cadar binding-list)))
(when (consp val-form)
(case (car val-form)
(let ((init (getf (cddr val-form) :initial-element)))
(when init
(funcall try-fn init))))
(funcall try-fn (cadr val-form))
(funcall try-fn (caddr val-form)))))))
;; Try to simplify the forms in the RHS of the bindings
(prune-list binding-list
#'(lambda (binding try-fn)
......@@ -2001,14 +1901,6 @@
#'(lambda (bindings)
(funcall try-fn `(,op ,bindings ,@body))))
;; Prune off unused variable
(when (and binding-list
(not (rest binding-list))
(let ((name (caar binding-list)))
(and (symbolp name)
(not (find-if-subtree #'(lambda (x) (eq x name)) body)))))
(funcall try-fn `(progn ,@body)))
;; Try to simplify the body of the LET form
(when body
(unless binding-list
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment