X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily.scm;h=945f26fb415298c18e52052ee3a36f186eac34c1;hb=99433c54bea756a38ed6b2a70bc8c90cd0d37902;hp=882445dae340a1cad09e36e4342554d37e635c5c;hpb=6ac8e1b2d7640826ae251e040de5efbc36da68ab;p=lilypond.git

diff --git a/scm/lily.scm b/scm/lily.scm
index 882445dae3..945f26fb41 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -1,48 +1,47 @@
-;;; lily.scm -- implement Scheme output routines for TeX and PostScript
+;;;; lily.scm -- implement Scheme output routines for TeX and PostScript
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;; 
-;;;; (c)  1998--2003 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; (c)  1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
 
 ;;; Library functions
 
 
+(if (defined? 'set-debug-cell-accesses!)
+    (set-debug-cell-accesses! #f))
+
 (use-modules (ice-9 regex)
 	     (ice-9 safe)
 	     (oop goops)
 	     (srfi srfi-1)  ; lists
 	     (srfi srfi-13)) ; strings
 
-(define-public safe-module (make-safe-module))
-
 (define-public (myd k v) (display k) (display ": ") (display v) (display ", "))
 
 ;;; General settings
 ;;; debugging evaluator is slower.  This should
 ;;; have a more sensible default.
 
-
 (if (ly:get-option 'verbose)
     (begin
       (debug-enable 'debug)
       (debug-enable 'backtrace)
-      (read-enable 'positions) ))
-
+      (read-enable 'positions)))
 
 (define-public (line-column-location line col file)
   "Print an input location, including column number ."
   (string-append (number->string line) ":"
-		 (number->string col) " " file)
-  )
+		 (number->string col) " " file))
 
 (define-public (line-location line col file)
   "Print an input location, without column number ."
-  (string-append (number->string line) " " file)
-  )
+  (string-append (number->string line) " " file))
 
 (define-public point-and-click #f)
 
+(define-public parser #f)
+
 (define-public (lilypond-version)
   (string-join
    (map (lambda (x) (if (symbol? x)
@@ -89,35 +88,45 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; lily specific variables.
+
 (define-public default-script-alist '())
 
-(define-public security-paranoia #f)
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Unassorted utility functions.
+;; parser stuff.
+(define-public (print-music-as-book parser music)
+  (let* ((score (ly:music-scorify music))
+	 (head  (ly:parser-lookup parser '$globalheader))
+	 (book (ly:score-bookify score head)))
+    (ly:parser-print-book parser book)))
 
+(define-public (print-score-as-book parser score)
+  (let*
+      ((head  (ly:parser-lookup parser '$globalheader))
+       (book (ly:score-bookify score head)))
+    
+    (ly:parser-print-book parser book)))
 
-;;;;;;;;;;;;;;;;
-; alist
-(define (uniqued-alist  alist acc)
-  (if (null? alist) acc
-      (if (assoc (caar alist) acc)
-	  (uniqued-alist (cdr alist) acc)
-	  (uniqued-alist (cdr alist) (cons (car alist) acc)))))
+(define-public (print-score parser score)
+  (let* ((head  (ly:parser-lookup parser '$globalheader))
+	(book (ly:score-bookify score head)))
+    (ly:parser-print-score parser book)))
+		
+(define-public default-toplevel-music-handler print-music-as-book)
+(define-public default-toplevel-book-handler ly:parser-print-book)
+(define-public default-toplevel-score-handler print-score-as-book)
 
 
-(define (assoc-get key alist)
-  "Return value if KEY in ALIST, else #f."
-  (let ((entry (assoc key alist)))
-    (if entry (cdr entry) #f)))
-  
-(define (assoc-get-default key alist default)
-  "Return value if KEY in ALIST, else DEFAULT."
-  (let ((entry (assoc key alist)))
-    (if entry (cdr entry) default)))
 
+;;;;;;;;;;;;;;;;
+; alist
+(define-public (assoc-get key alist . default)
+  "Return value if KEY in ALIST, else DEFAULT (or #f if not specified)."
+  (let ((entry (assoc key alist)))
+    (if (pair? entry)
+	(cdr entry)
+	(if (pair? default) (car default) #f))))
 
-(define-public (uniqued-alist  alist acc)
+(define-public (uniqued-alist alist acc)
   (if (null? alist) acc
       (if (assoc (caar alist) acc)
 	  (uniqued-alist (cdr alist) acc)
@@ -127,9 +136,7 @@
   (string<? (symbol->string (car x))
 	    (symbol->string (car y))))
 
-
-
-(define (chain-assoc x alist-list)
+(define-public (chain-assoc x alist-list)
   (if (null? alist-list)
       #f
       (let* ((handle (assoc x (car alist-list))))
@@ -137,14 +144,20 @@
 	    handle
 	    (chain-assoc x (cdr alist-list))))))
 
-(define (chain-assoc-get x alist-list default)
-  (if (null? alist-list)
-      default
-      (let* ((handle (assoc x (car alist-list))))
-	(if (pair? handle)
-	    (cdr handle)
-	    (chain-assoc-get x (cdr alist-list) default)))))
+(define-public (chain-assoc-get x alist-list . default)
+  "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
+found."
+
+  (define (helper x alist-list default)
+    (if (null? alist-list)
+	default
+	(let* ((handle (assoc x (car alist-list))))
+	  (if (pair? handle)
+	      (cdr handle)
+	      (helper x (cdr alist-list) default)))))
 
+  (helper x alist-list
+	  (if (pair? default) (car default) #f)))
 
 (define (map-alist-vals func list)
   "map FUNC over the vals of  LIST, leaving the keys."
@@ -162,12 +175,29 @@
 	    (map-alist-keys func (cdr list)))
       ))
  
+;;;;;;;;;;;;;;;;
+;; hash
 
-(define-public (hash-table->alist t)
-  "Convert table t to list"
-  (apply append
-	 (vector->list t)
-  ))
+
+
+(if (not (defined? 'hash-table?))	; guile 1.6 compat
+    (begin
+      (define hash-table? vector?)
+
+      (define-public (hash-table->alist t)
+	"Convert table t to list"
+	(apply append
+	       (vector->list t)
+	       )))
+
+    ;; native hashtabs.
+    (begin
+      (define-public (hash-table->alist t)
+
+	(hash-fold (lambda (k v acc) (acons  k v  acc))
+		   '() t)
+	)
+      ))
 
 ;; todo: code dup with C++. 
 (define-public (alist->hash-table l)
@@ -334,10 +364,7 @@ L1 is copied, L2 not.
   (not (= l r)))
 
 (define-public (ly:load x)
-  (let* (
-	 (fn (%search-load-path x))
-
-	 )
+  (let* ((fn (%search-load-path x)))
     (if (ly:get-option 'verbose)
 	(format (current-error-port) "[~A]" fn))
     (primitive-load fn)))
@@ -345,21 +372,34 @@ L1 is copied, L2 not.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  output
-(use-modules (scm output-tex)
-	     (scm output-ps)
-	     (scm output-sketch)
-	     (scm output-sodipodi)
-	     (scm output-pdftex)
-	     )
+
+
+;; only load modules necessary.
+(eval
+ (cons use-modules
+       (map (lambda (x)
+	      (list 'scm (string->symbol (string-append "framework-" x))))
+	    (ly:output-formats)))
+ (current-module))
+       
+   
+(define output-tex-module
+  (make-module 1021 (list (resolve-interface '(scm output-tex)))))
+(define output-ps-module
+  (make-module 1021 (list (resolve-interface '(scm output-ps)))))
+(define-public (tex-output-expression expr port)
+  (display (eval expr output-tex-module) port))
+(define-public (ps-output-expression expr port)
+  (display (eval expr output-ps-module) port))
+
 
 (define output-alist
   `(
     ("tex" . ("TeX output. The default output form." ,tex-output-expression))
-    ("ps" . ("Direct postscript. Requires setting GS_LIB and GS_FONTPATH" ,ps-output-expression))
-    ("scm" . ("Scheme dump: debug scheme molecule expressions" ,write))
-    ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
-    ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
-    ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
+    ("scm" . ("Scheme dump: debug scheme stencil expressions" ,write))
+;    ("sketch" . ("Bare bones Sketch output." ,sketch-output-expression))
+;    ("sodipodi" . ("Bare bones Sodipodi output." ,sodipodi-output-expression))
+;    ("pdftex" . ("PDFTeX output. Was last seen nonfunctioning." ,pdftex-output-expression))
     ))
 
 
@@ -370,27 +410,26 @@ L1 is copied, L2 not.
      output-alist)
    ))
 
-(define-public (find-dumper format )
-  (let*
-      ((d (assoc format output-alist)))
-    
+(define-public (find-dumper format)
+  (let ((d (assoc format output-alist)))
     (if (pair? d)
 	(caddr d)
-	(scm-error "Could not find dumper for format ~s" format))
-    ))
+	(scm-error "Could not find dumper for format ~s" format))))
+
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; other files.
 
-(map ly:load
-					; load-from-path
+(for-each ly:load
+     ;; load-from-path
      '("define-music-types.scm"
        "output-lib.scm"
        "c++.scm"
        "chord-ignatzek-names.scm"
        "chord-entry.scm"
        "chord-generic-names.scm"
-       "molecule.scm"
+       "stencil.scm"
        "new-markup.scm"
        "bass-figure.scm"
        "music-functions.scm"
@@ -398,26 +437,32 @@ L1 is copied, L2 not.
        "define-music-properties.scm"
        "auto-beam.scm"
        "chord-name.scm"
+
+       "ly-from-scheme.scm"
        
-       "define-translator-properties.scm"
+       "define-context-properties.scm"
        "translation-functions.scm"
        "script.scm"
        "midi.scm"
-
        "beam.scm"
        "clef.scm"
        "slur.scm"
        "font.scm"
+       "encoding.scm"
        
+       "fret-diagrams.scm"
+       "define-markup-commands.scm"
        "define-grob-properties.scm"
        "define-grobs.scm"
        "define-grob-interfaces.scm"
-
+       "page-layout.scm"
+       "titling.scm"
+       
        "paper.scm"
-       ))
-
 
-       
+       ; last:
+       "safe-lily.scm"
+       ))
 
 
 (set! type-p-name-alist
@@ -426,6 +471,7 @@ L1 is copied, L2 not.
    (,boolean? . "boolean")
    (,char? . "char")
    (,grob-list? . "list of grobs")
+   (,hash-table? . "hash table")
    (,input-port? . "input port")
    (,integer? . "integer")
    (,list? . "list")
@@ -433,16 +479,16 @@ L1 is copied, L2 not.
    (,ly:dimension? . "dimension, in staff space")
    (,ly:dir? . "direction")
    (,ly:duration? . "duration")
-   (,ly:grob? . "grob (GRaphical OBject)")
+   (,ly:grob? . "layout object")
    (,ly:input-location? . "input location")
-   (,ly:input-location? . "input location")   
    (,ly:moment? . "moment")
    (,ly:music? . "music")
    (,ly:pitch? . "pitch")
    (,ly:translator? . "translator")
+   (,ly:font-metric? . "font metric")
    (,markup-list? . "list of markups")
    (,markup? . "markup")
-   (,music-list? . "list of music")
+   (,ly:music-list? . "list of music")
    (,number-or-grob? . "number or grob")
    (,number-or-string? . "number or string")
    (,number-pair? . "pair of numbers")
@@ -457,3 +503,66 @@ L1 is copied, L2 not.
    ))
 
 
+;; debug mem leaks
+
+(define gc-protect-stat-count 0)
+(define-public (dump-gc-protects)
+  (set! gc-protect-stat-count (1+ gc-protect-stat-count) )
+  (let*
+      ((protects (sort
+	   (hash-table->alist (ly:protects))
+	   (lambda (a b)
+	     (< (object-address (car a))
+		(object-address (car b))))))
+       (outfile    (open-file (string-append
+	       "gcstat-" (number->string gc-protect-stat-count)
+	       ".scm"
+	       ) "w"))
+       )
+
+    (display "DUMPING...\n")
+    (display
+     (filter
+      (lambda (x) (not (symbol? x))) 
+      (map (lambda (y)
+	     (let
+		 ((x (car y))
+		  (c (cdr y)))
+
+	       (string-append
+		(string-join
+		 (map object->string (list (object-address x) c x))
+		 " ")
+		"\n")))
+	   protects))
+     outfile)
+
+    ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
+
+(define-public (lilypond-main files)
+  "Entry point for Lilypond"
+  (let*
+      ((failed '())
+       (handler (lambda (key arg)
+		  (set! failed (cons arg failed))))
+       )
+
+    (for-each
+     (lambda (fn)
+	(catch 'ly-file-failed
+	      (lambda () (ly:parse-file fn))
+	      handler))
+       
+	files)
+
+    (if (pair? failed)
+	(begin
+	  (display (string-append "\n *** Failed files: " (string-join failed) "\n" ))
+	  (exit 1))
+	(exit 0))
+
+    ))
+
+