lassik
/
scheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Detect Gauche srfi-NNN libraries

This commit is contained in:
Lassi Kortela 2021-08-18 19:02:24 +03:00
parent 2f1981e068
commit 408409c48c
1 changed files with 25 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
library-inspection.sld
View File

@ -31,6 +31,7 @@
(begin (begin
(define (module-name->library-name module-name) (define (module-name->library-name module-name)
(define (split-at char string) (define (split-at char string)
(let loop ((a 0) (b 0) (parts '())) (let loop ((a 0) (b 0) (parts '()))
(cond ((= a b (string-length string)) (cond ((= a b (string-length string))
@ -41,23 +42,43 @@
(loop (+ b 1) (+ b 1) (cons (substring string a b) parts))) (loop (+ b 1) (+ b 1) (cons (substring string a b) parts)))
(else (else
(loop a (+ b 1) parts))))) (loop a (+ b 1) parts)))))
(define (string->library-name-part string) (define (string->library-name-part string)
(or (string->number string) (or (string->number string)
(string->symbol string))) (string->symbol string)))
(map string->library-name-part
(split-at #\. (symbol->string module-name)))) (define (srfi-number string)
(let ((srfi- "srfi-"))
(and (> (string-length string) (string-length srfi-))
(string=? srfi- (substring string 0 (string-length srfi-)))
(string->number (substring string (string-length srfi-)
(string-length string))))))
(let* ((string (symbol->string module-name))
(number (srfi-number string)))
(if number
`(srfi ,number)
(map string->library-name-part (split-at #\. string)))))
(define (library-name->module-name library-name) (define (library-name->module-name library-name)
(define (string-join strings delim) (define (string-join strings delim)
(if (null? strings) "" (if (null? strings) ""
(let loop ((acc (car strings)) (strings (cdr strings))) (let loop ((acc (car strings)) (strings (cdr strings)))
(if (null? strings) acc (if (null? strings) acc
(loop (string-append acc delim (car strings)) (loop (string-append acc delim (car strings))
(cdr strings)))))) (cdr strings))))))
(define (library-name-part->string part) (define (library-name-part->string part)
(if (number? part) (number->string part) (symbol->string part))) (if (number? part) (number->string part) (symbol->string part)))
(string->symbol (string->symbol
(string-join (map library-name-part->string library-name) "."))) (if (and (= (length library-name) 2)
(eq? 'srfi (car library-name))
(number? (cadr library-name)))
(string-append "srfi-" (number->string (cadr library-name)))
(string-join (map library-name-part->string library-name)
"."))))
(define (library-list) (define (library-list)
(map (lambda (m) (module-name->library-name (module-name m))) (map (lambda (m) (module-name->library-name (module-name m)))
@ -70,6 +91,6 @@
(loop (if (match? (car list)) acc (cons (car list) acc)) (loop (if (match? (car list)) acc (cons (car list) acc))
(cdr list))))) (cdr list)))))
(let ((m (find-module (library-name->module-name library-name)))) (let ((m (find-module (library-name->module-name library-name))))
(if m (remove (lambda (x) (memq x '(*1 *3+ *1+ *2+ *e *3 *history *2))) (if m (remove (lambda (x) (memq x '(*1 *1+ *2 *2+ *3 *3+ *e *history)))
(module-exports m)) (module-exports m))
(error "No such library" library-name)))))))) (error "No such library" library-name))))))))