source: project/release/5/slib-prec/trunk/slib-grammar.scm @ 38716

Last change on this file since 38716 was 38716, checked in by Kon Lovett, 4 months ago

split grammers, strict-types

File size: 3.2 KB
Line 
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) ) ) )
Note: See TracBrowser for help on using the repository browser.