>From 3b3e278df64b5d8ae4dd1dcd8576f9597d32c5ca Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Mon, 23 Jan 2012 18:39:34 +0100 Subject: [PATCH] Limit depth for procedure nesting reports to ensure linear scaling of compilation times on input file size. --- support.scm | 24 ++++++++++++++++-------- 1 files changed, 16 insertions(+), 8 deletions(-) diff --git a/support.scm b/support.scm index 191ae7c..fe85940 100644 --- a/support.scm +++ b/support.scm @@ -1398,6 +1398,9 @@ (define (set-real-name! name rname) (##sys#hash-table-set! real-name-table name rname) ) +;; Arbitrary limit to prevent runoff into exponential behavior +(define real-name-max-depth 20) + (define (real-name var . db) (define (resolve n) (let ([n2 (##sys#hash-table-ref real-name-table n)]) @@ -1409,15 +1412,20 @@ (cond [(not rn) (##sys#symbol->qualified-string var)] [(pair? db) (let ([db (car db)]) - (let loop ([nesting (list (##sys#symbol->qualified-string rn))] + (let loop ([nesting (list (##sys#symbol->qualified-string rn))] + [depth 0] [container (get db var 'contained-in)] ) - (if container - (let ([rc (resolve container)]) - (if (eq? rc container) - (string-intersperse (reverse nesting) " in ") - (loop (cons (symbol->string rc) nesting) - (get db container 'contained-in) ) ) ) - (string-intersperse (reverse nesting) " in ")) ) ) ] + (cond + ((> depth real-name-max-depth) + (string-intersperse (reverse (cons "..." nesting)) " in ")) + (container + (let ([rc (resolve container)]) + (if (eq? rc container) + (string-intersperse (reverse nesting) " in ") + (loop (cons (symbol->string rc) nesting) + (fx+ depth 1) + (get db container 'contained-in) ) ) )) + (else (string-intersperse (reverse nesting) " in "))) ) ) ] [else (##sys#symbol->qualified-string rn)] ) ) ) (define (real-name2 var db) -- 1.7.3.4