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 ;; Cygwin
  81 ;; #(CYGWIN_NT-5.1 Hostname 1.5.12(0.116/4/2) 2004-11-10 08:34 i686)
  82 ;;
  83 ;; Debian
  84 ;; #(Linux hostname 2.4.27-1-686 #1 Fri Sep 3 06:28:00 UTC 2004 i686)
  85 ;;
  86 ;; Mingw
  87 ;; #(Windows XP HOSTNAME build 2600 5.01 Service Pack 1 i686)
  88 ;;
  89 (define PLATFORM
  90   (string->symbol
  91    (string-downcase
  92     (car (string-tokenize (vector-ref (uname) 0) char-set:letter)))))
  93
  94 (case PLATFORM
  95   ((windows)
  96    (define native-getcwd getcwd)
  97    (define (slashify x)
  98      (if (string-index x #\/)
  99          x
 100          (string-regexp-substitute "\\" "/" x)))
 101    ;; FIXME: this prints a warning.
 102   (define-public (ly-getcwd)
 103      (slashify (native-getcwd))))
 104   (else (define-public ly-getcwd getcwd)))
 105
 106 (define-public (is-absolute? file-name)
 107   (let ((file-name-length (string-length file-name)))
 108     (if (= file-name-length 0)
 109         #f
 110         (or (eq? (string-ref file-name 0) #\/)
 111             (and (eq? PLATFORM 'windows)
 112                  (> file-name-length 2)
 113                  (eq? (string-ref file-name 1) #\:)
 114                  (eq? (string-ref file-name 2) #\/))))))
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117
 118 (define (type-check-list location signature arguments)
 119   "Typecheck a list of arguments against a list of type
 120 predicates. Print a message at LOCATION if any predicate failed."
 121   (define (recursion-helper signature arguments count)
 122     (define (helper pred? arg count)
 123       (if (not (pred? arg))
 124
 125           (begin
 126             (ly:input-message
 127              location
 128              (format
 129               #f (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
 130               count (type-name pred?) arg))
 131             #f)
 132           #t))
 133
 134     (if (null? signature)
 135         #t
 136         (and (helper (car signature) (car arguments) count)
 137              (recursion-helper (cdr signature) (cdr arguments) (1+ count)))))
 138   (recursion-helper signature arguments 1))
 139
 140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141 ;;  output
 142
 143
 144 ;;(define-public (output-framework) (write "hello\n"))
 145
 146 (define output-tex-module
 147   (make-module 1021 (list (resolve-interface '(scm output-tex)))))
 148 (define output-ps-module
 149   (make-module 1021 (list (resolve-interface '(scm output-ps)))))
 150
 151 (define-public (ps-output-expression expr port)
 152   (display (eval expr output-ps-module) port))
 153
 154 ;; TODO: generate this list by registering the stencil expressions
 155 ;;       stencil expressions should have docstrings.
 156 (define-public (ly:all-stencil-expressions)
 157   "Return list of stencil expressions."
 158   '(beam
 159     bezier-sandwich
 160     blank
 161     bracket
 162     char
 163     circle
 164     dashed-line
 165     dashed-slur
 166     dot
 167     draw-line
 168     ez-ball
 169     filledbox
 170     glyph-string
 171     horizontal-line
 172     named-glyph
 173     polygon
 174     repeat-slash
 175     round-filled-box
 176     text
 177     url-link
 178     utf8-string
 179     white-dot
 180     white-text
 181     embedded-ps
 182     zigzag-line))
 183
 184 ;; TODO:
 185 ;;  - generate this list by registering the output-backend-commands
 186 ;;    output-backend-commands should have docstrings.
 187 ;;  - remove hard copies in output-ps output-tex
 188 (define-public (ly:all-output-backend-commands)
 189   "Return list of output backend commands."
 190   '(
 191     comment
 192     grob-cause
 193     no-origin
 194     placebox
 195     unknown))
 196
 197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 198 ;; Safe definitions utility
 199 (define safe-objects (list))
 200
 201 (define-macro (define-safe-public arglist . body)
 202   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
 203 The syntax is the same as `define*-public'."
 204   (define (get-symbol arg)
 205     (if (pair? arg)
 206         (get-symbol (car arg))
 207         arg))
 208   (let ((safe-symbol (get-symbol arglist)))
 209     `(begin
 210        (define*-public ,arglist
 211          ,@body)
 212        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
 213                                 safe-objects))
 214        ,safe-symbol)))
 215
 216
 217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218 ;; other files.
 219
 220 (for-each ly:load
 221           ;; load-from-path
 222           '("lily-library.scm"
 223             "file-cache.scm"
 224             "define-music-types.scm"
 225             "output-lib.scm"
 226             "c++.scm"
 227             "chord-ignatzek-names.scm"
 228             "chord-entry.scm"
 229             "chord-generic-names.scm"
 230             "stencil.scm"
 231             "markup.scm"
 232             "bass-figure.scm"
 233             "music-functions.scm"
 234             "part-combiner.scm"
 235             "define-music-properties.scm"
 236             "auto-beam.scm"
 237             "chord-name.scm"
 238
 239             "ly-from-scheme.scm"
 240
 241             "define-context-properties.scm"
 242             "translation-functions.scm"
 243             "script.scm"
 244             "midi.scm"
 245             "beam.scm"
 246             "clef.scm"
 247             "slur.scm"
 248             "font.scm"
 249             "encoding.scm"
 250
 251             "fret-diagrams.scm"
 252             "define-markup-commands.scm"
 253             "define-grob-properties.scm"
 254             "define-grobs.scm"
 255             "define-grob-interfaces.scm"
 256             "page-layout.scm"
 257             "titling.scm"
 258
 259             "paper.scm"
 260             "backend-library.scm"
 261             "x11-color.scm"
 262
 263             ;; must be after everything has been defined
 264             "safe-lily.scm"))
 265
 266
 267 (set! type-p-name-alist
 268       `(
 269         (,boolean-or-symbol? . "boolean or symbol")
 270         (,boolean? . "boolean")
 271         (,char? . "char")
 272         (,grob-list? . "list of grobs")
 273         (,hash-table? . "hash table")
 274         (,input-port? . "input port")
 275         (,integer? . "integer")
 276         (,list? . "list")
 277         (,ly:context? . "context")
 278         (,ly:dimension? . "dimension, in staff space")
 279         (,ly:dir? . "direction")
 280         (,ly:duration? . "duration")
 281         (,ly:grob? . "layout object")
 282         (,ly:input-location? . "input location")
 283         (,ly:moment? . "moment")
 284         (,ly:music? . "music")
 285         (,ly:pitch? . "pitch")
 286         (,ly:translator? . "translator")
 287         (,ly:font-metric? . "font metric")
 288         (,markup-list? . "list of markups")
 289         (,markup? . "markup")
 290         (,ly:music-list? . "list of music")
 291         (,number-or-grob? . "number or grob")
 292         (,number-or-string? . "number or string")
 293         (,number-pair? . "pair of numbers")
 294         (,number? . "number")
 295         (,output-port? . "output port")
 296         (,pair? . "pair")
 297         (,procedure? . "procedure")
 298         (,scheme? . "any type")
 299         (,string? . "string")
 300         (,symbol? . "symbol")
 301         (,vector? . "vector")))
 302
 303
 304 ;; debug mem leaks
 305
 306 (define gc-protect-stat-count 0)
 307 (define-public (dump-gc-protects)
 308   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 309   (let* ((protects (sort
 310                     (hash-table->alist (ly:protects))
 311                     (lambda (a b)
 312                       (< (object-address (car a))
 313                          (object-address (car b))))))
 314          (out-file-name (string-append
 315                          "gcstat-" (number->string gc-protect-stat-count)
 316                          ".scm"))
 317          (outfile    (open-file  out-file-name  "w")))
 318
 319     (display "Dumping gc protected objs to ...\n")
 320     (display
 321      (filter
 322       (lambda (x) (not (symbol? x)))
 323       (map (lambda (y)
 324              (let ((x (car y))
 325                    (c (cdr y)))
 326
 327                (string-append
 328                 (string-join
 329                  (map object->string (list (object-address x) c x))
 330                  " ")
 331                 "\n")))
 332            protects))
 333      outfile)))
 334
 335 (define-public (tweak-grob-property grob sym val)
 336   (set! (ly:grob-property grob sym) val))
 337
 338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 339 (define-public (lilypond-main files)
 340   "Entry point for LilyPond."
 341
 342   (if (null? files)
 343       (no-files-handler))
 344
 345   (let ((failed (lilypond-all files)))
 346     (if (pair? failed)
 347         (begin
 348           (ly:error (_ "failed files: ~S") (string-join failed))
 349           (exit 1))
 350         (begin
 351           ;; HACK: be sure to exit with single newline
 352           (ly:message "")
 353           (exit 0)))))
 354
 355 (define (no-files-handler)
 356   (ly:usage)
 357   (exit 2))
 358
 359 (define-public (lilypond-all files)
 360   (let* ((failed '())
 361          (handler (lambda (key failed-file)
 362                     (set! failed (append (list failed-file) failed)))))
 363     ;;(handler (lambda (key . arg) (set! failed (append arg failed)))))
 364     (for-each (lambda (x) (lilypond-file handler x)) files)))
 365
 366 (define (lilypond-file handler file-name)
 367   (catch 'ly-file-failed
 368          (lambda () (ly:parse-file file-name))
 369          (lambda (x . args) (handler x file-name)))
 370   ;;(lambda (x) (handler x f)))
 371   (if #f
 372       (dump-gc-protects)))
 373
 374 (use-modules (scm editor))
 375
 376 (define (running-from-gui?)
 377   (let ((have-tty? (isatty? (current-input-port))))
 378     ;; If no TTY and not using safe, assume running from GUI.
 379     ;; For mingw, the test must be inverted.
 380     (if (eq? PLATFORM 'windows)
 381         have-tty? (not have-tty?))))
 382
 383 (define-public (gui-main files)
 384   (if (null? files) (gui-no-files-handler))
 385   (let* ((base (basename (car files) ".ly"))
 386          (log-name (string-append base ".log"))
 387          (log-file (open-file log-name "w")))
 388     (if (not (running-from-gui?))
 389         (ly:message (_ "Redirecting output to ~a...") log-name))
 390     (ly:port-move (fileno (current-error-port)) log-file)
 391     (ly:message "# -*-compilation-*-")
 392     (let ((failed (lilypond-all files)))
 393       (if (pair? failed)
 394           (begin
 395             (system (get-editor-command log-name 0 0))
 396             (ly:error (_ "failed files: ~S") (string-join failed))
 397             ;; not reached?
 398             (exit 1))
 399           (exit 0)))))
 400
 401 (define (gui-no-files-handler)
 402   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
 403          ;; FIXME: soft-code, localize
 404          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
 405          (cmd (get-editor-command welcome-ly 0 0)))
 406     (ly:message (_ "Invoking `~a'...") cmd)
 407     (system cmd)
 408     (exit 1)))
 409
 410 (or (not (running-from-gui?))
 411     (ly:get-option 'safe)
 412     (define lilypond-main gui-main))