mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-06 20:20:20 +02:00
* boot-9.scm (module-duplicates-info, set-module-duplicates-info!): Removed.
(module-duplicates-handlers, module-duplicates-interface): New. (module-type): Added duplicates-handlers and duplicates-interface.
This commit is contained in:
parent
d57da08b6d
commit
8d8dac1f2f
2 changed files with 30 additions and 21 deletions
|
@ -9,6 +9,10 @@
|
||||||
module-defer-observers-table): New variables.
|
module-defer-observers-table): New variables.
|
||||||
(process-define-module, process-use-modules, export, re-export):
|
(process-define-module, process-use-modules, export, re-export):
|
||||||
Use call-with-deferred-observers.
|
Use call-with-deferred-observers.
|
||||||
|
(module-duplicates-info, set-module-duplicates-info!): Removed.
|
||||||
|
(module-duplicates-handlers, module-duplicates-interface): New.
|
||||||
|
(module-type): Added duplicates-handlers and
|
||||||
|
duplicates-interface.
|
||||||
|
|
||||||
* syncase.scm (eval): Mark as replacement.
|
* syncase.scm (eval): Mark as replacement.
|
||||||
|
|
||||||
|
|
|
@ -971,6 +971,7 @@
|
||||||
(define module-type
|
(define module-type
|
||||||
(make-record-type 'module
|
(make-record-type 'module
|
||||||
'(obarray uses binder eval-closure transformer name kind
|
'(obarray uses binder eval-closure transformer name kind
|
||||||
|
duplicates-handlers duplicates-interface
|
||||||
observers weak-observers observer-id)
|
observers weak-observers observer-id)
|
||||||
%print-module))
|
%print-module))
|
||||||
|
|
||||||
|
@ -1005,7 +1006,7 @@
|
||||||
|
|
||||||
(let ((module (module-constructor (and (not (zero? size))
|
(let ((module (module-constructor (and (not (zero? size))
|
||||||
(make-hash-table size))
|
(make-hash-table size))
|
||||||
uses binder #f #f #f #f
|
uses binder #f #f #f #f #f #f
|
||||||
'()
|
'()
|
||||||
(make-weak-value-hash-table 31)
|
(make-weak-value-hash-table 31)
|
||||||
0)))
|
0)))
|
||||||
|
@ -1034,6 +1035,14 @@
|
||||||
(define set-module-name! (record-modifier module-type 'name))
|
(define set-module-name! (record-modifier module-type 'name))
|
||||||
(define module-kind (record-accessor module-type 'kind))
|
(define module-kind (record-accessor module-type 'kind))
|
||||||
(define set-module-kind! (record-modifier module-type 'kind))
|
(define set-module-kind! (record-modifier module-type 'kind))
|
||||||
|
(define module-duplicates-handlers
|
||||||
|
(record-accessor module-type 'duplicates-handlers))
|
||||||
|
(define set-module-duplicates-handlers!
|
||||||
|
(record-modifier module-type 'duplicates-handlers))
|
||||||
|
(define module-duplicates-interface
|
||||||
|
(record-accessor module-type 'duplicates-interface))
|
||||||
|
(define set-module-duplicates-interface!
|
||||||
|
(record-modifier module-type 'duplicates-interface))
|
||||||
(define module-observers (record-accessor module-type 'observers))
|
(define module-observers (record-accessor module-type 'observers))
|
||||||
(define set-module-observers! (record-modifier module-type 'observers))
|
(define set-module-observers! (record-modifier module-type 'observers))
|
||||||
(define module-weak-observers (record-accessor module-type 'weak-observers))
|
(define module-weak-observers (record-accessor module-type 'weak-observers))
|
||||||
|
@ -1485,12 +1494,11 @@
|
||||||
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
|
;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
|
||||||
;;
|
;;
|
||||||
(define (module-use-interfaces! module interfaces)
|
(define (module-use-interfaces! module interfaces)
|
||||||
(let* ((duplicates-info (module-duplicates-info module))
|
(let* ((duplicates-handlers? (or (module-duplicates-handlers module)
|
||||||
(duplicates-handlers? (or (car duplicates-info)
|
|
||||||
(default-duplicate-binding-procedures)))
|
(default-duplicate-binding-procedures)))
|
||||||
(uses (module-uses module)))
|
(uses (module-uses module)))
|
||||||
;; remove duplicates-interface
|
;; remove duplicates-interface
|
||||||
(set! uses (delq! (cdr duplicates-info) uses))
|
(set! uses (delq! (module-duplicates-interface module) uses))
|
||||||
;; remove interfaces to be added
|
;; remove interfaces to be added
|
||||||
(for-each (lambda (interface)
|
(for-each (lambda (interface)
|
||||||
(set! uses
|
(set! uses
|
||||||
|
@ -1509,8 +1517,9 @@
|
||||||
(set-module-uses! module uses))
|
(set-module-uses! module uses))
|
||||||
interfaces)
|
interfaces)
|
||||||
;; add duplicates interface
|
;; add duplicates interface
|
||||||
(if (cdr duplicates-info)
|
(if (module-duplicates-interface module)
|
||||||
(set-module-uses! module (cons (cdr duplicates-info) uses)))
|
(set-module-uses! module
|
||||||
|
(cons (module-duplicates-interface module) uses)))
|
||||||
(module-modified module)))
|
(module-modified module)))
|
||||||
|
|
||||||
|
|
||||||
|
@ -1600,16 +1609,11 @@
|
||||||
(module-ref m '%module-public-interface #f))
|
(module-ref m '%module-public-interface #f))
|
||||||
(define (set-module-public-interface! m i)
|
(define (set-module-public-interface! m i)
|
||||||
(module-define! m '%module-public-interface i))
|
(module-define! m '%module-public-interface i))
|
||||||
(define (module-duplicates-info m)
|
|
||||||
(or (module-ref m '%module-duplicates-info #f) (cons #f #f)))
|
|
||||||
(define (set-module-duplicates-info! m i)
|
|
||||||
(module-define! m '%module-duplicates-info i))
|
|
||||||
(define (set-system-module! m s)
|
(define (set-system-module! m s)
|
||||||
(set-procedure-property! (module-eval-closure m) 'system-module s))
|
(set-procedure-property! (module-eval-closure m) 'system-module s))
|
||||||
(define the-root-module (make-root-module))
|
(define the-root-module (make-root-module))
|
||||||
(define the-scm-module (make-scm-module))
|
(define the-scm-module (make-scm-module))
|
||||||
(set-module-public-interface! the-root-module the-scm-module)
|
(set-module-public-interface! the-root-module the-scm-module)
|
||||||
(set-module-duplicates-info! the-root-module (cons #f #f))
|
|
||||||
(set-module-name! the-root-module '(guile))
|
(set-module-name! the-root-module '(guile))
|
||||||
(set-module-name! the-scm-module '(guile))
|
(set-module-name! the-scm-module '(guile))
|
||||||
(set-module-kind! the-scm-module 'interface)
|
(set-module-kind! the-scm-module 'interface)
|
||||||
|
@ -1638,8 +1642,7 @@
|
||||||
(let ((interface (make-module 31)))
|
(let ((interface (make-module 31)))
|
||||||
(set-module-name! interface (module-name module))
|
(set-module-name! interface (module-name module))
|
||||||
(set-module-kind! interface 'interface)
|
(set-module-kind! interface 'interface)
|
||||||
(set-module-public-interface! module interface)
|
(set-module-public-interface! module interface))))
|
||||||
(set-module-duplicates-info! module (cons #f #f)))))
|
|
||||||
(if (and (not (memq the-scm-module (module-uses module)))
|
(if (and (not (memq the-scm-module (module-uses module)))
|
||||||
(not (eq? module the-root-module)))
|
(not (eq? module the-root-module)))
|
||||||
(set-module-uses! module
|
(set-module-uses! module
|
||||||
|
@ -1853,7 +1856,8 @@
|
||||||
((#:duplicates)
|
((#:duplicates)
|
||||||
(if (not (pair? (cdr kws)))
|
(if (not (pair? (cdr kws)))
|
||||||
(unrecognized kws))
|
(unrecognized kws))
|
||||||
(set-car! (module-duplicates-info module)
|
(set-module-duplicates-handlers!
|
||||||
|
module
|
||||||
(lookup-duplicates-handlers (cadr kws)))
|
(lookup-duplicates-handlers (cadr kws)))
|
||||||
(loop (cddr kws) reversed-interfaces exports re-exports replacements))
|
(loop (cddr kws) reversed-interfaces exports re-exports replacements))
|
||||||
((#:export #:export-syntax)
|
((#:export #:export-syntax)
|
||||||
|
@ -1901,7 +1905,7 @@
|
||||||
;; Replace autoload-interface with interface
|
;; Replace autoload-interface with interface
|
||||||
(set-car! (memq a (module-uses module)) i)
|
(set-car! (memq a (module-uses module)) i)
|
||||||
(module-local-variable i sym))))))
|
(module-local-variable i sym))))))
|
||||||
(module-constructor #() '() b #f #f name 'autoload
|
(module-constructor #() '() b #f #f name 'autoload #f #f
|
||||||
'() (make-weak-value-hash-table 31) 0)))
|
'() (make-weak-value-hash-table 31) 0)))
|
||||||
|
|
||||||
;;; {Compiled module}
|
;;; {Compiled module}
|
||||||
|
@ -2925,10 +2929,9 @@
|
||||||
m))
|
m))
|
||||||
|
|
||||||
(define (process-duplicates module interface)
|
(define (process-duplicates module interface)
|
||||||
(let* ((duplicates-info (module-duplicates-info module))
|
(let* ((duplicates-handlers (or (module-duplicates-handlers module)
|
||||||
(duplicates-handlers (or (car duplicates-info)
|
|
||||||
(default-duplicate-binding-procedures)))
|
(default-duplicate-binding-procedures)))
|
||||||
(duplicates-interface (cdr duplicates-info)))
|
(duplicates-interface (module-duplicates-interface module)))
|
||||||
(module-for-each
|
(module-for-each
|
||||||
(lambda (name var)
|
(lambda (name var)
|
||||||
(cond ((module-import-interface module name)
|
(cond ((module-import-interface module name)
|
||||||
|
@ -2942,7 +2945,9 @@
|
||||||
(begin
|
(begin
|
||||||
(set! duplicates-interface
|
(set! duplicates-interface
|
||||||
(make-duplicates-interface))
|
(make-duplicates-interface))
|
||||||
(set-cdr! duplicates-info duplicates-interface)))
|
(set-module-duplicates-interface!
|
||||||
|
module
|
||||||
|
duplicates-interface)))
|
||||||
(let* ((var (module-local-variable duplicates-interface
|
(let* ((var (module-local-variable duplicates-interface
|
||||||
name))
|
name))
|
||||||
(val (and var
|
(val (and var
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue