356 lines
12 KiB
Scheme
356 lines
12 KiB
Scheme
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||
|
|
|
||
|
|
|
||
|
|
; Package / structure / interface mutation operations.
|
||
|
|
|
||
|
|
; None of these is essential for the static semantics of packages.
|
||
|
|
; They only come into play in order to implement dynamic package
|
||
|
|
; mutation, which is solely a debugging operation.
|
||
|
|
|
||
|
|
; This is work in progress. There are surely numerous bugs.
|
||
|
|
|
||
|
|
; (define (package-system-sentinel) #f)
|
||
|
|
|
||
|
|
(define (package-open! p struct-thunk)
|
||
|
|
(if (not (memq (struct-thunk) (package-opens p)))
|
||
|
|
(let ((thunk (package-opens-thunk p)))
|
||
|
|
(set-package-opens-thunk! p (lambda ()
|
||
|
|
(cons (struct-thunk) (thunk))))
|
||
|
|
(reinitialize-package! p)
|
||
|
|
(verify-package p)
|
||
|
|
)))
|
||
|
|
|
||
|
|
(define (reinitialize-package! p)
|
||
|
|
(if *debug?*
|
||
|
|
(begin (write `(reinitialize ,p)) (newline)))
|
||
|
|
;; (set-package-opens! p #f)
|
||
|
|
(if (package-opens-really p)
|
||
|
|
(initialize-package! p)))
|
||
|
|
|
||
|
|
(define (reinitialize-structure! s)
|
||
|
|
(if *debug?*
|
||
|
|
(begin (write `(reinitialize ,s)) (newline)))
|
||
|
|
;; (set-structure-interface! s #f)
|
||
|
|
(if (structure-interface-really s)
|
||
|
|
(initialize-structure! s)))
|
||
|
|
|
||
|
|
|
||
|
|
; GET-NEW-LOCATION-CAREFULLY is called to obtain a location when
|
||
|
|
; a variable becomes newly defined.
|
||
|
|
; If the variable has already been referenced in any code that ought
|
||
|
|
; to see the new binding, we need to alter all such references to
|
||
|
|
; access the new location instead of whatever location they saw
|
||
|
|
; before.
|
||
|
|
|
||
|
|
(define (get-new-location-carefully p name)
|
||
|
|
(let* ((prev (package-lookup p name))
|
||
|
|
(new (if (binding? prev)
|
||
|
|
(let ((new (make-new-location p name))
|
||
|
|
(cached (table-ref (package-cached p) name)))
|
||
|
|
(copy-shadowed-contents! (binding-place prev) new)
|
||
|
|
(cond (cached
|
||
|
|
(if (eq? (binding-place prev) cached)
|
||
|
|
(cope-with-mutation p name new cached)
|
||
|
|
(error "binding cache inconsistency"
|
||
|
|
p name new cached))))
|
||
|
|
new)
|
||
|
|
(get-new-location-non-shadowing p name)))
|
||
|
|
(aloc (table-ref (package-undefined-but-assigneds p)
|
||
|
|
name)))
|
||
|
|
(if aloc ; Assigned?
|
||
|
|
(begin (if *debug?*
|
||
|
|
(note "assigned -> defined" name))
|
||
|
|
(table-set! (package-undefined-but-assigneds p) name #f)
|
||
|
|
(set-location-forward! aloc new name p)))
|
||
|
|
new))
|
||
|
|
|
||
|
|
(define (note . rest) (apply signal 'note rest))
|
||
|
|
|
||
|
|
(define (get-new-location-non-shadowing p name)
|
||
|
|
(let* ((uloc (table-ref (package-undefineds p) name))
|
||
|
|
(loc
|
||
|
|
(if uloc
|
||
|
|
(begin (if *debug?* (note "undefined -> defined" name uloc))
|
||
|
|
(table-set! (package-undefineds p) name #f)
|
||
|
|
uloc)
|
||
|
|
(make-new-location p name))))
|
||
|
|
(if (and (not uloc)
|
||
|
|
(symbol? name)) ; interfaces can't handle generated names
|
||
|
|
(let recur ((q p))
|
||
|
|
(let loop ((opens (package-opens q)))
|
||
|
|
(if (not (null? opens))
|
||
|
|
(if (interface-ref (structure-interface (car opens)) name)
|
||
|
|
;; Shadowing
|
||
|
|
(let* ((q (structure-package (car opens)))
|
||
|
|
(probe (table-ref (package-undefineds q)
|
||
|
|
name)))
|
||
|
|
(if probe
|
||
|
|
(begin (if *debug?*
|
||
|
|
(note "undefined -> shadowed"
|
||
|
|
name loc probe))
|
||
|
|
(cope-with-mutation p name loc probe))
|
||
|
|
(recur q)))
|
||
|
|
(loop (cdr opens)))))))
|
||
|
|
loc))
|
||
|
|
|
||
|
|
; COPE-WITH-MUTATION:
|
||
|
|
; A package system mutation has newly caused NAME to be bound in
|
||
|
|
; package P to NEW, but prior references assumed that its binding was
|
||
|
|
; PREV (perhaps inherited from another package). If PREV is a
|
||
|
|
; location, then each occurrence of it stowed away in templates and
|
||
|
|
; packages must eventually be replaced by either location NEW, if P's
|
||
|
|
; binding is the one that's visible at that occurrence, or to a fresh
|
||
|
|
; location to replace PREV, if not.
|
||
|
|
|
||
|
|
(define (cope-with-mutation p name new prev)
|
||
|
|
(if (eq? new prev)
|
||
|
|
(error "lossage in cope-with-mutation" p name new prev))
|
||
|
|
(let ((replacement (make-new-location p name)))
|
||
|
|
(copy-location-info! prev replacement)
|
||
|
|
(table-set! (package-cached p) name new)
|
||
|
|
(if *debug?*
|
||
|
|
(begin (write `(mutation ,prev ,new ,replacement)) (newline)))
|
||
|
|
(shadow-location! prev
|
||
|
|
(map package-uid
|
||
|
|
(packages-seeing-location p name prev))
|
||
|
|
new
|
||
|
|
replacement)))
|
||
|
|
|
||
|
|
;(define (set-binding-place! b foo) (vector-set! b 1 foo))
|
||
|
|
|
||
|
|
|
||
|
|
; Hmm. It ought to be possible to turn this into an RPC.
|
||
|
|
|
||
|
|
(define (copy-shadowed-contents! import loc)
|
||
|
|
(if (location-defined? import)
|
||
|
|
(set-contents! loc (contents import))))
|
||
|
|
|
||
|
|
|
||
|
|
; Return a list of all packages that might have cached a particular
|
||
|
|
; inherited binding.
|
||
|
|
|
||
|
|
(define (packages-seeing-location package name loc)
|
||
|
|
(if (not (symbol? name)) ; interfaces cannot handle generated names
|
||
|
|
(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-ref (structure-interface struct) name)
|
||
|
|
(walk-population recur (structure-clients struct))))
|
||
|
|
(package-clients package)))))
|
||
|
|
losers)))
|
||
|
|
|
||
|
|
(define (set-location-forward! loser new name p)
|
||
|
|
(if *debug?*
|
||
|
|
(begin (write `(forward ,loser ,new)) (newline)))
|
||
|
|
(for-each (lambda (q)
|
||
|
|
(package-note-caching! q name new))
|
||
|
|
(packages-seeing-location p name loser))
|
||
|
|
(shadow-location! loser '() #f new))
|
||
|
|
|
||
|
|
|
||
|
|
(set-fluid! $get-location get-new-location-carefully) ;foo
|
||
|
|
|
||
|
|
|
||
|
|
(define (copy-location-info! from to)
|
||
|
|
(let ((probe (location-info from)))
|
||
|
|
(if probe
|
||
|
|
(table-set! location-info-table (location-id to) probe))))
|
||
|
|
|
||
|
|
|
||
|
|
;; Deal with editing operations
|
||
|
|
|
||
|
|
(define (really-verify-later! thunk) ;cf. define-structure macro
|
||
|
|
(let ((loser (ignore-errors thunk)))
|
||
|
|
(cond ((or (structure? loser)
|
||
|
|
(interface? loser))
|
||
|
|
;; (write `(loser: ,loser)) (newline)
|
||
|
|
(set-fluid! $losers (cons loser (fluid $losers))))))
|
||
|
|
#f)
|
||
|
|
|
||
|
|
(define $losers (make-fluid '()))
|
||
|
|
(define $package-losers (make-fluid '()))
|
||
|
|
|
||
|
|
(define (package-system-sentinel)
|
||
|
|
(drain $losers verify-loser)
|
||
|
|
(drain $package-losers verify-package))
|
||
|
|
|
||
|
|
(define (verify-loser loser)
|
||
|
|
(if *debug?*
|
||
|
|
(begin (write `(verify-loser ,loser)) (newline)))
|
||
|
|
(cond ((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)))))
|
||
|
|
|
||
|
|
(define (drain flu check)
|
||
|
|
(let loop ()
|
||
|
|
(let ((losers (fluid flu)))
|
||
|
|
(if (not (null? losers))
|
||
|
|
(let ((loser (car losers)))
|
||
|
|
(set-fluid! flu (cdr losers))
|
||
|
|
(check loser)
|
||
|
|
(loop))))))
|
||
|
|
|
||
|
|
(define *debug?* #f)
|
||
|
|
|
||
|
|
; --------------------
|
||
|
|
; If any looked-up location is now invalid, do something about it. We
|
||
|
|
; might have a previously unbound variable that is now exported by
|
||
|
|
; some structure; or, we might have a variable that was bound in some
|
||
|
|
; structure before, but now either that structure doesn't export it at
|
||
|
|
; all, or we're now getting that binding from some new structure.
|
||
|
|
|
||
|
|
(define (verify-package p)
|
||
|
|
(verify-package-cached p)
|
||
|
|
(verify-package-undefineds p))
|
||
|
|
|
||
|
|
; unbound -> bound
|
||
|
|
|
||
|
|
(define (verify-package-undefineds p)
|
||
|
|
(if *debug?*
|
||
|
|
(begin (write `(verify undefineds ,p)) (newline)))
|
||
|
|
(let ((newly-defined '())
|
||
|
|
(defs (package-definitions p))
|
||
|
|
(undefs (package-undefineds p)))
|
||
|
|
(table-walk (lambda (name prev)
|
||
|
|
(if (table-ref defs name)
|
||
|
|
(error "lossage in verify-package-undefineds" p name))
|
||
|
|
(let ((binding (package-lookup p name)))
|
||
|
|
(if (binding? binding)
|
||
|
|
(let ((place (binding-place binding)))
|
||
|
|
(if (eq? place prev)
|
||
|
|
(error "lossage - verify-package-undefineds"
|
||
|
|
p name binding))
|
||
|
|
(set-location-forward! prev place name p)
|
||
|
|
(set! newly-defined
|
||
|
|
(cons name newly-defined)))
|
||
|
|
(let ((loc (location-for-reference p name)))
|
||
|
|
(if (not (eq? loc prev))
|
||
|
|
;; Newly imported
|
||
|
|
(begin (set-location-forward! prev loc name p)
|
||
|
|
(set! newly-defined
|
||
|
|
(cons name newly-defined))))))))
|
||
|
|
undefs)
|
||
|
|
(if (not (null? newly-defined))
|
||
|
|
(begin (display "Newly accessible in ")
|
||
|
|
(write (package-name p))
|
||
|
|
(display ": ")
|
||
|
|
(write newly-defined)
|
||
|
|
(newline)))
|
||
|
|
(for-each (lambda (winner)
|
||
|
|
(table-set! undefs winner #f))
|
||
|
|
newly-defined)))
|
||
|
|
|
||
|
|
(define (verify-package-cached p)
|
||
|
|
;; (write `(verify ,p cached)) (newline)
|
||
|
|
(let ((newly-moved '())
|
||
|
|
(newly-undefined '())
|
||
|
|
(cached (package-cached p)))
|
||
|
|
(table-walk (lambda (name prev)
|
||
|
|
(let ((binding (package-lookup p name)))
|
||
|
|
(if (binding? binding)
|
||
|
|
(if (not (eq? (binding-place binding) prev))
|
||
|
|
(set! newly-moved
|
||
|
|
(cons name newly-moved)))
|
||
|
|
;; Otherwise either (a) it was previously
|
||
|
|
;; defined but has become newly undefined, or
|
||
|
|
;; (b) it was undefined before and is still, but
|
||
|
|
;; is inherited (or not) from a different place.
|
||
|
|
(let ((u (location-for-reference p name)))
|
||
|
|
(if (not (eq? u prev))
|
||
|
|
(set! newly-undefined
|
||
|
|
(cons name newly-undefined)))))))
|
||
|
|
cached)
|
||
|
|
(if (not (null? newly-moved))
|
||
|
|
(begin (display "Definitions visible in ")
|
||
|
|
(write (package-name p))
|
||
|
|
(display " have moved: ")
|
||
|
|
(write newly-moved)
|
||
|
|
(newline)))
|
||
|
|
(for-each (lambda (name)
|
||
|
|
(let ((new (binding-place (package-lookup p name))))
|
||
|
|
(cope-with-mutation p name new
|
||
|
|
(table-ref cached name))
|
||
|
|
(table-set! cached name new)))
|
||
|
|
newly-moved)
|
||
|
|
(if (and *debug?* (not (null? newly-undefined)))
|
||
|
|
(begin (display "Newly undefined in ")
|
||
|
|
(write (package-name p))
|
||
|
|
(display ": ")
|
||
|
|
(write newly-undefined)
|
||
|
|
(newline)))
|
||
|
|
(for-each (lambda (name)
|
||
|
|
(let ((new (location-for-reference p name)))
|
||
|
|
(cope-with-mutation p name new
|
||
|
|
(table-ref cached name))
|
||
|
|
(table-set! cached name new)))
|
||
|
|
newly-undefined)))
|
||
|
|
|
||
|
|
(set-verify-later! really-verify-later!)
|
||
|
|
|
||
|
|
|
||
|
|
;(define (maybe-note-redefinition p name seen new)
|
||
|
|
; (if (and seen (not (compatible? new seen)))
|
||
|
|
; (let ((old-description (binding-description-string seen))
|
||
|
|
; (new-description (binding-description-string new))
|
||
|
|
; (doing (if (package-definition p name)
|
||
|
|
; "redefining"
|
||
|
|
; "shadowing")))
|
||
|
|
; (warn (if (equal? old-description new-description)
|
||
|
|
; doing
|
||
|
|
; (string-append doing
|
||
|
|
; " as "
|
||
|
|
; new-description
|
||
|
|
; " (prior references assumed "
|
||
|
|
; old-description
|
||
|
|
; ")"))
|
||
|
|
; name))))
|
||
|
|
;
|
||
|
|
;; Foo. This should really set SEEN for all the packages up the
|
||
|
|
;; inheritance chain.
|
||
|
|
;
|
||
|
|
;(define (assume-denotation p name info)
|
||
|
|
; (if (package-unstable? p) ;***** save space? and time?
|
||
|
|
; (table-set! (package-seen p) name info))
|
||
|
|
; info)
|
||
|
|
;
|
||
|
|
;; Little utility for warning messages.
|
||
|
|
;
|
||
|
|
;(define (binding-description-string d)
|
||
|
|
; (cond ((transform? d)
|
||
|
|
; (if (syntax? d) "macro" "integrated procedure"))
|
||
|
|
; ((operator? d)
|
||
|
|
; (if (syntax? d) "special operator" "primitive procedure"))
|
||
|
|
; (else "variable")))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define (package-undefine! p name)
|
||
|
|
(let ((probe (table-ref (package-definitions p) name)))
|
||
|
|
(if probe
|
||
|
|
(begin (table-set! (package-definitions p) name #f)
|
||
|
|
(set-location-defined?! (binding-place probe) #f)
|
||
|
|
(set-location-forward!
|
||
|
|
(binding-place probe)
|
||
|
|
(let ((new (package-lookup p name)))
|
||
|
|
(if (binding? new)
|
||
|
|
(binding-place new)
|
||
|
|
(location-for-reference p name)))
|
||
|
|
name p))
|
||
|
|
(warn "can't undefine - binding is inherited"
|
||
|
|
p name))))
|