I've started on implementing a replacement test generator, see attachment. Usage is exactly the same as the original generate.py.
However, it hangs somewhere and I can't find how to step through a guile program, even in emacs. Help?
;; -*- geiser-scheme-implementation: guile -*-
;; Implementation: Danny Milosavljevic <dan...@scratchpost.org>
;; Based on: Implementation in Python by Vicent Marti.
;; License: ISC, like the original generate.py in clar.
(use-modules (ice-9 ftw))
(use-modules (ice-9 regex))
(use-modules (ice-9 getopt-long))
(use-modules (ice-9 rdelim))
(use-modules (ice-9 match))
(use-modules (ice-9 textual-ports))
(use-modules (srfi srfi-1))
(define (render-callback cb)
(if (> (length cb) 0)
(string-append " { \"" (assoc-ref cb "short-name") "\", &"
(assoc-ref cb "symbol") " }")
" { NULL, NULL }"))
(define (replace needle replacement haystack)
"Replace all occurences of NEEDLE in HAYSTACK by REPLACEMENT.
NEEDLE is a regular expression."
(regexp-substitute/global #f needle haystack 'pre replacement 'post))
(define (skip-comments text)
(replace (string-append "//.*?$|"
"/[*].*?[*]/|"
"'([.]|[^'])*'|"
"\"([.]|[^\"])*")
"" text))
(define (maybe-only items)
(match items
((a) a)
(_ #f)))
(define (Module name path excludes)
(let* ((clean-name (replace "_" "::" name))
(enabled (not (any (lambda (exclude)
(string-prefix? exclude clean-name))
excludes))))
(define (parse contents)
(define (cons-match match prev)
(cons
`(("declaration" ,(match:substring match 1))
("symbol" ,(match:substring match 2))
("short-name" ,(match:substring match 3)))
prev))
(let* ((contents (skip-comments contents))
(entries (fold-matches (string-append "^(void\\s+(test_"
name
"__(\\w+))\\s*\(\\s*void\\s*\\))\\s*\\{")
contents
'()
cons-match))
(callbacks (filter (lambda (entry)
(match (assoc-ref entry "short-name")
(("initialize" value) #f)
(("cleanup" value) #f)
(a #t)))
entries)))
(if (> (length callbacks) 0)
'(("name" name)
("enabled" (if enabled "1" "0"))
("clean-name" clean-name)
("initialize" (maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
(("initialize" value) value)
((_ value) #f)))
entries)))
("cleanup" (maybe-only (filter-map (lambda (entry)
(match (assoc-ref entry "short-name")
(("cleanup" value) value)
((_ value) #f)))
entries)))
("callbacks" callbacks))
#f)))
(define (refresh path)
(and (file-exists? path)
(parse (get-string-all path))))
(refresh path)))
(define (generate-TestSuite path output excludes)
(define (load)
(define enter? (const #t))
(define (leaf file stat result)
(let* ((module-root (string-drop file (string-length path)))
(module-root (filter-map (match-lambda
("" #f)
(a a))
(string-split module-root #\/))))
(define (make-module path)
(let* ((name (string-join (append module-root (list (string-drop-right (basename path) (string-length ".c")))) "_"))
(name (replace "-" "_" name)))
(Module name path excludes)))
(write file)
(write module-root)
(newline)
(if (string-suffix? ".c" file)
(let ((module (make-module file)))
(if module
(cons module result)
result))
result)))
(define (down dir stat result)
result)
(define (up file state result)
result)
(define skip (const #f))
(define error (const #f)) ; FIXME
(write "fold")
(newline)
(file-system-fold enter? leaf down up skip error '() path))
(define (CallbacksTemplate module)
(string-append "static const struct clar_func _clar_cb_" module-name "[] = {\n"
(string-join (map render-callback (assoc-ref module "callbacks")) ",\n")
"\n};\n"))
(define (DeclarationTemplate module)
(string-append (string-join (map (lambda (cb)
(string-append "extern"
(assoc-ref cb "declaration")
";"))
(assoc-ref module "callbacks"))
"\n")
"\n"
(if (assoc-ref module "initialize")
(string-append "extern " (assoc-ref (assoc-ref module "initialize") "declaration") ";\n")
"")
(if (assoc-ref module "cleanup")
(string-append "extern " (assoc-ref (assoc-ref module "cleanup") "declaration") ";\n")
"")))
(define (InfoTemplate module)
(string-append "
{
\"" (assoc-ref module "clean-name") "\",\"
" (render-callback (assoc-ref module "initialize")) ",
" (render-callback (assoc-ref module "cleanup")) ",
_clar_cb_" (assoc-ref module "name") ", "
(length (assoc-ref module "callbacks"))
", " (assoc-ref module "enabled") "
}"))
(define (write data)
(define (name< module-a module-b)
(string<? (assoc-ref module-a "name")
(assoc-ref module-b "name")))
(define modules (sort (load) name<))
(define (suite-count)
(length modules))
(define (callback-count)
(fold + 0 (map (lambda (entry)
(assoc-ref entry "callbacks"))
modules)))
(define (display-x value)
(display value data))
(for-each (compose display-x DeclarationTemplate) modules)
(for-each (compose display-x CallbacksTemplate) modules)
(display-x "static struct clar_suite _clar_suites[] = {")
(display-x (string-join (map InfoTemplate modules) ","))
(display-x "\n};\n")
(display-x "static const size_t _clar_suite_count = ")
(display-x (number->string (suite-count)))
(display-x ";\n")
(display-x "static const size_t _clar_callback_count = ")
(display-x (number->string (callback-count)))
(display-x ";\n")
(display (string-append "Written `clar.suite` (" callback-count " tests in " suite-count " suites"))
#t)
(call-with-output-file (string-append output "/clar.suite") write))
;;; main
(define (main)
(define option-spec
'((force (single-char #\f) (value #f))
(exclude (single-char #\x) (value #t))
(output (single-char #\o) (value #t))
(help (single-char #\h) (value #f))))
(define options (getopt-long (command-line) option-spec #:stop-at-first-non-option #t))
(define args (reverse (option-ref options '() '())))
(when (> (length args) 1)
(display "More than one path given\n")
(exit 1))
(if (< (length args) 1)
(set! args '(".")))
(let* ((path (car args))
(output (option-ref options 'output path))
(excluded (filter-map (match-lambda
(('exclude . value) value)
(_ #f))
options)))
(generate-TestSuite path output excluded)))
(main)
pgpngjrwztfVI.pgp
Description: OpenPGP digital signature
