1 | ;;;; slib-grammar.scm |
---|
2 | |
---|
3 | ;; |
---|
4 | |
---|
5 | (define *grammar-ids* '()) |
---|
6 | |
---|
7 | (define (grammar-id-name-set! id name) |
---|
8 | (set! *grammar-ids* (alist-update! id name *grammar-ids* eqv?)) ) |
---|
9 | |
---|
10 | (define (grammar-id-name id) |
---|
11 | (alist-ref id *grammar-ids* eqv?) ) |
---|
12 | |
---|
13 | (define (list-of-grammar-ids) |
---|
14 | (map car *grammar-ids*) ) |
---|
15 | |
---|
16 | (define (count-of-grammar-ids) |
---|
17 | (length *grammar-ids*) ) |
---|
18 | |
---|
19 | (define (clear-grammar-ids) |
---|
20 | (set! *grammar-ids* '()) ) |
---|
21 | |
---|
22 | ;ordered list of grammar names |
---|
23 | (define (grammar-id-name-setup! names) |
---|
24 | (import (only (srfi 1) iota)) |
---|
25 | (for-each grammar-id-name-set! (iota (length names)) names) ) |
---|
26 | |
---|
27 | ;; |
---|
28 | |
---|
29 | ;;from jacal unparse.scm |
---|
30 | |
---|
31 | (define (print-using-grammar sexp grm) |
---|
32 | ;(print "[" (grammar-name grm) "] " sexp) |
---|
33 | (pretty-print sexp) |
---|
34 | #; ;FIXME needs most of jacal! |
---|
35 | (template-print sexp (grammar-write-tab grm)) ) |
---|
36 | |
---|
37 | ; supplies module based struct tag & other identifiers |
---|
38 | (define-record grammar name reader read-tab writer write-tab) |
---|
39 | (define-record-type grammar |
---|
40 | (make-grammar name reader read-tab writer write-tab) |
---|
41 | grammar? |
---|
42 | (name grammar-name grammar-name-set!) |
---|
43 | (reader grammar-reader grammar-reader-set!) |
---|
44 | (read-tab grammar-read-tab grammar-read-tab-set!) |
---|
45 | (writer grammar-writer grammar-writer-set!) |
---|
46 | (write-tab grammar-write-tab grammar-read-tab-set!) ) |
---|
47 | |
---|
48 | ; |
---|
49 | (define *grammars* '()) |
---|
50 | |
---|
51 | (define (defgrammar name grm) |
---|
52 | (set! *grammars* (alist-update! name grm *grammars* eq?)) ) |
---|
53 | |
---|
54 | (define (get-grammar name) |
---|
55 | (alist-ref name *grammars* eq?) ) |
---|
56 | |
---|
57 | (define (list-of-grammars) |
---|
58 | (map (lambda (cell) (car cell)) *grammars*) ) |
---|
59 | |
---|
60 | (define (count-of-grammars) |
---|
61 | (length *grammars*) ) |
---|
62 | |
---|
63 | (define (get-grammar/id id) |
---|
64 | (get-grammar (grammar-id-name id)) ) |
---|
65 | |
---|
66 | (define (clear-grammars) |
---|
67 | (clear-grammar-ids) |
---|
68 | (set! *grammar* '()) ) |
---|
69 | |
---|
70 | ; |
---|
71 | (define (read-sexp grm column) ((grammar-reader grm) grm column)) |
---|
72 | (define (write-sexp sexp grm) ((grammar-writer grm) sexp grm)) |
---|
73 | |
---|
74 | (define *tab-stop* 8) |
---|
75 | |
---|
76 | ; |
---|
77 | (define (flush-input-whitespace port) |
---|
78 | (do ((chr (peek-char port) (peek-char port)) |
---|
79 | (col 0 (case chr |
---|
80 | ((#\space) (+ 1 col)) |
---|
81 | ((#\tab) (modulo (+ (sub1 *tab-stop*) col) *tab-stop*)) |
---|
82 | ((#\newline) 0) |
---|
83 | (else col)))) |
---|
84 | ((or (eof-object? chr) |
---|
85 | (not (char-whitespace? chr))) |
---|
86 | col) |
---|
87 | (read-char port))) |
---|
88 | |
---|
89 | ;; |
---|
90 | |
---|
91 | (define (make-delimited-parse-grammar-reader delim) |
---|
92 | (lambda (grm column #!optional (port (current-input-port))) |
---|
93 | (prec:parse |
---|
94 | (grammar-read-tab grm) |
---|
95 | delim |
---|
96 | (+ column (flush-input-whitespace port)) |
---|
97 | port)) ) |
---|
98 | |
---|
99 | ;; |
---|
100 | |
---|
101 | (define (grammar-copy! grm1 grm2) |
---|
102 | (grammar-name-set! grm1 (grammar-name grm2)) |
---|
103 | (grammar-reader-set! grm1 (grammar-reader grm2)) |
---|
104 | (grammar-read-tab-set! grm1 (grammar-read-tab grm2)) |
---|
105 | (grammar-writer-set! grm1 (grammar-writer grm2)) |
---|
106 | (grammar-read-tab-set! grm1 (grammar-write-tab grm2)) ) |
---|
107 | |
---|
108 | (define temporary-grammar |
---|
109 | (let ((+grammar-cache+ (make-grammar #f #f #f #f #f))) |
---|
110 | (lambda (grm) |
---|
111 | (grammar-copy! +grammar-cache+ grm) |
---|
112 | +grammar-cache+ ) ) ) |
---|
113 | |
---|
114 | (define (read-delimited-sexp port delim grm column) |
---|
115 | (unless (grammar? grm) (error 'read-delimited-sexp "invalid grammar" grm)) |
---|
116 | (let ((tmp (temporary-grammar grm))) |
---|
117 | (grammar-reader-set! tmp (make-delimited-parse-grammar-reader delim)) |
---|
118 | (parameterize ((current-input-port port)) |
---|
119 | (read-sexp tmp column) ) ) ) |
---|