scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fixes from S48 1.0: STRUCTURE-CLIENTS may contain both, packages and 

structures.
This commit is contained in:
mainzelm 2003-02-13 09:52:13 +00:00
parent c223eded17
commit 28db39b1c5
1 changed files with 26 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
scheme/env/pedit.scm vendored
View File

@ -138,16 +138,21 @@
(list package)
(let ((losers '())) ; was (list package) but that disables the
; entire procedure
(let recur ((package package))
(if (and (not (memq package losers))
(not (table-ref (package-definitions package) name)))
(begin (set! losers (cons package losers))
(walk-population
(lambda (struct)
(if (interface-member? (structure-interface struct) name)
(walk-population recur (structure-clients struct))))
(package-clients package)))))
losers)))
(let recur ((package-or-structure package))
(let ((package (if (package? package-or-structure)
package
(structure-package package-or-structure))))
(if (and (not (memq package losers))
(not (table-ref (package-definitions package) name)))
(begin (set! losers (cons package losers))
(walk-population
(lambda (struct)
(if (interface-member? (structure-interface struct)
name)
(walk-population recur
(structure-clients struct))))
(package-clients package))))))
losers)))
(define (set-location-forward! loser new name p)
(if *debug?*
@ -187,18 +192,18 @@
(define (verify-loser loser)
(if *debug?*
(begin (write `(verify-loser ,loser)) (newline)))
(cond ((structure? loser)
(cond ((interface? loser)
(walk-population verify-loser (interface-clients loser)))
((structure? loser)
(reinitialize-structure! loser)
(walk-population
(lambda (p)
(reinitialize-package! p)
(let ((ps (fluid $package-losers)))
(if (not (memq p ps))
(set-fluid! $package-losers
(cons p ps)))))
(structure-clients loser)))
((interface? loser)
(walk-population verify-loser (interface-clients loser)))))
(walk-population verify-loser (structure-clients loser)))
((package? loser)
(reinitialize-package! loser)
(let ((losers (fluid $package-losers)))
(if (not (memq loser losers))
(set-fluid! $package-losers
(cons loser losers)))))))
(define (drain flu check)
(let loop ()