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             (when (zero? column)
 319               (display (ind-str))
 320               (set! column (+ column ind-len)))
 321             (when (> (+ column len) maxcol)
 322               (newline)
 323               (display (cnt-str))
 324               (set! column (+ column ind-len 4)))
 325             (display str)
 326             (when (and (positive? len)
 327                        (eqv? #\newline (string-ref str (1- len))))
 328               (set! column 0))))))
 329
 330     (lambda (arg0 . rest)
 331       (cond
 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"))
 338        ))))
 339
 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)
 344   (let*
 345       ((maxcol 78)
 346        (column 0)
 347        (sf (lambda (fmt . args)
 348              (let* ((str (apply simple-format #f fmt args))
 349                     (len (string-length str)))
 350                (cond
 351                 ((char=? #\# (string-ref str 0))
 352                  (display str))
 353                 (else
 354                  (when (> (+ column len) maxcol)
 355                    (newline)
 356                    (set! column 0))
 357                  (if (char=? #\newline (string-ref str (1- len)))
 358                      (string-set! str (1- len) #\space))
 359                  (display str)
 360                  (set! column (+ column len))))))))
 361
 362     (lambda (arg0 . rest)
 363       (cond
 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"))))))
 370
 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)
 374
 375   (define (doit)
 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))
 380       #t))
 381
 382   (cond
 383    ;; src-file does not exist
 384    ((not (access? src-file R_OK)) #f)
 385
 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)
 389
 390    ;; both exist, but no changes
 391    ((zero? (system
 392             (simple-format #f "cmp ~A ~A >/dev/null" src-file dst-file)))
 393     (system (simple-format #f "rm ~A" src-file)) #f)
 394
 395    ;; both exist, update
 396    ((access? dst-file W_OK)
 397     (doit))
 398
 399    (else
 400     (simple-format (current-error-port) "move-if-changed: no write access\n")
 401     #f)))
 402
 403 ;; @end table
 404
 405 ;;; --- last line ---