backquote-aux.lsp 1.69 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Jun 11 08:04:23 2004
;;;; Contains: Aux. functions associated with backquote tests

(in-package :cl-test)

;;; Not yet finished


;;; Create random backquoted forms
(defun make-random-backquoted-form (size)
  (my-with-standard-io-syntax
   (let ((*print-readably* nil)
sds's avatar
sds committed
15
         (*package* (find-package "CL-TEST")))
pfdietz's avatar
pfdietz committed
16 17
     (read-from-string
      (concatenate 'string
sds's avatar
sds committed
18 19
                   "`"
                   (make-random-backquoted-sequence-string size))))))
pfdietz's avatar
pfdietz committed
20 21 22 23 24 25

(defun make-random-backquoted-sequence-string (size)
  (case size
    ((0 1) (make-random-backquoted-string size))
    (t
     (let* ((nelements (1+ (min (random (1- size)) (random (1- size)) 9)))
sds's avatar
sds committed
26 27
            (sizes (random-partition (1- size) nelements))
            (substrings (mapcar #'make-random-backquoted-string sizes)))
pfdietz's avatar
pfdietz committed
28
       (apply #'concatenate
sds's avatar
sds committed
29 30 31 32 33 34 35 36 37 38
              'string
              "("
              (car substrings)
              (if nil ; (and (> nelements 1) (coin))
                  (nconc
                   (loop for s in (cddr substrings) collect " " collect s)
                   (list " . " (cadr substrings) ")"))
                (nconc
                 (loop for s in (cdr substrings) collect " " collect s)
                 (list ")"))))))))
pfdietz's avatar
pfdietz committed
39 40 41 42 43 44 45 46 47 48 49 50

;;; Create a string that is a backquoted form
(defun make-random-backquoted-string (size)
  (if (<= size 1)
      (rcase
       (1 "()")
       (1 (string (random-from-seq #.(coerce *cl-symbol-names* 'vector))))
       (1 (write-to-string (- (random 2001) 1000)))
       (2 (concatenate 'string "," (string (random-from-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))))
       )
    ;; size > 1
    (make-random-backquoted-sequence-string size)))