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