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