scsh-0.6/scheme/env/pedit.scm

; Copyright (c) 1993-2001 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))
		(call-with-values
		 (lambda ()
		   (interface-ref (structure-interface (car opens))
				  name))
		 (lambda (base-name type)
		   (if base-name
		       ;; Shadowing
		       (let* ((q (structure-package (car opens)))
			      (probe (table-ref (package-undefineds q)
						base-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-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?*
      (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 ((interface? loser)
	 (walk-population verify-loser (interface-clients loser)))
	((structure? loser)
	 (reinitialize-structure! 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 ()
    (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))))