summary refs log tree commit diff stats
diff options
context:
space:
mode:
authorCase Duckworth2023-05-01 23:48:45 -0500
committerCase Duckworth2023-05-01 23:48:45 -0500
commit180489d214cf4e99508c58fd63a90b89811addae (patch)
tree44abb57591eb14a545777b54d323ffa7029fecf0
parentInitial commit (diff)
downloadruse-main.tar.gz
ruse-main.zip
Add library definition generator and writer main
-rwxr-xr-xruse.scm76
1 files changed, 63 insertions, 13 deletions
diff --git a/ruse.scm b/ruse.scm index 1fff10a..b5c7519 100755 --- a/ruse.scm +++ b/ruse.scm
@@ -7,7 +7,16 @@ Make r7rs library files out of source scheme files
7 7
8#+chicken (import (r7rs)) 8#+chicken (import (r7rs))
9(import (scheme base) 9(import (scheme base)
10 (scheme file)) 10 (scheme file)
11 (scheme write)
12 (chicken pathname)
13 (chicken pretty-print)
14 (chicken string)
15 (utf8))
16
17(define (displayln str)
18 (display str)
19 (newline))
11 20
12(define (filter pred xs) 21(define (filter pred xs)
13 (let loop ((pred pred) 22 (let loop ((pred pred)
@@ -22,22 +31,23 @@ Make r7rs library files out of source scheme files
22 (loop pred (cdr xs) acc))))) 31 (loop pred (cdr xs) acc)))))
23 32
24(define (top-level-defines tree) 33(define (top-level-defines tree)
25 (filter (lambda (x)
26 (memq (car x)
27 '( define
28 define-syntax
29 define-record-type
30 define-values
31 ;; others ?
32 )))
33 tree))
34
35(define (top-level-names tree)
36 (map (lambda (d) 34 (map (lambda (d)
37 (if (pair? (cadr d)) 35 (if (pair? (cadr d))
38 (caadr d) 36 (caadr d)
39 (cadr d))) 37 (cadr d)))
40 (top-level-defines tree))) 38 (filter (lambda (x)
39 (memq (car x)
40 '( define
41 define-syntax
42 define-record-type
43 define-values
44 ;; others ?
45 )))
46 tree)))
47
48(define (top-level-imports tree)
49 (filter (lambda (x) (memq (car x) '(import)))
50 tree))
41 51
42(define (slurp-file file) 52(define (slurp-file file)
43 (with-input-from-file file 53 (with-input-from-file file
@@ -48,3 +58,43 @@ Make r7rs library files out of source scheme files
48 (reverse it) 58 (reverse it)
49 (loop (read) (cons next it))))))) 59 (loop (read) (cons next it)))))))
50 60
61(define (assq-ref x alist)
62 (and (assq x alist)
63 (cdr (assq x alist))
64 #f))
65
66(define (file->library-definition file . args)
67 (let* ((tree (slurp-file file))
68 (name (file->library-name file))
69 (exports (top-level-defines tree))
70 (imports (top-level-imports tree))
71 ;; Possibly: `include-library-interface' ?
72 (includer (or (assq-ref 'includer args) 'include))
73 (includes (list file)))
74 `(define-library ,name
75 (export ,@exports)
76 ,@imports
77 (,includer ,@includes))))
78
79(define (file->library-name file)
80 (map string->symbol
81 (string-split (pathname-file file) ".")))
82
83(define cond-expand-form
84 '(cond-expand
85 (chicken (import (r7rs)))
86 (else)))
87
88(define (write-library-definition library-definition . port)
89 (parameterize ((current-output-port (if (null? port)
90 (current-output-port)
91 port))
92 (pretty-print-width 80))
93 (displayln (string-append ";;; " (->string
94 (cadr library-definition))
95 " --- library definition"))
96 (displayln ";; This file was automatically generated by ruse.\n")
97 (pretty-print cond-expand-form)
98 (newline)
99 (pretty-print library-definition)
100 (newline)))