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