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