X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily.scm;h=6cdc3656c841d64a84d049e204bd9d822afcfb37;hb=7949941eb50f6243b76ded2dd331501027b68448;hp=3c207413ed08e857b8cc7508a13bab985cc2aec2;hpb=03166b077427a230be791d5555c2f24fcdfcc4be;p=lilypond.git

diff --git a/scm/lily.scm b/scm/lily.scm
index 3c207413ed..6cdc3656c8 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -1,17 +1,22 @@
-;;; 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
 
-
+(set-debug-cell-accesses! #t)
 (use-modules (ice-9 regex)
-	     (srfi srfi-1)		;lists
-	     (srfi srfi-13)		;strings
-	     )
+	     (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
@@ -22,7 +27,7 @@
     (begin
       (debug-enable 'debug)
       (debug-enable 'backtrace)
-      (read-enable 'positions)))
+      (read-enable 'positions) ))
 
 
 (define-public (line-column-location line col file)
@@ -79,11 +84,14 @@
 
 (define-public ZERO-MOMENT (ly:make-moment 0 1)) 
 
+(define-public (moment-min a b)
+  (if (ly:moment<? a b) a b))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; lily specific variables.
 (define-public default-script-alist '())
 
-(define-public security-paranoia #f)
+(define-public safe-mode? #f)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Unassorted utility functions.
@@ -98,16 +106,13 @@
 	  (uniqued-alist (cdr alist) (cons (car alist) acc)))))
 
 
-(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."
+(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 entry (cdr entry) default)))
-
+    (if (pair? entry)
+	(cdr entry)
+	(if (pair? default) (car default) #f)
+	)))
 
 (define-public (uniqued-alist  alist acc)
   (if (null? alist) acc
@@ -129,14 +134,21 @@
 	    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 (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."
@@ -154,6 +166,42 @@
 	    (map-alist-keys func (cdr list)))
       ))
  
+;;;;;;;;;;;;;;;;
+;; hash
+
+
+
+(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)
+  "Convert alist to table"
+  (let
+      ((m (make-hash-table (length l))))
+
+    (map (lambda (k-v)
+	   (hashq-set! m (car k-v) (cdr k-v)))
+	 l)
+
+    m))
+       
 
 
 ;;;;;;;;;;;;;;;;
@@ -174,14 +222,20 @@
 
 
 ;; TODO: use the srfi-1 partition function.
-(define-public (uniq-list list)
+(define-public (uniq-list l)
+  
   "Uniq LIST, assuming that it is sorted"
-  (if (null? list) '()
-      (if (null? (cdr list))
-	  list
-	  (if (equal? (car list) (cadr list))
-	      (uniq-list (cdr list))
-	      (cons (car list) (uniq-list (cdr list)))))))
+  (define (helper acc l) 
+    (if (null? l)
+	acc
+	(if (null? (cdr l))
+	    (cons (car l) acc)
+	    (if (equal? (car l) (cadr l))
+		(helper acc (cdr l))
+		(helper (cons (car l) acc)  (cdr l)))
+	    )))
+  (reverse! (helper '() l) '()))
+
 
 (define (split-at-predicate predicate l)
  "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
@@ -294,6 +348,9 @@ L1 is copied, L2 not.
       0
       (if (< x 0) -1 1)))
 
+(define-public (symbol<? l r)
+  (string<? (symbol->string l) (symbol->string r)))
+
 (define-public (!= l r)
   (not (= l r)))
 
@@ -310,18 +367,22 @@ L1 is copied, L2 not.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;  output
 (use-modules (scm output-tex)
-	     (scm output-ps)
-	     (scm output-ascii-script)
 	     (scm output-sketch)
 	     (scm output-sodipodi)
-	     (scm output-pdftex)
-	     )
+	     (scm output-pdftex))
+
+
+(define output-tex-module
+  (make-module 1021 (list (resolve-interface '(scm new-output-tex)))))
+
+(define (new-tex-output-expression expr port)
+  (display (eval expr output-tex-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))
+    ("safetex" . ("TeX output. The default output form." ,new-tex-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))
@@ -335,62 +396,60 @@ 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"
+       "part-combiner.scm"
        "define-music-properties.scm"
        "auto-beam.scm"
        "chord-name.scm"
        
-       "define-translator-properties.scm"
+       "define-context-properties.scm"
        "translation-functions.scm"
        "script.scm"
-       "drums.scm"
        "midi.scm"
 
        "beam.scm"
        "clef.scm"
        "slur.scm"
-       "font.scm"
+;       "font.scm"
+       "new-font.scm"
        
+       "define-markup-commands.scm"
        "define-grob-properties.scm"
        "define-grobs.scm"
        "define-grob-interfaces.scm"
 
+       "page-layout.scm"
        "paper.scm"
        ))
 
 
-       
-
-
 (set! type-p-name-alist
   `(
    (,boolean-or-symbol? . "boolean or symbol")
    (,boolean? . "boolean")
    (,char? . "char")
    (,grob-list? . "list of grobs")
+   (,hash-table? . "hash table")
    (,input-port? . "input port")
    (,integer? . "integer")
    (,list? . "list")
@@ -398,16 +457,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")
@@ -420,3 +479,40 @@ L1 is copied, L2 not.
    (,symbol? . "symbol")
    (,vector? . "vector")
    ))
+
+
+;; 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
+     (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)
+
+    ))
+