Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
ansi-test
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Karsten Poeck
ansi-test
Commits
c8094476
Commit
c8094476
authored
Jun 14, 2004
by
camm
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Update changes from 2.6.2pre for Debian test autobuild
parent
f6cb6842
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
60 additions
and
114 deletions
+60
-114
ansi-tests/ansi-aux.lsp
ansi-tests/ansi-aux.lsp
+29
-0
ansi-tests/cl-symbol-names.lsp
ansi-tests/cl-symbol-names.lsp
+3
-0
ansi-tests/gclload1.lsp
ansi-tests/gclload1.lsp
+22
-0
ansi-tests/random-int-form.lsp
ansi-tests/random-int-form.lsp
+6
-114
No files found.
ansi-tests/ansi-aux.lsp
View file @
c8094476
...
...
@@ -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))
#|
(cond
((= p 1) (list n))
((< n p) (make-list p :initial-element 1))
(t
(let ((n1 (1+ (random (floor n p)))))
(cons n1 (random-partition (- n n1) (1- p)))))))
|#
(cond
((= p 1) (list n))
((= n 0) (make-list p :initial-element 0))
(t (let* ((r (random p))
(n1 (random (1+ n))))
(cond
((= r 0)
(cons n1 (random-partition (- n n1) (1- p))))
((= r (1- p))
(append (random-partition (- n n1) (1- p)) (list n1)))
(t
(let* ((n2 (random (1+ (- n n1))))
(n3 (- n n1 n2)))
(append (random-partition n2 r)
(list n1)
(random-partition n3 (- p 1 r))))))))))
ansi-tests/cl-symbol-names.lsp
View file @
c8094476
...
...
@@ -2145,6 +2145,9 @@
*cl-standard-generic-function-symbols*
'
(
declare
)))))
(
defparameter
*
cl
-
function
-
or
-
accessor
-
symbols
*
(
append
*
cl
-
function
-
symbols
*
*
cl
-
accessor
-
symbols
*))
(
defparameter
*
cl
-
non
-
variable
-
constant
-
symbols
*
(
set
-
difference
*
cl
-
symbols
*
...
...
ansi-tests/gclload1.lsp
View file @
c8094476
...
...
@@ -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)
ansi-tests/random-int-form.lsp
View file @
c8094476
...
...
@@ -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)))
(cond
((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)
(rcase
;; flet call
#-(or armedbear)
(30 ;; 5
(make-random-integer-flet-call-form size))
(5 (make-random-aref-form size))
;; Unary ops
(40
(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)
(20
(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)
(or
(when *vars*
(let* ((desc (random-var-desc))
(type (var-desc-type desc))
(name (var-desc-name desc)))
(cond
((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))
((coerce)
(try 0)
(try (car args))
(prune #'(lambda (form) (try `(coerce ,form ,(cadr args))))
(car args)))
((multiple-value-call)
;; 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)
((make-array)
(let ((init (getf (cddr val-form) :initial-element)))
(when init
(funcall try-fn init))))
((cons)
(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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment