Start cond-expand registry

This commit is contained in:
Lassi Kortela 2021-07-20 17:21:12 +03:00
parent 0f87d39e37
commit 193bce3dcd
1 changed files with 21 additions and 0 deletions

View File

@ -19,6 +19,8 @@
(let ((x (read))) (let ((x (read)))
(if (eof-object? x) (reverse xs) (loop (cons x xs)))))) (if (eof-object? x) (reverse xs) (loop (cons x xs))))))
(define (append-map f xs) (apply append (map f xs)))
(define (group head xs) (define (group head xs)
(define (eject gs g) (if (null? g) gs (cons (reverse g) gs))) (define (eject gs g) (if (null? g) gs (cons (reverse g) gs)))
(let loop ((xs xs) (gs '()) (g '())) (let loop ((xs xs) (gs '()) (g '()))
@ -206,6 +208,24 @@
(splice-operating-systems) (splice-operating-systems)
(splice-machines))))))) (splice-machines)))))))
(define (cond-expand-test)
(registry
"Tests cond-expand can do"
"cond-expand"
'(p)
(tabulate
'("ID" "Description")
(map (lambda (entry)
(cons (assoc? 'class entry)
`(((code
"("
,(symbol->string (assoc1 'id entry))
,@(append-map (lambda (arg) `(" " ,(symbol->string arg)))
(cdr (assoc 'args entry)))
")"))
,(format-description entry))))
(sort-by-id (group-file 'id "cond-expand.scm"))))))
(define (library-name) (define (library-name)
(registry (registry
"Library name prefixes" "Library name prefixes"
@ -341,6 +361,7 @@
,(operating-system) ,(operating-system)
,(machine) ,(machine)
,(feature) ,(feature)
,(cond-expand-test)
,(library-name) ,(library-name)
,(library-name-scheme) ,(library-name-scheme)
,(character-name) ,(character-name)