scm/lily.scm

   1 ;;;; lily.scm -- toplevel Scheme stuff
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 1998--2005 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 (if (defined? 'set-debug-cell-accesses!)
  10     (set-debug-cell-accesses! #f))
  11
  12 ;(set-debug-cell-accesses! 1000)
  13
  14 (use-modules (ice-9 regex)
  15              (ice-9 safe)
  16              (ice-9 optargs)
  17              (oop goops)
  18              (srfi srfi-1)
  19              (srfi srfi-13)
  20              (srfi srfi-14))
  21
  22
  23 ;; my display
  24 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
  25
  26 (define-public (print . args)
  27   (apply format (cons (current-output-port) args)))
  28
  29
  30 ;;; General settings
  31 ;;; debugging evaluator is slower.  This should
  32 ;;; have a more sensible default.
  33
  34 (if (ly:get-option 'verbose)
  35     (begin
  36       (debug-enable 'debug)
  37       (debug-enable 'backtrace)
  38       (read-enable 'positions)))
  39
  40 ;; initialize defaults.
  41 (ly:set-option 'command-line-settings
  42                '((resolution . 90)
  43                  (preview-include-book-title . #t)
  44                  ))
  45
  46 (define-public tex-backend?
  47   (member (ly:output-backend) '("texstr" "tex")))
  48
  49 (define-public parser #f)
  50
  51 (define-public (lilypond-version)
  52   (string-join
  53    (map (lambda (x) (if (symbol? x)
  54                         (symbol->string x)
  55                         (number->string x)))
  56         (ly:version))
  57    "."))
  58
  59
  60
  61 ;; cpp hack to get useful error message
  62 (define ifdef "First run this through cpp.")
  63 (define ifndef "First run this through cpp.")
  64
  65 ;; gettext wrapper for guile < 1.7.2
  66 (if (defined? 'gettext)
  67     (define-public _ gettext)
  68     (define-public _ ly:gettext))
  69
  70 (define-public (ly:load x)
  71   (let* ((file-name (%search-load-path x)))
  72     (if (ly:get-option 'verbose)
  73         (ly:progress "[~A" file-name))
  74     (primitive-load file-name)
  75     (if (ly:get-option 'verbose)
  76         (ly:progress "]"))))
  77
  78 (define-public TEX_STRING_HASHLIMIT 10000000)
  79
  80 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81
  82 (define (type-check-list location signature arguments)
  83   "Typecheck a list of arguments against a list of type
  84 predicates. Print a message at LOCATION if any predicate failed."
  85   (define (recursion-helper signature arguments count)
  86     (define (helper pred? arg count)
  87       (if (not (pred? arg))
  88
  89           (begin
  90             (ly:input-message
  91              location
  92              (format
  93               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
  94               count (type-name pred?) arg))
  95             #f)
  96           #t))
  97
  98     (if (null? signature)
  99         #t
 100         (and (helper (car signature) (car arguments) count)
 101              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 102   (recursion-helper signature arguments 1))
 103
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 ;;  output
 106
 107
 108 ;;(define-public (output-framework) (write "hello\n"))
 109
 110 (define output-tex-module
 111   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 112 (define output-ps-module
 113   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 114
 115 (define-public (ps-output-expression expr port)
 116   (display (eval expr output-ps-module) port))
 117
 118 ;; TODO: generate this list by registering the stencil expressions
 119 ;;       stencil expressions should have docstrings.
 120 (define-public (ly:all-stencil-expressions)
 121   "Return list of stencil expressions."
 122   '(beam
 123     bezier-sandwich
 124     blank
 125     bracket
 126     char
 127     circle
 128     dashed-line
 129     dashed-slur
 130     dot
 131     draw-line
 132     ez-ball
 133     filledbox
 134     glyph-string
 135     horizontal-line
 136     named-glyph
 137     polygon
 138     repeat-slash
 139     round-filled-box
 140     text
 141     url-link
 142     utf8-string
 143     white-dot
 144     white-text
 145     embedded-ps
 146     zigzag-line))
 147
 148 ;; TODO:
 149 ;;  - generate this list by registering the output-backend-commands
 150 ;;    output-backend-commands should have docstrings.
 151 ;;  - remove hard copies in output-ps output-tex
 152 (define-public (ly:all-output-backend-commands)
 153   "Return list of output backend commands."
 154   '(
 155     comment
 156     grob-cause
 157     no-origin
 158     placebox
 159     unknown))
 160
 161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 162 ;; Safe definitions utility
 163 (define safe-objects (list))
 164
 165 (define-macro (define-safe-public arglist . body)
 166   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
 167 The syntax is the same as `define*-public'."
 168   (define (get-symbol arg)
 169     (if (pair? arg)
 170         (get-symbol (car arg))
 171         arg))
 172   (let ((safe-symbol (get-symbol arglist)))
 173     `(begin
 174        (define*-public ,arglist
 175          ,@body)
 176        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
 177                                 safe-objects))
 178        ,safe-symbol)))
 179
 180
 181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 182 ;; other files.
 183
 184 (for-each ly:load
 185           ;; load-from-path
 186           '("lily-library.scm"
 187             "file-cache.scm"
 188             "define-music-types.scm"
 189             "output-lib.scm"
 190             "c++.scm"
 191             "chord-ignatzek-names.scm"
 192             "chord-entry.scm"
 193             "chord-generic-names.scm"
 194             "stencil.scm"
 195             "markup.scm"
 196             "bass-figure.scm"
 197             "music-functions.scm"
 198             "part-combiner.scm"
 199             "define-music-properties.scm"
 200             "auto-beam.scm"
 201             "chord-name.scm"
 202
 203             "ly-from-scheme.scm"
 204
 205             "define-context-properties.scm"
 206             "translation-functions.scm"
 207             "script.scm"
 208             "midi.scm"
 209             "beam.scm"
 210             "clef.scm"
 211             "slur.scm"
 212             "font.scm"
 213             "encoding.scm"
 214
 215             "fret-diagrams.scm"
 216             "define-markup-commands.scm"
 217             "define-grob-properties.scm"
 218             "define-grobs.scm"
 219             "define-grob-interfaces.scm"
 220             "page-layout.scm"
 221             "titling.scm"
 222
 223             "paper.scm"
 224             "backend-library.scm"
 225             "x11-color.scm"
 226
 227             ;; must be after everything has been defined
 228             "safe-lily.scm"))
 229
 230
 231 (set! type-p-name-alist
 232       `(
 233         (,boolean-or-symbol? . "boolean or symbol")
 234         (,boolean? . "boolean")
 235         (,char? . "char")
 236         (,grob-list? . "list of grobs")
 237         (,hash-table? . "hash table")
 238         (,input-port? . "input port")
 239         (,integer? . "integer")
 240         (,list? . "list")
 241         (,ly:context? . "context")
 242         (,ly:dimension? . "dimension, in staff space")
 243         (,ly:dir? . "direction")
 244         (,ly:duration? . "duration")
 245         (,ly:grob? . "layout object")
 246         (,ly:input-location? . "input location")
 247         (,ly:moment? . "moment")
 248         (,ly:music? . "music")
 249         (,ly:pitch? . "pitch")
 250         (,ly:translator? . "translator")
 251         (,ly:font-metric? . "font metric")
 252         (,markup-list? . "list of markups")
 253         (,markup? . "markup")
 254         (,ly:music-list? . "list of music")
 255         (,number-or-grob? . "number or grob")
 256         (,number-or-string? . "number or string")
 257         (,number-pair? . "pair of numbers")
 258         (,number? . "number")
 259         (,output-port? . "output port")
 260         (,pair? . "pair")
 261         (,procedure? . "procedure")
 262         (,scheme? . "any type")
 263         (,string? . "string")
 264         (,symbol? . "symbol")
 265         (,vector? . "vector")))
 266
 267
 268 ;; debug mem leaks
 269
 270 (define gc-protect-stat-count 0)
 271 (define-public (dump-gc-protects)
 272   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 273   (let* ((protects (sort
 274                     (hash-table->alist (ly:protects))
 275                     (lambda (a b)
 276                       (< (object-address (car a))
 277                          (object-address (car b))))))
 278          (out-file-name (string-append
 279                          "gcstat-" (number->string gc-protect-stat-count)
 280                          ".scm"))
 281          (outfile    (open-file  out-file-name  "w")))
 282
 283     (display "Dumping gc protected objs to ...\n")
 284     (display
 285      (filter
 286       (lambda (x) (not (symbol? x)))
 287       (map (lambda (y)
 288              (let ((x (car y))
 289                    (c (cdr y)))
 290
 291                (string-append
 292                 (string-join
 293                  (map object->string (list (object-address x) c x))
 294                  " ")
 295                 "\n")))
 296            protects))
 297      outfile)))
 298
 299 (define-public (tweak-grob-property grob sym val)
 300   (set! (ly:grob-property grob sym) val))
 301
 302 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 303 (define-public (lilypond-main files)
 304   "Entry point for LilyPond."
 305
 306   (if (null? files)
 307       (no-files-handler))
 308
 309   (let ((failed (lilypond-all files)))
 310     (if (pair? failed)
 311         (begin
 312           (ly:error (_ "failed files: ~S") (string-join failed))
 313           (exit 1))
 314         (begin
 315           ;; HACK: be sure to exit with single newline
 316           (ly:message "")
 317           (exit 0)))))
 318
 319 (define (no-files-handler)
 320   (ly:usage)
 321   (exit 2))
 322
 323 (define-public (lilypond-all files)
 324   (let* ((failed '())
 325          (handler (lambda (key failed-file)
 326                     (set! failed (append (list failed-file) failed)))))
 327     ;;(handler (lambda (key . arg) (set! failed (append arg failed)))))
 328     (for-each (lambda (x) (lilypond-file handler x)) files)))
 329
 330 (define (lilypond-file handler file-name)
 331   (catch 'ly-file-failed
 332          (lambda () (ly:parse-file file-name))
 333          (lambda (x . args) (handler x file-name)))
 334   ;;(lambda (x) (handler x f)))
 335   (if #f
 336       (dump-gc-protects)))
 337
 338 (use-modules (scm editor))
 339
 340 (define-public (gui-main files)
 341   (if (null? files) (gui-no-files-handler))
 342   (let* ((base (basename (car files) ".ly"))
 343          (log-name (string-append base ".log"))
 344          (log-file (open-file log-name "w")))
 345     ;; Ugh, his opens a terminal
 346     ;; Do this when invoked using --quiet, --log or something?
 347     ;; (ly:message (_ "Redirecting output to ~a...") log-name)
 348     (ly:port-move (fileno (current-error-port)) log-file)
 349     (ly:message "# -*-compilation-*-")
 350     (if (null? (lilypond-all files))
 351         (exit 0)
 352         (begin
 353           (system (get-editor-command log-name 0 0))
 354           (exit 1)))))
 355
 356 (define (gui-no-files-handler)
 357   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
 358          ;; FIXME: soft-code, localize
 359          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
 360          (cmd (get-editor-command welcome-ly 0 0)))
 361     (ly:message (_ "Invoking `~a'...") cmd)
 362     (system cmd)
 363     (exit 1)))
 364
 365 ;; If no TTY and not using safe, assume running from GUI.
 366 (or (isatty? (current-input-port))
 367     (ly:get-option 'safe)
 368     (define lilypond-main gui-main))