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

Last change on this file since 38598 was 38598, checked in by Kon Lovett, 6 months ago

hide *output-grammar*, ... behind active-grammar

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