bugreport, concise version

bugreport, concise version

[Han-Wen Nienhuys]

Hi guys,

I consider this a very severe bug. Can you fix this please?


byrd:~/usr/src/lilypond$ guile -l scm/bla.scm
Backtrace:
In unknown file:
   ?: 0* [primitive-load "scm/bla.scm"]
In scm/bla.scm:
 107: 1* [determine-split-list #((1 . 2) (3 . 4)) #((1 . 2) (3 . 4))]
In unknown file:
   ?: 2  Segmentatie fout



bla.scm :


(define ly:moment<? <)

(define-public (determine-split-list ev1 ev2)
  (define (when v i)
    (car (vector-ref v i)))
  (define (what v i)
    (cdr (vector-ref v i)))

  (define chord-threshold 8)

  (define result
    (list->vector
     (map (lambda (x)
	    (cons x 'together))
	  (merge (map car ev1) (map car ev2) ly:moment<?))))

  (define (analyse-events i1 i2 ri
			  active1
			  active2)

    (define (analyse-span-event active ev)
      (let*
	  ((name (ly:get-mus-property ev 'name))
	   (key (cond
		 ((equal? name 'SlurEvent) 'slur)
		 ((equal? name 'TieEvent) 'tie)
		 ((equal? name 'Beam) 'beam)
		 (else #f)))
	   (sp (ly:get-mus-property span-direction ev)))

	(if (and (symbol? key) (ly:dir? sp))
	    ((if (= sp STOP) delete! cons) key active))
	))       

    (define (put x)
      (set-what (whatever result ri) x))

    (cond
     ((= i1 (vector-length ev1)) (put 'apart))
     ((= i2 (vector-length ev2)) (put 'apart))
     (else
      (let*
	  ((m1 (when ev1 i1))
	   (m2 (when ev2 i2)))

	(if (not (or (equal? m1 (when result ri))
		     (equal? m2 (when result ri))))
	    (scm-error boem))

	(set! active1
	      (sort
	       (map (lambda (x) (analyse-span-event active1 x))
		    (what ev1 i1)) symbol<?))
	(set! active2
	      (sort (map (lambda (x) (analyse-span-event active2 x))
			 (what ev2 i2)) symbol<?))
	
	(cond
	 ((ly:moment<? m1 m2)
	  (put 'apart)
	  (analyse-events (1+ i1) i2 (1+ ri) active1 active2))
	 ((ly:moment<? m2 m1)
	  (put 'apart)
	  (analyse-events i1 (1+ i2) (1+ ri) active1 active2))
	 (else
	  (if (not (equal? active1 active2))
	      (put 'apart)

	      (let*
		  ((notes1 (get-note-evs ev1 i1))
		   (pitches1 (sort
			      (map (lambda (x) (ly:get-mus-property x 'pitch)) notes1) ly:pitch<?))
		   (notes2 (get-note-evs ev2 i2))
		   (pitches2 (sort
			      (map (lambda (x) (ly:get-mus-property x 'pitch)) notes2) ly:pitch<?))
		   )
		(cond
		 ((equal? pitches1 pitches2) (put 'unisono))
		 ((> (length notes1) 1) (put 'apart))
		 ((> (length notes2) 1) (put 'apart))
		 (else
		  (let* ((dif (ly:pitch-diff (car pitches1) (car pitches1))))
		    (if (< (ly:pitch-steps diff) chord-threshold)
			(put 'chords)
			(put 'apart))
		    ))))
	      ))
	 (analyse-events (1+ i1) (1+ i2) (1+ ri) active1 active2)
	 )))))


  
  (set! ev1 (list->vector ev1))
  (set! ev2 (list->vector ev2))

  
  (analyse-events 0 0  0 '() '())

  (display result)
  )



(determine-split-list '((1 . 2) (3 . 4)) '((1 . 2) (3 . 4)))



-- 

 Han-Wen Nienhuys   |   hanwen@xs4all.nl   |   http://www.xs4all.nl/~hanwen 



_______________________________________________
Bug-guile mailing list
Bug-guile@gnu.org
http://mail.gnu.org/mailman/listinfo/bug-guile

Re: bugreport, concise version

[Marius Vollmer]

Han-Wen Nienhuys  <hanwen@xs4all.nl> writes:

> I consider this a very severe bug. Can you fix this please?

Done!

Dirk, could you double-check the diff below?  I think it is obviously
the right thing to do.  Without the change, bodies with internal
definitions would get expanded on every execution, not just on the
first time.

2004-01-22  Marius Vollmer  <mvo@zagadka.de>

	* eval.c (m_expand_body): Rewrite the expression in place (by
	overwriting FORMS) also when a letrec is constructed, not only
	when no definitions are found.  Do not return rewritten expression
	to emphasize the in-place rewriting.  Changed all users.

Index: libguile/eval.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/eval.c,v
retrieving revision 1.350
diff -u -r1.350 eval.c
--- libguile/eval.c	21 Nov 2003 23:21:34 -0000	1.350
+++ libguile/eval.c	22 Jan 2004 22:41:15 -0000
@@ -764,9 +764,10 @@
 }
 
 
-/* The function m_expand_body memoizes a proper list of expressions forming a
- * body.  This function takes care of dealing with internal defines and
- * transforming them into an equivalent letrec expression.  */ 
+/* The function m_expand_body memoizes a proper list of expressions
+ * forming a body.  This function takes care of dealing with internal
+ * defines and transforming them into an equivalent letrec expression.
+ * The list of expressions is rewritten in place.  */ 
 
 /* This is a helper function for m_expand_body.  It helps to figure out whether
  * an expression denotes a syntactic keyword.  */ 
@@ -835,7 +836,7 @@
   return 0;
 }
 
-static SCM
+static void
 m_expand_body (const SCM forms, const SCM env)
 {
   /* The first body form can be skipped since it is known to be the ISYM that
@@ -948,14 +949,13 @@
       /* FIXME: forms does not hold information about the file location.  */
       letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
       new_letrec_expression = scm_m_letrec (letrec_expression, env);
-      new_body = scm_list_1 (new_letrec_expression);
-      return new_body;
+      SCM_SETCAR (forms, new_letrec_expression);
+      SCM_SETCDR (forms, SCM_EOL);
     }
   else
     {
       SCM_SETCAR (forms, SCM_CAR (sequence));
       SCM_SETCDR (forms, SCM_CDR (sequence));
-      return forms;
     }
 }
 
@@ -967,7 +967,8 @@
 {
   scm_c_issue_deprecation_warning 
     ("`scm_m_expand_body' is deprecated.");
-  return m_expand_body (exprs, env);
+  m_expand_body (exprs, env);
+  return exprs;
 }
 
 #endif
@@ -2549,7 +2550,7 @@
 	      scm_rec_mutex_lock (&source_mutex);
 	      /* check for race condition */
 	      if (SCM_ISYMP (SCM_CAR (code)))
-		code = m_expand_body (code, env);
+		m_expand_body (code, env);
 	      scm_rec_mutex_unlock (&source_mutex);
 	      goto again;
 	    }
@@ -2951,7 +2952,7 @@
 		  scm_rec_mutex_lock (&source_mutex);
 		  /* check for race condition */
 		  if (SCM_ISYMP (SCM_CAR (x)))
-		    x = m_expand_body (x, env);
+		    m_expand_body (x, env);
 		  scm_rec_mutex_unlock (&source_mutex);
 		  goto nontoplevel_begin;
 		}
@@ -4604,7 +4605,7 @@
 		  scm_rec_mutex_lock (&source_mutex);
 		  /* check for race condition */
 		  if (SCM_ISYMP (SCM_CAR (proc)))
-		    proc = m_expand_body (proc, args);
+		    m_expand_body (proc, args);
 		  scm_rec_mutex_unlock (&source_mutex);
 		  goto again;
 		}

-- 
GPG: D5D4E405 - 2F9B BCCC 8527 692A 04E3  331E FAF8 226A D5D4 E405


_______________________________________________
Bug-guile mailing list
Bug-guile@gnu.org
http://mail.gnu.org/mailman/listinfo/bug-guile

Re: bugreport, concise version

[Dirk Herrmann]

Marius Vollmer wrote:

>Dirk, could you double-check the diff below?  I think it is obviously
>the right thing to do.  Without the change, bodies with internal
>definitions would get expanded on every execution, not just on the
>first time.
>
The diff is alright. Thanks for fixing the bug.

Best regards
Dirk



_______________________________________________
Bug-guile mailing list
Bug-guile@gnu.org
http://mail.gnu.org/mailman/listinfo/bug-guile