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

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

move grammer record into module, remove redundant -local, add #{..} read-syntax module, grammer define not automatic w/o syntax

File size: 4.9 KB
Line 
1;;;; slib-prec-grammar.scm  -*- Scheme -*-
2;;;; Kon Lovett, Apr '20
3;;;; Kon Lovett, Apr '18
4
5(module slib-prec-grammar
6
7(;export
8  ;
9  active-grammar active-grammar-set!
10  active-input-grammar active-output-grammar active-echo-grammar
11  ;
12  make-grammar
13  grammar?
14  grammar-name
15  grammar-reader
16  grammar-read-tab
17  grammar-writer
18  grammar-write-tab
19  ;
20  grammar-id-name
21  list-of-grammar-ids
22  count-of-grammar-ids
23  clear-grammar-ids
24  grammar-id-name-setup!
25  ;
26  defgrammar
27  get-grammar
28  list-of-grammars
29  count-of-grammars
30  get-grammar/id
31  clear-grammars
32  ;
33  read-sexp
34  write-sexp
35  print-using-grammar
36  flush-input-whitespace
37  ;
38  make-delimited-parse-grammar-reader
39  make-delimited-sexp-reader
40  read-sexp-from-string)
41
42(import scheme)
43(import (chicken base))
44(import (chicken type))
45(import (only (srfi 1) iota))
46(import slib-prec-parse)
47
48;;;
49
50(include "slib-compat")
51
52;;
53
54(define *grammar-ids* '())
55
56(define (grammar-id-name-set! id name)
57  (set! *grammar-ids* (alist-update! id name *grammar-ids* eqv?)) )
58
59(define (grammar-id-name id)
60  (alist-ref id *grammar-ids* eqv?) )
61
62(define (list-of-grammar-ids)
63  (map car *grammar-ids*) )
64
65(define (count-of-grammar-ids)
66  (length *grammar-ids*) )
67
68(define (clear-grammar-ids)
69  (set! *grammar-ids* '()) )
70
71;ordered list of grammar names
72(define (grammar-id-name-setup! names)
73  (clear-grammar-ids)
74  (for-each grammar-id-name-set! (iota (length names)) names) )
75
76;;
77
78;;from jacal unparse.scm
79
80(define (print-using-grammar sexp grm)
81  ;(print "[" (grammar-name grm) "] " sexp)
82  (pretty-print sexp)
83  #; ;FIXME needs most of jacal!
84  (template-print sexp (grammar-write-tab grm)) )
85
86; supplies module based struct tag & other identifiers
87(define-record grammar name reader read-tab writer write-tab)
88(define-record-type grammar
89  (make-grammar name reader read-tab writer write-tab)
90  grammar?
91  (name grammar-name grammar-name-set!)
92  (reader grammar-reader grammar-reader-set!)
93  (read-tab grammar-read-tab grammar-read-tab-set!)
94  (writer grammar-writer grammar-writer-set!)
95  (write-tab grammar-write-tab grammar-write-tab-set!) )
96
97(define (grammar-copy! grm1 grm2 #!key name reader read-tab writer write-tab)
98  (grammar-name-set! grm1 (or name (grammar-name grm2)))
99  (grammar-reader-set! grm1 (or reader (grammar-reader grm2)))
100  (grammar-read-tab-set! grm1 (or read-tab (grammar-read-tab grm2)))
101  (grammar-writer-set! grm1 (or writer (grammar-writer grm2)))
102  (grammar-write-tab-set! grm1 (or write-tab (grammar-write-tab grm2))) )
103
104;
105(define *grammars* '())
106
107(define (defgrammar name grm)
108  (set! *grammars* (alist-update! name grm *grammars* eq?)) )
109
110(define (get-grammar name)
111  (alist-ref name *grammars* eq?) )
112
113(define (list-of-grammars)
114  (map (lambda (cell) (car cell)) *grammars*) )
115
116(define (count-of-grammars)
117  (length *grammars*) )
118
119(define (get-grammar/id id)
120  (get-grammar (grammar-id-name id)) )
121
122(define (clear-grammars)
123  (clear-grammar-ids)
124  (set! *grammar* '()) )
125
126;;
127
128;
129(define (read-sexp grm column)  ((grammar-reader grm) grm column))
130(define (write-sexp sexp grm)   ((grammar-writer grm) sexp grm))
131
132(define *tab-stop* 8)
133
134;
135(define (flush-input-whitespace port)
136  (do ((chr (peek-char port) (peek-char port))
137       (col 0 (case chr
138                ((#\space)    (+ 1 col))
139                ((#\tab)      (modulo (+ (sub1 *tab-stop*) col) *tab-stop*))
140                ((#\newline)  0)
141                (else         col))))
142      ((or (eof-object? chr)
143           (not (char-whitespace? chr)))
144       col)
145    (read-char port)))
146
147;;
148
149(define (make-delimited-parse-grammar-reader delim)
150  (lambda (grm column #!optional (port (current-input-port)))
151    (prec:parse
152      (grammar-read-tab grm)
153      delim
154      (+ column (flush-input-whitespace port))
155      port)) )
156
157(define (make-delimited-sexp-reader port delim)
158  (lambda (grm column)
159    (define temporary-grammar
160      (let ((+grammar-cache+ (make-grammar #f #f #f #f #f)))
161        (lambda (grm . args)
162          (apply grammar-copy! +grammar-cache+ grm args)
163          +grammar-cache+ ) ) )
164    (let ((grm* (temporary-grammar grm #:reader (make-delimited-parse-grammar-reader delim))))
165      ;ugly but SLIB prec kinda assumes
166      (parameterize ((current-input-port port))
167        (read-sexp grm* column) ) ) ) )
168
169;;
170
171(define (read-sexp-from-string str #!optional (grm (active-input-grammar)) (column 0))
172  (import (only (chicken port) with-input-from-string))
173  (with-input-from-string str (cut read-sexp grm column)) )
174
175;;
176
177(define *input-grammar*)
178(define *output-grammar*)
179(define *echo-grammar*)
180
181(define (active-grammar-set! input output #!optional (echo 'null))
182  (set! *input-grammar* (get-grammar input))
183  (set! *output-grammar* output)
184  (set! *echo-grammar* echo) )
185
186(define (active-grammar)
187  (values *input-grammar* *output-grammar* *echo-grammar*) )
188
189(define (active-input-grammar) (receive (i o e) (active-grammar) i))
190(define (active-output-grammar) (receive (i o e) (active-grammar) o))
191(define (active-echo-grammar) (receive (i o e) (active-grammar) e))
192
193) ;slib-prec-grammar
Note: See TracBrowser for help on using the repository browser.