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