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

33
scheme/env/pedit.scm vendored
View File

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