Commit 683662bb authored by pfdietz's avatar pfdietz
Browse files

Fragments of a system for generating random lisp forms. Not yet ready for use.

parent f7312cc2
This directory contains (or will contain) a program for generating
random Lisp code. The intent is to generate random input cases to
test for compile and/or eval bugs.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Jun 6 18:15:50 2003
;;;; Contains: Generator class and associated generic function definitions
(in-package :rctest)
(compile-and-load "rctest-util.lsp")
(defvar *prototype-class-table* (make-hash-table)
"Contains a map from names of classes to prototype instances
for those classes.")
(defgeneric prototype (class)
(:method ((class standard-class) &aux (name (class-name class)))
(or (gethash name *prototype-class-table*)
(setf (gethash name *prototype-class-table*)
(make-instance class))))
(:method ((class symbol))
(prototype (find-class class))))
(defclass generator () ())
(defclass composite-generator (generator)
((subgenerators :type array :initform (make-array '(10)
:adjustable t
:fill-pointer 0))
(cumulative-weights :type array
:initform (make-array '(10)
:fill-pointer 0
:adjustable t
:element-type 'single-float
:initial-element 0.0f0))
))
(defclass simple-generator (generator) ())
(defgeneric generate (gen size &rest ctxt &key &allow-other-keys)
(:method
((gen composite-generator) (size real) &rest ctxt)
(let* ((subgens (slot-value gen 'subgenerators))
(n (fill-pointer subgens)))
(when (<= n 0) (return-from generate (values nil nil)))
(let* ((cum-weights (slot-value gen 'cumulative-weights))
(total-weight (aref cum-weights (1- n)))
(random-weight (random total-weight))
;; Replace POSITION call with a binary search if necessary
(index (position random-weight cum-weights :test #'>=)))
(loop for i from 1 to 10
do (multiple-value-bind (val success?)
(apply #'generate (aref subgens index) size ctxt)
(when success? (return (values val t))))
finally (return (values nil nil))))))
)
(defmethod generate ((gen symbol) size &rest ctxt &key &allow-other-keys)
(apply #'generate (prototype gen) size ctxt))
(defgeneric add-subgenerator (gen subgen weight)
(:method
((gen composite-generator) (subgen generator) weight)
(let* ((subgens (slot-value gen 'subgenerators))
(n (fill-pointer subgens))
(cum-weights (slot-value gen 'cumulative-weights))
(total-weight (if (> n 0) (aref cum-weights (1- n)) 0.0f0)))
(vector-push-extend gen subgens n)
(vector-push-extend (+ total-weight weight) cum-weights n)
(values))))
(defclass iterative-generator (generator)
((subgenerator :initarg :sub)))
(defclass random-iterative-generator (iterative-generator) ())
(defmethod generate ((gen random-iterative-generator) size &rest ctxt)
(if (<= size 1)
nil
(let ((subgen (slot-value gen 'subgenerator))
(subsizes (randomly-partition (1- size) (min (isqrt size) 10))))
(loop for subsize in subsizes
for (element success) = (multiple-value-list
(apply #'generate subgen subsize ctxt))
when success collect element))))
;;; Macro for defining simple generator objects
;;; BODY is the body of the method with arguments (gen ctxt size)
;;; for computing the result. Inside the body the function FAIL causes
;;; the generator to return (nil nil).
(defmacro defgenerator (name &key
keys
body
(superclass 'simple-generator)
slots)
(let ((rtag (gensym)))
(unless (listp keys) (setf keys (list keys)))
`(progn
(defclass ,name (,superclass) ,slots)
(defmethod generate ((gen ,name) (size real) &rest ctxt &key ,@keys)
(declare (ignorable gen size ctxt))
(block ,rtag
(flet ((fail () (return-from ,rtag (values nil nil))))
,body))))))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Jun 9 20:57:34 2003
;;;; Contains: Generators for lambda expressions
(in-package :rctest)
(compile-and-load "generator.lsp")
(defgenerator lambda-list-generator
:body
(let ((vars (loop for i from 1 to size collect (gensym))))
(values vars t vars)))
(defvar *lambda-list-generator* (make-instance 'lambda-list-generator))
(defgenerator lambda-generator.1 :keys (vars)
:body
(let* ((s1 (random (min 5 size)))
(s2 (- size s1)))
(multiple-value-bind (lambda-list success1 lambda-vars)
(apply #'generate *lambda-list-generator* s1 ctxt)
(let ((vars (append (mapcar #'list lambda-vars) vars)))
(multiple-value-bind (body success2)
(apply #'generate 'implicit-progn-generator s2 :vars vars ctxt)
(if (and success1 success2)
(values `(lambda ,lambda-list ,@body))
(values nil nil)))))))
(defvar *lambda-generator* (make-instance 'lambda-generator.1))
;;; Compile and load the rctest system
(load "../compile-and-load.lsp")
(load "../rt-package.lsp")
(compile-and-load "../rt.lsp")
(load "../cl-test-package.lsp")
(compile-and-load "../random-aux.lsp")
(load "rctest-package.lsp")
(compile-and-load "rctest-util.lsp")
(compile-and-load "generator.lsp")
(compile-and-load "lambda-generator.lsp")
(compile-and-load "form-generators.lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Jun 6 16:46:31 2003
;;;; Contains: Definition of the RCTEST package
(defpackage :rctest
(:use :cl :cl-test)
(:import-from "COMMON-LISP-USER" #:compile-and-load)
(:export
#:generate
))
;; (in-package :rctest)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Jun 7 21:42:23 2003
;;;; Contains: Utility functions for RCTEST
(in-package :rctest)
(defun randomly-partition (size &optional (limit 1))
"Return a randomly generated list of positive integers whose
sum is SIZE. Try to make no element be < LIMIT."
(declare (type unsigned-byte size limit))
(let ((result nil))
(loop
while (> size 0)
do
(let* ((e0 (min size (max limit (1+ (min (random size) (random size)))))))
(push e0 result)
(decf size e0)))
(random-permute result)))
Supports Markdown
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