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