Import Nyacc 0.72.0.
[mes.git] / module / nyacc / lang / util.scm
1 ;;; module/nyacc/util.scm
2 ;;;
3 ;;; Copyright (C) 2015 Matthew R. Wette
4 ;;;
5 ;;; This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
6 ;;; or any later version published by the Free Software Foundation.  See the
7 ;;; file COPYING included with the nyacc distribution.
8
9 ;; runtime utilities for the parsers -- needs work
10
11 (define-module (nyacc lang util)
12   #:export (lang-crn-lic
13             push-input pop-input reset-input-stack
14             make-tl tl->list ;; rename?? to tl->sx for sxml-expr
15             tl-append tl-insert tl-extend tl+attr
16             sx-tag
17             sx-attr sx-attr-ref sx-has-attr? sx-set-attr! sx-set-attr*
18             sx-ref sx-tail sx-find
19             ;; for pretty-printing
20             make-protect-expr make-pp-formatter make-pp-formatter/ugly
21             ;; for ???
22             move-if-changed
23             fmterr)
24   #:use-module ((srfi srfi-1) #:select(find))
25   )
26
27 ;; This is a generic copyright/licence that will be printed in the output
28 ;; of the examples/nyacc/lang/*/ actions.scm and tables.scm files.
29 (define lang-crn-lic "Copyright (C) 2015,2016 Matthew R. Wette
30
31 This software is covered by the GNU GENERAL PUBLIC LICENCE, Version 3,
32 or any later version published by the Free Software Foundation.  See the
33 file COPYING included with the this distribution.")
34
35 (define (fmterr fmt . args)
36   (apply simple-format (current-error-port) fmt args))
37
38 ;; === input stack =====================
39
40 (define *input-stack* (make-fluid '()))
41
42 (define (reset-input-stack)
43   (fluid-set! *input-stack* '()))
44
45 (define (push-input port)
46   (let ((curr (current-input-port))
47         (ipstk (fluid-ref *input-stack*)))
48     (fluid-set! *input-stack* (cons curr ipstk))
49     (set-current-input-port port)))
50
51 ;; Return #f if empty
52 (define (pop-input)
53   (let ((ipstk (fluid-ref *input-stack*)))
54     (if (null? ipstk) #f
55         (begin
56           (set-current-input-port (car ipstk))
57           (fluid-set! *input-stack* (cdr ipstk))))))
58
59 ;; It may be possible to reimplement with closures, using soft-ports.
60 ;; (push-string-input ...
61
62 #|
63 (define (push-string-input str)
64   (let* ((prev (current-input-port))
65          (port (make-soft-port ...))
66          )
67     #f))
68 |#
69
70 ;; === tl ==============================
71
72 ;; @section Tagged Lists
73 ;; Tagged lists are
74 ;; They are implemented as a cons cell with the car and the cdr a list.
75 ;; The cdr is used to accumulate appended items and the car is used to
76 ;; keep the tag, attributes and inserted items.
77 ;; @example
78 ;; tl => '(H . T), H => (c a b 'tag); T =>
79 ;; @end example
80
81 ;; @table code
82
83 ;; @deffn make-tl tag [item item ...]
84 ;; Create a tagged-list structure.
85 (define (make-tl tag . rest)
86   (let iter ((tail tag) (l rest))
87     (if (null? l) (cons '() tail)
88         (iter (cons (car l) tail) (cdr l)))))
89
90 ;; @deffn tl->list tl
91 ;; Convert a tagged list structure to a list.  This collects added attributes
92 ;; and puts them right after the (leading) tag, resulting in something like
93 ;; @example
94 ;; (<tag> (@ <attr>) <rest>)
95 ;; @end example
96 (define (tl->list tl)
97   (let ((heda (car tl))
98         (head (let iter ((head '()) (attr '()) (tl-head (car tl)))
99                 (if (null? tl-head)
100                     (if (pair? attr)
101                         (cons (cons '@ attr) (reverse head))
102                         (reverse head))
103                     (if (and (pair? (car tl-head)) (eq? '@ (caar tl-head)))
104                         (iter head (cons (cdar tl-head) attr) (cdr tl-head))
105                         (iter (cons (car tl-head) head) attr (cdr tl-head)))))))
106     (let iter ((tail '()) (tl-tail (cdr tl)))
107       (if (pair? tl-tail)
108           (iter (cons (car tl-tail) tail) (cdr tl-tail))
109           (cons tl-tail (append head tail))))))
110
111 ;; @deffn tl-insert tl item
112 ;; Insert item at front of tagged list (but after tag).
113 (define (tl-insert tl item)
114   (cons (cons item (car tl)) (cdr tl)))
115
116 ;; @deffn tl-append tl item ...
117 ;; Append item at end of tagged list.
118 (define (tl-append tl . rest)
119   (cons (car tl)
120         (let iter ((tail (cdr tl)) (items rest))
121           (if (null? items) tail
122               (iter (cons (car items) tail) (cdr items))))))
123
124 ;; @deffn tl-extend tl item-l
125 ;; Extend with a list of items.
126 (define (tl-extend tl item-l)
127   (apply tl-append tl item-l))
128
129 ;; @deffn tl+attr tl key val)
130 ;; Add an attribute to a tagged list.  Return the tl.
131 ;; @example
132 ;; (tl+attr tl 'type "int")
133 ;; @end example
134 (define (tl+attr tl key val)
135   (tl-insert tl (cons '@ (list key val))))
136
137 ;; @deffn tl-merge tl tl1
138 ;; Merge guts of phony-tl @code{tl1} into @code{tl}.
139 (define (tl-merge tl tl1)
140   (error "not implemented (yet)")
141   )
142
143 ;; === sx ==============================
144 ;; @section SXML Utility Procedures
145
146 ;; @deffn sx-ref sx ix => item
147 ;; Reference the @code{ix}-th element of the list, not counting the optional
148 ;; attributes item.  If the list is shorter than the index, return @code{#f}.
149 ;; @example
150 ;; (sx-ref '(abc "def") 1) => "def"
151 ;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def"
152 ;; @end example
153 (define (sx-ref sx ix)
154   (define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
155   (cond
156    ((zero? ix) (car sx))
157    ((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
158     (list-xref sx (1+ ix)))
159    (else
160     (list-xref sx ix))))
161
162 ;; @deffn sx-tag sx => tag
163 ;; Return the tag for a tree
164 (define (sx-tag sx)
165   (if (pair? sx) (car sx) #f))
166
167 ;; @deffn sx-tail sx ix => (list)
168 ;; Return the tail starting at the ix-th cdr, starting from 0.
169 ;; For example, if sx has 3 items then (sx-tail sx 2) returns '().
170 ;; BUG: not working for (sx '(foo) 1)
171 (define (sx-tail sx ix)
172   (if (zero? ix) (error "zero index not supported"))
173   (let ((sx (cdr sx)) (ix (1- ix)))
174     (cond
175      ((and (null? sx) (zero? ix)) sx)
176      ((and (pair? (car sx)) (eqv? '@ (caar sx))) (list-tail sx (1+ ix)))
177      (else (list-tail sx ix)))))
178
179 ;; @deffn sx-has-attr? sx
180 ;; p to determine if @arg{sx} has attributes.
181 (define (sx-has-attr? sx)
182   (and (pair? (cdr sx)) (pair? (cadr sx)) (eqv? '@ (caadr sx))))
183
184 ;; @deffn sx-attr sx => '(@ ...)|#f
185 ;; @example
186 ;; (sx-attr '(abc (@ (foo "1")) def) 1) => '(@ (foo "1"))
187 ;; @end example
188 (define (sx-attr sx)
189   (if (and (pair? (cdr sx)) (pair? (cadr sx)))
190       (if (eqv? '@ (caadr sx))
191           (cadr sx)
192           #f)
193       #f))
194
195 ;; @deffn sx-attr-ref sx key => val
196 ;; Return an attribute value given the key, or @code{#f}.
197 (define (sx-attr-ref sx key)
198   (and=> (sx-attr sx)
199          (lambda (attr)
200            (and=> (assq-ref (cdr attr) key) car))))
201
202 ;; @deffn sx-set-attr! sx key val
203 ;; Set attribute for sx.  If no attributes exist, if key does not exist,
204 ;; add it, if it does exist, replace it.
205 (define (sx-set-attr! sx key val . rest)
206   (if (sx-has-attr? sx)
207       (let ((attr (cadr sx)))
208         (set-cdr! attr (assoc-set! (cdr attr) key (list val))))
209       (set-cdr! sx (cons `(@ (,key ,val)) (cdr sx))))
210   sx)
211
212 ;; @deffn sx-set-attr* sx key val [key val [key ... ]]
213 ;; Set attribute for sx.  If no attributes exist, if key does not exist,
214 ;; add it, if it does exist, replace it.
215 (define (sx-set-attr* sx . rest)
216   (let iter ((attr (or (and=> (sx-attr sx) cdr) '())) (kvl rest))
217     (cond
218      ((null? kvl) (cons* (sx-tag sx) (cons '@ (reverse attr)) (sx-tail sx 1)))
219      (else (iter (cons (list (car kvl) (cadr kvl)) attr) (cddr kvl))))))
220       
221 ;; @deffn sx-find tag sx => ((tag ...) (tag ...))
222 ;; Find the first matching element (in the first level).
223 (define (sx-find tag sx)
224   (find (lambda (node)
225             (and (pair? node) (eqv? tag (car node))))
226         sx))
227
228 ;;; === pp ==========================
229 ;; @section Pretty-Print and Other Utility Procedures
230
231 ;; @deffn make-protect-expr op-prec op-assc => side op expr => #t|#f
232 ;; Generate procedure @code{protect-expr} for pretty-printers, which takes
233 ;; the form @code{(protect-expr? side op expr)} and where @code{side}
234 ;; is @code{'lval} or @code{'rval}, @code{op} is the operator and @code{expr}
235 ;; is the expression.  The argument @arg{op-prec} is a list of equivalent
236 ;; operators in order of decreasing precedence and @arg{op-assc} is an
237 ;; a-list of precedence with keys @code{'left}, @code{'right} and
238 ;; @code{nonassoc}.
239 ;; @example
240 ;; (protect-expr? 'lval '+ '(mul ...)) => TBD
241 ;; @end example
242 (define (make-protect-expr op-prec op-assc)
243
244   (define (assc-lt? op)
245     (memq op (assq-ref op-assc 'left)))
246
247   (define (assc-rt? op)
248     (memq op (assq-ref op-assc 'right)))
249
250   ;; @deffn prec a b => '>|'<|'=|#f
251   ;; Returns the prececence relation of @code{a}, @code{b} as
252   ;; @code{<}, @code{>}, @code{=} or @code{#f} (no relation).
253   (define (prec a b)
254     (let iter ((ag #f) (bg #f) (opg op-prec)) ;; a-group, b-group
255       (cond
256        ((null? opg) #f)                 ; indeterminate
257        ((memq a (car opg))
258         (if bg '<
259             (if (memq b (car opg)) '=
260                 (iter #t bg (cdr opg)))))
261        ((memq b (car opg))
262         (if ag '>
263             (if (memq a (car opg)) '=
264                 (iter ag #t (cdr opg)))))
265        (else
266         (iter ag bg (cdr opg))))))
267
268   (lambda (side op expr)
269     (let ((assc? (case side
270                    ((lt left) assc-rt?)
271                    ((rt right) assc-lt?)))
272           (vtag (car expr)))
273       (case (prec op vtag)
274         ((>) #t)
275         ((<) #f)
276         ((=) (assc? op))
277         (else #f)))))
278
279 ;; @deffn make-pp-formatter => fmtr
280 ;; @example
281 ;; (fmtr 'push) ;; push indent level
282 ;; (fmtr 'pop)  ;; pop indent level
283 ;; (fmtr "fmt" arg1 arg2 ...)
284 ;; @end example
285 (define* (make-pp-formatter)
286   (letrec
287       ((maxcol 78)
288        (maxind 36)
289        (column 0)
290        (ind-lev 0)
291        (ind-len 0)
292        (blanks "                                            ")
293        (ind-str (lambda () (substring blanks 0 ind-len)))
294        (cnt-str (lambda () (substring blanks 0 (+ 4 ind-len))))
295        ;;(sf-nl (lambda () (newline) (set! column 0)))
296
297        (push-il
298         (lambda ()
299           (set! ind-lev (min maxind (1+ ind-lev)))
300           (set! ind-len (* 2 ind-lev))))
301
302        (pop-il
303         (lambda ()
304           (set! ind-lev (max 0 (1- ind-lev)))
305           (set! ind-len (* 2 ind-lev))))
306        
307        (sf
308         (lambda (fmt . args)
309           (let* ((str (apply simple-format #f fmt args))
310                  (len (string-length str)))
311             (when (zero? column)
312               (display (ind-str))
313               (set! column (+ column ind-len)))
314             (when (> (+ column len) maxcol)
315               (newline)
316               (display (cnt-str))
317               (set! column (+ column ind-len 4)))
318             (display str)
319             (when (and (positive? len)
320                        (eqv? #\newline (string-ref str (1- len))))
321               (set! column 0))))))
322
323     (lambda (arg0 . rest)
324       (cond
325        ((string? arg0) (apply sf arg0 rest))
326        ((eqv? 'push arg0) (push-il))
327        ((eqv? 'pop arg0) (pop-il))
328        ((eqv? 'nlin arg0) ;; newline if needed
329         (cond ((positive? column) (newline) (set! column 0))))
330        (else (error "pp-formatter: bad args"))
331        ))))
332
333 ;; @deffn make-pp-formatter/ugly => fmtr
334 ;; Makes a @code{fmtr} like @code{make-pp-formatter} but no indentation
335 ;; and just adds strings on ...
336 (define* (make-pp-formatter/ugly)
337   (let*
338       ((maxcol 78)
339        (column 0)
340        (sf (lambda (fmt . args)
341              (let* ((str (apply simple-format #f fmt args))
342                     (len (string-length str)))
343                (cond
344                 ((char=? #\# (string-ref str 0))
345                  (display str))
346                 (else
347                  (when (> (+ column len) maxcol)
348                    (newline)
349                    (set! column 0))
350                  (if (char=? #\newline (string-ref str (1- len)))
351                      (string-set! str (1- len) #\space))
352                  (display str)
353                  (set! column (+ column len))))))))
354
355     (lambda (arg0 . rest)
356       (cond
357        ((string? arg0) (apply sf arg0 rest))
358        ((eqv? 'nlin arg0) ;; newline if needed
359         (cond ((positive? column) (newline) (set! column 0))))
360        ((eqv? 'push arg0) #f)
361        ((eqv? 'pop arg0) #f)
362        (else (error "pp-formatter/ugly: bad args"))))))
363   
364 ;; @deffn move-if-changed src-file dst-file [sav-file]
365 ;; Return @code{#t} if changed.
366 (define (move-if-changed src-file dst-file . rest)
367
368   (define (doit)
369     (let ((sav-file (if (pair? rest) (car rest) #f)))
370       (if (and sav-file (access? sav-file W_OK))
371           (system (simple-format #f "mv ~A ~A" dst-file sav-file)))
372       (system (simple-format #f "mv ~A ~A" src-file dst-file))
373       #t))
374     
375   (cond
376    ;; src-file does not exist
377    ((not (access? src-file R_OK)) #f)
378
379    ;; dst-file does not exist, update anyhow
380    ((not (access? dst-file F_OK))
381     (system (simple-format #f "mv ~A ~A" src-file dst-file)) #t)
382
383    ;; both exist, but no changes
384    ((zero? (system
385             (simple-format #f "cmp ~A ~A >/dev/null" src-file dst-file)))
386     (system (simple-format #f "rm ~A" src-file)) #f)
387
388    ;; both exist, update
389    ((access? dst-file W_OK)
390     (doit))
391    
392    (else
393     (simple-format (current-error-port) "move-if-changed: no write access\n")
394     #f)))
395
396 ;; @end table
397
398 ;;; --- last line ---