scm/lily-library.scm

   1 ;;;;
   2 ;;;; lily-library.scm -- utilities
   3 ;;;;
   4 ;;;;  source file of the GNU LilyPond music typesetter
   5 ;;;;
   6 ;;;; (c) 1998--2009 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;; Han-Wen Nienhuys <hanwen@xs4all.nl>
   8
   9 ; for take, drop, take-while, list-index, and find-tail:
  10 (use-modules (srfi srfi-1))
  11
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13 ;; constants.
  14
  15 (define-public X 0)
  16 (define-public Y 1)
  17 (define-safe-public START -1)
  18 (define-safe-public STOP 1)
  19 (define-public LEFT -1)
  20 (define-public RIGHT 1)
  21 (define-public UP 1)
  22 (define-public DOWN -1)
  23 (define-public CENTER 0)
  24
  25 (define-safe-public DOUBLE-FLAT-QTS -4)
  26 (define-safe-public THREE-Q-FLAT-QTS -3)
  27 (define-safe-public FLAT-QTS -2)
  28 (define-safe-public SEMI-FLAT-QTS -1)
  29 (define-safe-public NATURAL-QTS 0)
  30 (define-safe-public SEMI-SHARP-QTS 1)
  31 (define-safe-public SHARP-QTS 2)
  32 (define-safe-public THREE-Q-SHARP-QTS 3)
  33 (define-safe-public DOUBLE-SHARP-QTS 4)
  34 (define-safe-public SEMI-TONE-QTS 2)
  35
  36 (define-safe-public DOUBLE-FLAT  -1)
  37 (define-safe-public THREE-Q-FLAT -3/4)
  38 (define-safe-public FLAT -1/2)
  39 (define-safe-public SEMI-FLAT -1/4)
  40 (define-safe-public NATURAL 0)
  41 (define-safe-public SEMI-SHARP 1/4)
  42 (define-safe-public SHARP 1/2)
  43 (define-safe-public THREE-Q-SHARP 3/4)
  44 (define-safe-public DOUBLE-SHARP 1)
  45 (define-safe-public SEMI-TONE 1/2)
  46
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;; moments
  49
  50 (define-public ZERO-MOMENT (ly:make-moment 0 1))
  51
  52 (define-public (moment-min a b)
  53   (if (ly:moment<? a b) a b))
  54
  55 (define-public (moment<=? a b)
  56   (or (equal? a b)
  57       (ly:moment<? a b)))
  58
  59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60 ;; arithmetic
  61 (define-public (average x . lst)
  62   (/ (+ x (apply + lst)) (1+ (length lst))))
  63
  64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 ;; parser <-> output hooks.
  66
  67 (define-public (collect-bookpart-for-book parser book-part)
  68   "Toplevel book-part handler"
  69   (define (add-bookpart book-part)
  70     (ly:parser-define!
  71        parser 'toplevel-bookparts
  72        (cons book-part (ly:parser-lookup parser 'toplevel-bookparts))))
  73   ;; If toplevel scores have been found before this \bookpart,
  74   ;; add them first to a dedicated bookpart
  75   (if (pair? (ly:parser-lookup parser 'toplevel-scores))
  76       (begin
  77         (add-bookpart (ly:make-book-part
  78                        (ly:parser-lookup parser 'toplevel-scores)))
  79         (ly:parser-define! parser 'toplevel-scores (list))))
  80   (add-bookpart book-part))
  81
  82 (define-public (collect-scores-for-book parser score)
  83   (ly:parser-define!
  84    parser 'toplevel-scores
  85    (cons score (ly:parser-lookup parser 'toplevel-scores))))
  86
  87 (define-public (collect-music-aux score-handler parser music)
  88   (define (music-property symbol)
  89     (let ((value (ly:music-property music symbol)))
  90       (if (not (null? value))
  91           value
  92           #f)))
  93   (cond ((music-property 'page-marker)
  94          ;; a page marker: set page break/turn permissions or label
  95          (begin
  96            (let ((label (music-property 'page-label)))
  97              (if (symbol? label)
  98                  (score-handler (ly:make-page-label-marker label))))
  99            (for-each (lambda (symbol)
 100                        (let ((permission (music-property symbol)))
 101                          (if (symbol? permission)
 102                              (score-handler
 103                               (ly:make-page-permission-marker symbol
 104                                                               (if (eqv? 'forbid permission)
 105                                                                   '()
 106                                                                   permission))))))
 107                      (list 'line-break-permission 'page-break-permission
 108                            'page-turn-permission))))
 109         ((not (music-property 'void))
 110          ;; a regular music expression: make a score with this music
 111          ;; void music is discarded
 112          (score-handler (scorify-music music parser)))))
 113
 114 (define-public (collect-music-for-book parser music)
 115   "Top-level music handler"
 116   (collect-music-aux (lambda (score)
 117                        (collect-scores-for-book parser score))
 118                      parser
 119                      music))
 120
 121 (define-public (collect-book-music-for-book parser book music)
 122   "Book music handler"
 123   (collect-music-aux (lambda (score)
 124                        (ly:book-add-score! book score))
 125                      parser
 126                      music))
 127
 128 (define-public (scorify-music music parser)
 129   "Preprocess MUSIC."
 130
 131   (for-each (lambda (func)
 132               (set! music (func music parser)))
 133             toplevel-music-functions)
 134
 135   (ly:make-score music))
 136
 137 (define (print-book-with parser book process-procedure)
 138   (let*
 139       ((paper (ly:parser-lookup parser '$defaultpaper))
 140        (layout (ly:parser-lookup parser '$defaultlayout))
 141        (count (ly:parser-lookup parser 'output-count))
 142        (base (ly:parser-output-name parser))
 143        (output-suffix (ly:parser-lookup parser 'output-suffix)) )
 144
 145     (if (string? output-suffix)
 146         (set! base (format "~a-~a" base (string-regexp-substitute
 147                                            "[^a-zA-Z0-9-]" "_" output-suffix))))
 148
 149     ;; must be careful: output-count is under user control.
 150     (if (not (integer? count))
 151         (set! count 0))
 152
 153     (if (> count 0)
 154         (set! base (format #f "~a-~a" base count)))
 155     (ly:parser-define! parser 'output-count (1+ count))
 156     (process-procedure book paper layout base)
 157     ))
 158
 159 (define-public (print-book-with-defaults parser book)
 160   (print-book-with parser book ly:book-process))
 161
 162 (define-public (print-book-with-defaults-as-systems parser book)
 163   (print-book-with parser book ly:book-process-to-systems))
 164
 165 ;;;;;;;;;;;;;;;;
 166 ;; alist
 167
 168 (define-public assoc-get ly:assoc-get)
 169
 170 (define-public (uniqued-alist alist acc)
 171   (if (null? alist) acc
 172       (if (assoc (caar alist) acc)
 173           (uniqued-alist (cdr alist) acc)
 174           (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 175
 176 (define-public (alist<? x y)
 177   (string<? (symbol->string (car x))
 178             (symbol->string (car y))))
 179
 180 (define-public (chain-assoc-get x alist-list . default)
 181   "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
 182 found."
 183
 184   (define (helper x alist-list default)
 185     (if (null? alist-list)
 186         default
 187         (let* ((handle (assoc x (car alist-list))))
 188           (if (pair? handle)
 189               (cdr handle)
 190               (helper x (cdr alist-list) default)))))
 191
 192   (helper x alist-list
 193           (if (pair? default) (car default) #f)))
 194
 195 (define (map-alist-vals func list)
 196   "map FUNC over the vals of  LIST, leaving the keys."
 197   (if (null?  list)
 198       '()
 199       (cons (cons  (caar list) (func (cdar list)))
 200             (map-alist-vals func (cdr list)))))
 201
 202 (define (map-alist-keys func list)
 203   "map FUNC over the keys of an alist LIST, leaving the vals. "
 204   (if (null?  list)
 205       '()
 206       (cons (cons (func (caar list)) (cdar list))
 207             (map-alist-keys func (cdr list)))))
 208
 209 (define-public (first-member members lst)
 210   "Return first successful MEMBER of member from MEMBERS in LST."
 211   (if (null? members)
 212       #f
 213       (let ((m (member (car members) lst)))
 214         (if m m (first-member (cdr members) lst)))))
 215
 216 (define-public (first-assoc keys lst)
 217   "Return first successful ASSOC of key from KEYS in LST."
 218   (if (null? keys)
 219       #f
 220       (let ((k (assoc (car keys) lst)))
 221         (if k k (first-assoc (cdr keys) lst)))))
 222
 223 (define-public (flatten-alist alist)
 224   (if (null? alist)
 225       '()
 226       (cons (caar alist)
 227             (cons (cdar alist)
 228                   (flatten-alist (cdr alist))))))
 229
 230 ;;;;;;;;;;;;;;;;
 231 ;; vector
 232
 233 (define-public (vector-for-each proc vec)
 234   (do
 235       ((i 0 (1+ i)))
 236       ((>= i (vector-length vec)) vec)
 237     (vector-set! vec i (proc (vector-ref vec i)))))
 238
 239 ;;;;;;;;;;;;;;;;
 240 ;; hash
 241
 242 (define-public (hash-table->alist t)
 243   (hash-fold (lambda (k v acc) (acons  k v  acc))
 244              '() t))
 245
 246 ;; todo: code dup with C++.
 247 (define-safe-public (alist->hash-table lst)
 248   "Convert alist to table"
 249   (let ((m (make-hash-table (length lst))))
 250     (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
 251     m))
 252
 253 ;;;;;;;;;;;;;;;;
 254 ;; list
 255
 256 (define (functional-or . rest)
 257   (if (pair? rest)
 258       (or (car rest)
 259            (apply functional-and (cdr rest)))
 260       #f))
 261
 262 (define (functional-and . rest)
 263   (if (pair? rest)
 264       (and (car rest)
 265            (apply functional-and (cdr rest)))
 266       #t))
 267
 268 (define (split-list lst n)
 269   "Split LST in N equal sized parts"
 270
 271   (define (helper todo acc-vector k)
 272     (if (null? todo)
 273         acc-vector
 274         (begin
 275           (if (< k 0)
 276               (set! k (+ n k)))
 277
 278           (vector-set! acc-vector k (cons (car todo) (vector-ref acc-vector k)))
 279           (helper (cdr todo) acc-vector (1- k)))))
 280
 281   (helper lst (make-vector n '()) (1- n)))
 282
 283 (define (list-element-index lst x)
 284   (define (helper todo k)
 285     (cond
 286      ((null? todo) #f)
 287      ((equal? (car todo) x) k)
 288      (else
 289       (helper (cdr todo) (1+ k)))))
 290
 291   (helper lst 0))
 292
 293 (define-public (count-list lst)
 294   "Given lst (E1 E2 .. ) return ((E1 . 1) (E2 . 2) ... )  "
 295
 296   (define (helper l acc count)
 297     (if (pair? l)
 298         (helper (cdr l) (cons (cons (car l) count) acc) (1+ count))
 299         acc))
 300
 301
 302   (reverse (helper lst '() 1)))
 303
 304 (define-public (list-join lst intermediate)
 305   "put INTERMEDIATE  between all elts of LST."
 306
 307   (fold-right
 308    (lambda (elem prev)
 309             (if (pair? prev)
 310                 (cons  elem (cons intermediate prev))
 311                 (list elem)))
 312           '() lst))
 313
 314 (define-public (filtered-map proc lst)
 315   (filter
 316    (lambda (x) x)
 317    (map proc lst)))
 318
 319
 320 (define (flatten-list lst)
 321   "Unnest LST"
 322   (if (null? lst)
 323       '()
 324       (if (pair? (car lst))
 325           (append (flatten-list (car lst)) (flatten-list  (cdr lst)))
 326           (cons (car lst) (flatten-list (cdr lst))))))
 327
 328 (define (list-minus a b)
 329   "Return list of elements in A that are not in B."
 330   (lset-difference eq? a b))
 331
 332 (define-public (uniq-list lst)
 333   "Uniq LST, assuming that it is sorted. Uses equal? for comparisons."
 334
 335   (reverse!
 336    (fold (lambda (x acc)
 337            (if (null? acc)
 338                (list x)
 339                (if (equal? x (car acc))
 340                    acc
 341                    (cons x acc))))
 342          '() lst) '()))
 343
 344 (define (split-at-predicate pred lst)
 345   "Split LST into two lists at the first element that returns #f for
 346   (PRED previous_element element). Return the two parts as a pair.
 347   Example: (split-at-predicate < '(1 2 3 2 1)) ==> ((1 2 3) . (2 1))"
 348   (if (null? lst)
 349       (list lst)
 350       (let ((i (list-index pred (cdr lst) lst)))
 351         (if i
 352             (cons (take lst (1+ i)) (drop lst (1+ i)))
 353             (list lst)))))
 354
 355 (define-public (split-list-by-separator lst pred)
 356   "Split LST at each element that satisfies PRED, and return the parts
 357   (with the separators removed) as a list of lists. Example:
 358   (split-list-by-separator '(a 0 b c 1 d) number?) ==> ((a) (b c) (d))"
 359   (let loop ((result '()) (lst lst))
 360     (if (and lst (not (null? lst)))
 361         (loop
 362           (append result
 363                   (list (take-while (lambda (x) (not (pred x))) lst)))
 364           (let ((tail (find-tail pred lst)))
 365             (if tail (cdr tail) #f)))
 366        result)))
 367
 368 (define-public (offset-add a b)
 369   (cons (+ (car a) (car b))
 370         (+ (cdr a) (cdr b))))
 371
 372 (define-public (offset-flip-y o)
 373   (cons (car o) (- (cdr o))))
 374
 375 (define-public (offset-scale o scale)
 376   (cons (* (car o) scale)
 377         (* (cdr o) scale)))
 378
 379 (define-public (ly:list->offsets accum coords)
 380   (if (null? coords)
 381       accum
 382       (cons (cons (car coords) (cadr coords))
 383             (ly:list->offsets accum (cddr coords)))))
 384
 385 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 386 ;; numbers
 387
 388 (if (not (defined? 'nan?)) ;; guile 1.6 compat
 389     (define-public (nan? x) (not (or (< 0.0 x)
 390                                      (> 0.0 x)
 391                                      (= 0.0 x)))))
 392
 393 (if (not (defined? 'inf?))
 394     (define-public (inf? x) (= (/ 1.0 x) 0.0)))
 395
 396 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 397 ;; intervals
 398
 399 (define-public empty-interval '(+inf.0 . -inf.0))
 400
 401 (define-public (symmetric-interval expr)
 402   (cons (- expr) expr))
 403
 404 (define-public (interval-length x)
 405   "Length of the number-pair X, when an interval"
 406   (max 0 (- (cdr x) (car x))))
 407
 408 (define-public interval-start car)
 409 (define-public (ordered-cons a b)
 410   (cons (min a b)
 411         (max a b)))
 412
 413 (define-public interval-end cdr)
 414
 415 (define-public (interval-bound interval dir)
 416   ((if (= dir RIGHT) cdr car) interval))
 417
 418 (define-public (interval-index interval dir)
 419   "Interpolate INTERVAL between between left (DIR=-1) and right (DIR=+1)"
 420
 421   (* (+  (interval-start interval) (interval-end interval)
 422          (* dir (- (interval-end interval) (interval-start interval))))
 423      0.5))
 424
 425 (define-public (interval-center x)
 426   "Center the number-pair X, when an interval"
 427   (if (interval-empty? x)
 428       0.0
 429       (/ (+ (car x) (cdr x)) 2)))
 430
 431 (define-public interval-start car)
 432 (define-public interval-end cdr)
 433 (define-public (interval-translate iv amount)
 434   (cons (+ amount (car iv))
 435         (+ amount (cdr iv))))
 436
 437 (define (other-axis a)
 438   (remainder (+ a 1) 2))
 439
 440 (define-public (interval-widen iv amount)
 441    (cons (- (car iv) amount)
 442          (+ (cdr iv) amount)))
 443
 444
 445 (define-public (interval-empty? iv)
 446    (> (car iv) (cdr iv)))
 447
 448 (define-public (interval-union i1 i2)
 449    (cons (min (car i1) (car i2))
 450          (max (cdr i1) (cdr i2))))
 451
 452 (define-public (interval-sane? i)
 453   (not (or  (nan? (car i))
 454             (inf? (car i))
 455             (nan? (cdr i))
 456             (inf? (cdr i))
 457             (> (car i) (cdr i)))))
 458
 459 (define-public (add-point interval p)
 460   (cons (min (interval-start interval) p)
 461         (max (interval-end interval) p)))
 462
 463
 464 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 465 ;; string
 466
 467 (define-public (string-endswith s suffix)
 468   (equal? suffix (substring s
 469                             (max 0 (- (string-length s) (string-length suffix)))
 470                             (string-length s))))
 471
 472 (define-public (string-startswith s prefix)
 473   (equal? prefix (substring s 0 (min (string-length s) (string-length prefix)))))
 474
 475 (define-public (string-encode-integer i)
 476   (cond
 477    ((= i  0) "o")
 478    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 479    (else (string-append
 480           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 481           (string-encode-integer (quotient i 26))))))
 482
 483 (define (number->octal-string x)
 484   (let* ((n (inexact->exact x))
 485          (n64 (quotient n 64))
 486          (n8 (quotient (- n (* n64 64)) 8)))
 487     (string-append
 488      (number->string n64)
 489      (number->string n8)
 490      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 491
 492 (define-public (ly:inexact->string x radix)
 493   (let ((n (inexact->exact x)))
 494     (number->string n radix)))
 495
 496 (define-public (ly:number-pair->string c)
 497   (string-append (ly:number->string (car c)) " "
 498                  (ly:number->string (cdr c))))
 499
 500 (define-public (dir-basename file . rest)
 501   "Strip suffixes in REST, but leave directory component for FILE."
 502   (define (inverse-basename x y) (basename y x))
 503   (simple-format #f "~a/~a" (dirname file)
 504                  (fold inverse-basename file rest)))
 505
 506 (define-public (write-me message x)
 507   "Return X.  Display MESSAGE and write X.  Handy for debugging,
 508 possibly turned off."
 509   (display message) (write x) (newline) x)
 510 ;;  x)
 511
 512 (define-public (stderr string . rest)
 513   (apply format (cons (current-error-port) (cons string rest)))
 514   (force-output (current-error-port)))
 515
 516 (define-public (debugf string . rest)
 517   (if #f
 518       (apply stderr (cons string rest))))
 519
 520 (define (index-cell cell dir)
 521   (if (equal? dir 1)
 522       (cdr cell)
 523       (car cell)))
 524
 525 (define (cons-map f x)
 526   "map F to contents of X"
 527   (cons (f (car x)) (f (cdr x))))
 528
 529 (define-public (list-insert-separator lst between)
 530   "Create new list, inserting BETWEEN between elements of LIST"
 531   (define (conc x y )
 532     (if (eq? y #f)
 533         (list x)
 534         (cons x  (cons between y))))
 535   (fold-right conc #f lst))
 536
 537 (define-public (string-regexp-substitute a b str)
 538   (regexp-substitute/global #f a str 'pre b 'post))
 539
 540 (define (regexp-split str regex)
 541   (define matches '())
 542   (define end-of-prev-match 0)
 543   (define (notice match)
 544
 545     (set! matches (cons (substring (match:string match)
 546                                    end-of-prev-match
 547                                    (match:start match))
 548                         matches))
 549     (set! end-of-prev-match (match:end match)))
 550
 551   (regexp-substitute/global #f regex str notice 'post)
 552
 553   (if (< end-of-prev-match (string-length str))
 554       (set!
 555        matches
 556        (cons (substring str end-of-prev-match (string-length str)) matches)))
 557
 558    (reverse matches))
 559
 560 ;;;;;;;;;;;;;;;;
 561 ;; other
 562
 563 (define (sign x)
 564   (if (= x 0)
 565       0
 566       (if (< x 0) -1 1)))
 567
 568 (define-public (binary-search start end getter target-val)
 569   (_i "Find the index between @var{start} and @var{end} (an integer)
 570 which will produce the closest match to @var{target-val} when
 571 applied to function @var{getter}.")
 572   (if (<= end start)
 573       start
 574       (let* ((compare (quotient (+ start end) 2))
 575              (get-val (getter compare)))
 576         (cond
 577          ((< target-val get-val)
 578           (set! end (1- compare)))
 579          ((< get-val target-val)
 580           (set! start (1+ compare))))
 581         (binary-search start end getter target-val))))
 582
 583 (define-public (car< a b)
 584   (< (car a) (car b)))
 585
 586 (define-public (symbol<? lst r)
 587   (string<? (symbol->string lst) (symbol->string r)))
 588
 589 (define-public (symbol-key<? lst r)
 590   (string<? (symbol->string (car lst)) (symbol->string (car r))))
 591
 592 ;;
 593 ;; don't confuse users with #<procedure .. > syntax.
 594 ;;
 595 (define-public (scm->string val)
 596   (if (and (procedure? val)
 597            (symbol? (procedure-name val)))
 598       (symbol->string (procedure-name val))
 599       (string-append
 600        (if (self-evaluating? val)
 601            (if (string? val)
 602                "\""
 603                "")
 604            "'")
 605        (call-with-output-string (lambda (port) (display val port)))
 606        (if (string? val)
 607            "\""
 608            ""))))
 609
 610 (define-public (!= lst r)
 611   (not (= lst r)))
 612
 613 (define-public lily-unit->bigpoint-factor
 614   (cond
 615    ((equal? (ly:unit) "mm") (/ 72.0 25.4))
 616    ((equal? (ly:unit) "pt") (/ 72.0 72.27))
 617    (else (ly:error (_ "unknown unit: ~S") (ly:unit)))))
 618
 619 (define-public lily-unit->mm-factor
 620   (* 25.4 (/ lily-unit->bigpoint-factor 72)))
 621
 622 ;;; FONT may be font smob, or pango font string...
 623 (define-public (font-name-style font)
 624   ;; FIXME: ughr, barf: feta-alphabet is actually emmentaler
 625   (if (and (string? font)
 626            (string-prefix? "feta-alphabet" font))
 627       (string-append "emmentaler"
 628                      "-"
 629                      (substring font
 630                                 (string-length "feta-alphabet")
 631                                 (string-length font)))
 632       (let* ((font-name (ly:font-name font))
 633              (full-name (if font-name font-name (ly:font-file-name font))))
 634         (if (string-prefix? "Aybabtu" full-name)
 635             "aybabtu"
 636             (string-downcase full-name)))))
 637
 638 (define-public (modified-font-metric-font-scaling font)
 639   (let* ((designsize (ly:font-design-size font))
 640          (magnification (* (ly:font-magnification font)))
 641          (scaling (* magnification designsize)))
 642     (debugf "scaling:~S\n" scaling)
 643     (debugf "magnification:~S\n" magnification)
 644     (debugf "design:~S\n" designsize)
 645     scaling))
 646
 647 (define-public (version-not-seen-message input-file-name)
 648   (ly:message
 649    "~a:0: ~a ~a"
 650     input-file-name
 651     (_ "warning:")
 652     (format #f
 653             (_ "no \\version statement found, please add~afor future compatibility")
 654             (format #f "\n\n\\version ~s\n\n" (lilypond-version)))))
 655
 656 (define-public (old-relative-not-used-message input-file-name)
 657   (ly:message
 658    "~a:0: ~a ~a"
 659     input-file-name
 660     (_ "warning:")
 661     (_ "old relative compatibility not used")))