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

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

use slib prec include, use slib simetrix, combine *-setups

File size: 3.3 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  #;
32  (template-print sexp (grammar-write-tab grm)))
33
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;
91(define (make-grm-parse-reader delim #!optional (port (current-input-port)))
92  (lambda (grm column)
93    (prec:parse
94      (grammar-read-tab grm)
95      delim
96      (+ column (flush-input-whitespace port))
97      port)) )
98
99(define (read-sexp/delim grm delim port)
100  (unless (grammar? grm) (error 'read-sexp/delim "invalid grammar" grm))
101  (let (
102    (tmp (grammar-reader grm)) )
103    (grammar-reader-set! grm (make-grm-parse-reader delim port))
104    (let (
105      (res (read-sexp grm 0)) )
106      (grammar-reader-set! grm tmp)
107      res ) ) )
108
109;from jacal toploads.scm
110(define *input-grammar* (get-grammar 'scheme))
111(define *output-grammar* (get-grammar 'scheme))
112(define *echo-grammar* (get-grammar 'null))
113(define tran:translations '())
114;(define Language #f)
115(define math:debug #f)
116(define math:phases #f)
117(define math:trace #f)
118;(define linkradicals #f)
119(define horner #f)
120(define page-height #f)
121(define page-width #f)
122;(define newextstr #f)
123;(define newlabelstr #f)
124;(define newlabelsym #f)
125;(define % #f)
126;(define *modulus* 0)
127
128;
129(define (math:error . args) (apply slib:error 'math: args))
130(define (math:warn . args) (apply slib:warn 'math: args))
131(define (math:exit b) #;(cleanup-handlers!) (slib:error "error in math system"))
Note: See TracBrowser for help on using the repository browser.