1 ;;; module/nyacc/util.scm
3 ;;; Copyright (C) 2015 Matthew R. Wette
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.
9 ;; runtime utilities for the parsers -- needs work
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
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
24 #:use-module ((srfi srfi-1) #:select(find))
30 (use-modules (ice-9 optargs))
31 (use-modules (ice-9 syncase)))
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
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.")
42 (define (fmterr fmt . args)
43 (apply simple-format (current-error-port) fmt args))
45 ;; === input stack =====================
47 (define *input-stack* (make-fluid '()))
49 (define (reset-input-stack)
50 (fluid-set! *input-stack* '()))
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)))
60 (let ((ipstk (fluid-ref *input-stack*)))
63 (set-current-input-port (car ipstk))
64 (fluid-set! *input-stack* (cdr ipstk))))))
66 ;; It may be possible to reimplement with closures, using soft-ports.
67 ;; (push-string-input ...
70 (define (push-string-input str)
71 (let* ((prev (current-input-port))
72 (port (make-soft-port ...))
77 ;; === tl ==============================
79 ;; @section Tagged Lists
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.
85 ;; tl => '(H . T), H => (c a b 'tag); T =>
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)))))
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
101 ;; (<tag> (@ <attr>) <rest>)
103 (define (tl->list tl)
104 (let ((heda (car tl))
105 (head (let iter ((head '()) (attr '()) (tl-head (car tl)))
108 (cons (cons '@ attr) (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)))
115 (iter (cons (car tl-tail) tail) (cdr tl-tail))
116 (cons tl-tail (append head tail))))))
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)))
123 ;; @deffn tl-append tl item ...
124 ;; Append item at end of tagged list.
125 (define (tl-append tl . rest)
127 (let iter ((tail (cdr tl)) (items rest))
128 (if (null? items) tail
129 (iter (cons (car items) tail) (cdr items))))))
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))
136 ;; @deffn tl+attr tl key val)
137 ;; Add an attribute to a tagged list. Return the tl.
139 ;; (tl+attr tl 'type "int")
141 (define (tl+attr tl key val)
142 (tl-insert tl (cons '@ (list key val))))
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)")
150 ;; === sx ==============================
151 ;; @section SXML Utility Procedures
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}.
157 ;; (sx-ref '(abc "def") 1) => "def"
158 ;; (sx-ref '(abc (@ (foo "1")) "def") 1) => "def"
160 (define (sx-ref sx ix)
161 (define (list-xref l x) (if (> (length l) x) (list-ref l x) #f))
163 ((zero? ix) (car sx))
164 ((and (pair? (cadr sx)) (eqv? '@ (caadr sx)))
165 (list-xref sx (1+ ix)))
169 ;; @deffn sx-tag sx => tag
170 ;; Return the tag for a tree
172 (if (pair? sx) (car sx) #f))
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)))
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)))))
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))))
191 ;; @deffn sx-attr sx => '(@ ...)|#f
193 ;; (sx-attr '(abc (@ (foo "1")) def) 1) => '(@ (foo "1"))
196 (if (and (pair? (cdr sx)) (pair? (cadr sx)))
197 (if (eqv? '@ (caadr sx))
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)
207 (and=> (assq-ref (cdr attr) key) car))))
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))))
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))
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))))))
228 ;; @deffn sx-find tag sx => ((tag ...) (tag ...))
229 ;; Find the first matching element (in the first level).
230 (define (sx-find tag sx)
232 (and (pair? node) (eqv? tag (car node))))
235 ;;; === pp ==========================
236 ;; @section Pretty-Print and Other Utility Procedures
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
247 ;; (protect-expr? 'lval '+ '(mul ...)) => TBD
249 (define (make-protect-expr op-prec op-assc)
251 (define (assc-lt? op)
252 (memq op (assq-ref op-assc 'left)))
254 (define (assc-rt? op)
255 (memq op (assq-ref op-assc 'right)))
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).
261 (let iter ((ag #f) (bg #f) (opg op-prec)) ;; a-group, b-group
263 ((null? opg) #f) ; indeterminate
266 (if (memq b (car opg)) '=
267 (iter #t bg (cdr opg)))))
270 (if (memq a (car opg)) '=
271 (iter ag #t (cdr opg)))))
273 (iter ag bg (cdr opg))))))
275 (lambda (side op expr)
276 (let ((assc? (case side
278 ((rt right) assc-lt?)))
286 ;; @deffn make-pp-formatter => fmtr
288 ;; (fmtr 'push) ;; push indent level
289 ;; (fmtr 'pop) ;; pop indent level
290 ;; (fmtr "fmt" arg1 arg2 ...)
292 (define* (make-pp-formatter)
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)))
306 (set! ind-lev (min maxind (1+ ind-lev)))
307 (set! ind-len (* 2 ind-lev))))
311 (set! ind-lev (max 0 (1- ind-lev)))
312 (set! ind-len (* 2 ind-lev))))
316 (let* ((str (apply simple-format #f fmt args))
317 (len (string-length str)))
320 (set! column (+ column ind-len)))
321 (when (> (+ column len) maxcol)
324 (set! column (+ column ind-len 4)))
326 (when (and (positive? len)
327 (eqv? #\newline (string-ref str (1- len))))
330 (lambda (arg0 . rest)
332 ((string? arg0) (apply sf arg0 rest))
333 ((eqv? 'push arg0) (push-il))
334 ((eqv? 'pop arg0) (pop-il))
335 ((eqv? 'nlin arg0) ;; newline if needed
336 (cond ((positive? column) (newline) (set! column 0))))
337 (else (error "pp-formatter: bad args"))
340 ;; @deffn make-pp-formatter/ugly => fmtr
341 ;; Makes a @code{fmtr} like @code{make-pp-formatter} but no indentation
342 ;; and just adds strings on ...
343 (define* (make-pp-formatter/ugly)
347 (sf (lambda (fmt . args)
348 (let* ((str (apply simple-format #f fmt args))
349 (len (string-length str)))
351 ((char=? #\# (string-ref str 0))
354 (when (> (+ column len) maxcol)
357 (if (char=? #\newline (string-ref str (1- len)))
358 (string-set! str (1- len) #\space))
360 (set! column (+ column len))))))))
362 (lambda (arg0 . rest)
364 ((string? arg0) (apply sf arg0 rest))
365 ((eqv? 'nlin arg0) ;; newline if needed
366 (cond ((positive? column) (newline) (set! column 0))))
367 ((eqv? 'push arg0) #f)
368 ((eqv? 'pop arg0) #f)
369 (else (error "pp-formatter/ugly: bad args"))))))
371 ;; @deffn move-if-changed src-file dst-file [sav-file]
372 ;; Return @code{#t} if changed.
373 (define (move-if-changed src-file dst-file . rest)
376 (let ((sav-file (if (pair? rest) (car rest) #f)))
377 (if (and sav-file (access? sav-file W_OK))
378 (system (simple-format #f "mv ~A ~A" dst-file sav-file)))
379 (system (simple-format #f "mv ~A ~A" src-file dst-file))
383 ;; src-file does not exist
384 ((not (access? src-file R_OK)) #f)
386 ;; dst-file does not exist, update anyhow
387 ((not (access? dst-file F_OK))
388 (system (simple-format #f "mv ~A ~A" src-file dst-file)) #t)
390 ;; both exist, but no changes
392 (simple-format #f "cmp ~A ~A >/dev/null" src-file dst-file)))
393 (system (simple-format #f "rm ~A" src-file)) #f)
395 ;; both exist, update
396 ((access? dst-file W_OK)
400 (simple-format (current-error-port) "move-if-changed: no write access\n")
405 ;;; --- last line ---