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-public 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     filledbox
 169     glyph-string
 170     named-glyph
 171     polygon
 172     repeat-slash
 173     round-filled-box
 174     text
 175     url-link
 176     utf8-string
 177     white-dot
 178     white-text
 179     embedded-ps
 180     zigzag-line))
 181
 182 ;; TODO:
 183 ;;  - generate this list by registering the output-backend-commands
 184 ;;    output-backend-commands should have docstrings.
 185 ;;  - remove hard copies in output-ps output-tex
 186 (define-public (ly:all-output-backend-commands)
 187   "Return list of output backend commands."
 188   '(
 189     comment
 190     grob-cause
 191     no-origin
 192     placebox
 193     unknown))
 194
 195 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 196 ;; Safe definitions utility
 197 (define safe-objects (list))
 198
 199 (define-macro (define-safe-public arglist . body)
 200   "Define a variable, export it, and mark it as safe, ie usable in LilyPond safe mode.
 201 The syntax is the same as `define*-public'."
 202   (define (get-symbol arg)
 203     (if (pair? arg)
 204         (get-symbol (car arg))
 205         arg))
 206   (let ((safe-symbol (get-symbol arglist)))
 207     `(begin
 208        (define*-public ,arglist
 209          ,@body)
 210        (set! safe-objects (cons (cons ',safe-symbol ,safe-symbol)
 211                                 safe-objects))
 212        ,safe-symbol)))
 213
 214
 215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 216 ;; other files.
 217
 218 (for-each ly:load
 219           ;; load-from-path
 220           '("lily-library.scm"
 221             "file-cache.scm"
 222             "define-music-types.scm"
 223             "output-lib.scm"
 224             "c++.scm"
 225             "chord-ignatzek-names.scm"
 226             "chord-entry.scm"
 227             "chord-generic-names.scm"
 228             "stencil.scm"
 229             "markup.scm"
 230             "bass-figure.scm"
 231             "music-functions.scm"
 232             "part-combiner.scm"
 233             "define-music-properties.scm"
 234             "auto-beam.scm"
 235             "chord-name.scm"
 236
 237             "ly-from-scheme.scm"
 238
 239             "define-context-properties.scm"
 240             "translation-functions.scm"
 241             "script.scm"
 242             "midi.scm"
 243             "beam.scm"
 244             "clef.scm"
 245             "slur.scm"
 246             "font.scm"
 247             "encoding.scm"
 248
 249             "fret-diagrams.scm"
 250             "define-markup-commands.scm"
 251             "define-grob-properties.scm"
 252             "define-grobs.scm"
 253             "define-grob-interfaces.scm"
 254             "page-layout.scm"
 255             "titling.scm"
 256
 257             "paper.scm"
 258             "backend-library.scm"
 259             "x11-color.scm"
 260
 261             ;; must be after everything has been defined
 262             "safe-lily.scm"))
 263
 264
 265 (set! type-p-name-alist
 266       `(
 267         (,boolean-or-symbol? . "boolean or symbol")
 268         (,boolean? . "boolean")
 269         (,char? . "char")
 270         (,grob-list? . "list of grobs")
 271         (,hash-table? . "hash table")
 272         (,input-port? . "input port")
 273         (,integer? . "integer")
 274         (,list? . "list")
 275         (,ly:context? . "context")
 276         (,ly:dimension? . "dimension, in staff space")
 277         (,ly:dir? . "direction")
 278         (,ly:duration? . "duration")
 279         (,ly:grob? . "layout object")
 280         (,ly:input-location? . "input location")
 281         (,ly:moment? . "moment")
 282         (,ly:music? . "music")
 283         (,ly:pitch? . "pitch")
 284         (,ly:translator? . "translator")
 285         (,ly:font-metric? . "font metric")
 286         (,markup-list? . "list of markups")
 287         (,markup? . "markup")
 288         (,ly:music-list? . "list of music")
 289         (,number-or-grob? . "number or grob")
 290         (,number-or-string? . "number or string")
 291         (,number-pair? . "pair of numbers")
 292         (,number? . "number")
 293         (,output-port? . "output port")
 294         (,pair? . "pair")
 295         (,procedure? . "procedure")
 296         (,scheme? . "any type")
 297         (,string? . "string")
 298         (,symbol? . "symbol")
 299         (,vector? . "vector")))
 300
 301
 302 ;; debug mem leaks
 303
 304 (define gc-protect-stat-count 0)
 305 (define-public (dump-gc-protects)
 306   (set! gc-protect-stat-count (1+ gc-protect-stat-count))
 307   (let* ((protects (sort
 308                     (hash-table->alist (ly:protects))
 309                     (lambda (a b)
 310                       (< (object-address (car a))
 311                          (object-address (car b))))))
 312          (out-file-name (string-append
 313                          "gcstat-" (number->string gc-protect-stat-count)
 314                          ".scm"))
 315          (outfile    (open-file  out-file-name  "w")))
 316
 317     (display "Dumping gc protected objs to ...\n")
 318     (display
 319      (filter
 320       (lambda (x) (not (symbol? x)))
 321       (map (lambda (y)
 322              (let ((x (car y))
 323                    (c (cdr y)))
 324
 325                (string-append
 326                 (string-join
 327                  (map object->string (list (object-address x) c x))
 328                  " ")
 329                 "\n")))
 330            protects))
 331      outfile)))
 332
 333 (define-public (tweak-grob-property grob sym val)
 334   (set! (ly:grob-property grob sym) val))
 335
 336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 337 (define-public (lilypond-main files)
 338   "Entry point for LilyPond."
 339
 340   (if (null? files)
 341       (no-files-handler))
 342
 343   (let ((failed (lilypond-all files)))
 344     (if (pair? failed)
 345         (begin
 346           (ly:error (_ "failed files: ~S") (string-join failed))
 347           (exit 1))
 348         (begin
 349           ;; HACK: be sure to exit with single newline
 350           (ly:message "")
 351           (exit 0)))))
 352
 353 (define (no-files-handler)
 354   (ly:usage)
 355   (exit 2))
 356
 357 (define-public (lilypond-all files)
 358   (let* ((failed '())
 359          (handler (lambda (key failed-file)
 360                     (set! failed (append (list failed-file) failed)))))
 361     ;;(handler (lambda (key . arg) (set! failed (append arg failed)))))
 362     (for-each (lambda (x) (lilypond-file handler x)) files)
 363     failed))
 364
 365 (define (lilypond-file handler file-name)
 366   (catch 'ly-file-failed
 367          (lambda () (ly:parse-file file-name))
 368          (lambda (x . args) (handler x file-name)))
 369   ;;(lambda (x) (handler x f)))
 370   (if #f
 371       (dump-gc-protects)))
 372
 373 (use-modules (scm editor))
 374
 375 (define (running-from-gui?)
 376   (let ((have-tty? (isatty? (current-input-port))))
 377     ;; If no TTY and not using safe, assume running from GUI.
 378     (cond
 379      ((eq? PLATFORM 'windows)
 380       ;; This only works for i586-mingw32msvc-gcc -mwindows
 381       (not (string-match "standard input"
 382                          (format #f "~S" (current-input-port)))))
 383      ((eq? PLATFORM 'darwin) #f)
 384      (else
 385       (not have-tty?)))))
 386
 387 (define-public (gui-main files)
 388   (if (null? files) (gui-no-files-handler))
 389   (let* ((base (basename (car files) ".ly"))
 390          (log-name (string-append base ".log")))
 391     (if (not (running-from-gui?))
 392         (ly:message (_ "Redirecting output to ~a...") log-name))
 393     (ly:stderr-redirect log-name "w")
 394     (ly:message "# -*-compilation-*-")
 395     (let ((failed (lilypond-all files)))
 396       (if (pair? failed)
 397           (begin
 398             ;; ugh
 399             (ly:stderr-redirect "foo" "r")
 400             (system (get-editor-command log-name 0 0))
 401             (ly:error (_ "failed files: ~S") (string-join failed))
 402             ;; not reached?
 403             (exit 1))
 404           (exit 0)))))
 405
 406 (define (gui-no-files-handler)
 407   (let* ((ly (string-append (ly:effective-prefix) "/ly/"))
 408          ;; FIXME: soft-code, localize
 409          (welcome-ly (string-append ly "Welcome_to_LilyPond.ly"))
 410          (cmd (get-editor-command welcome-ly 0 0)))
 411     (ly:message (_ "Invoking `~a'...") cmd)
 412     (system cmd)
 413     (exit 1)))
 414
 415 (or (not (running-from-gui?))
 416     (ly:get-option 'safe)
 417     (define lilypond-main gui-main))