- implemented uninstall-library.

This commit is contained in:
Abdulaziz Ghuloum 2008-11-11 14:47:35 -05:00
parent 5d3e70fa83
commit c7d68432e3
5 changed files with 34 additions and 8 deletions

View File

@ -1 +1 @@
1667 1668

View File

@ -415,6 +415,7 @@
[wstatus-received-signal i] [wstatus-received-signal i]
[kill i] [kill i]
[installed-libraries i] [installed-libraries i]
[uninstall-library i]
[library-path i] [library-path i]
[library-extensions i] [library-extensions i]
[current-primitive-locations $boot] [current-primitive-locations $boot]

View File

@ -22,7 +22,8 @@
annotation-stripped annotation-stripped
read-library-source-file read-library-source-file
library-version-mismatch-warning library-version-mismatch-warning
file-locator-resolution-error) file-locator-resolution-error
label-binding set-label-binding!)
(import (import
(only (ikarus.compiler) eval-core) (only (ikarus.compiler) eval-core)
(only (ikarus.reader.annotated) read-library-source-file) (only (ikarus.reader.annotated) read-library-source-file)
@ -59,5 +60,10 @@
(set-rtd-printer! (type-descriptor name) (set-rtd-printer! (type-descriptor name)
printer)))] printer)))]
[(_ name (field* ...)) [(_ name (field* ...))
(define-struct name (field* ...))]))) (define-struct name (field* ...))]))
(define (set-label-binding! label binding)
(set-symbol-value! label binding))
(define (label-binding label)
(and (symbol-bound? label) (symbol-value label))))

View File

@ -643,6 +643,7 @@
(define label->binding (define label->binding
(lambda (x r) (lambda (x r)
(cond (cond
((not x) '(displaced-lexical))
((imported-label->binding x) => ((imported-label->binding x) =>
(lambda (b) (lambda (b)
(cond (cond

View File

@ -22,7 +22,7 @@
(export imported-label->binding library-subst installed-libraries (export imported-label->binding library-subst installed-libraries
visit-library library-name library-version library-exists? visit-library library-name library-version library-exists?
find-library-by-name install-library library-spec invoke-library find-library-by-name install-library library-spec invoke-library
current-library-expander current-library-expander uninstall-library
current-library-collection library-path library-extensions current-library-collection library-path library-extensions
serialize-all current-precompiled-library-loader) serialize-all current-precompiled-library-loader)
(import (rnrs) (psyntax compat) (rnrs r5rs)) (import (rnrs) (psyntax compat) (rnrs r5rs))
@ -35,7 +35,11 @@
(else (cons x ls)))) (else (cons x ls))))
(case-lambda (case-lambda
(() set) (() set)
((x) (set! set (set-cons x set)))))) ((x) (set! set (set-cons x set)))
((x del?)
(if del?
(set! set (remq x set))
(set! set (set-cons x set)))))))
(define current-library-collection (define current-library-collection
;;; this works now because make-collection is a lambda ;;; this works now because make-collection is a lambda
@ -264,6 +268,21 @@
(lambda (x) (equal? (library-name x) name))) (lambda (x) (equal? (library-name x) name)))
(find-external-library name))) (find-external-library name)))
(define uninstall-library
(case-lambda
[(name err?)
(define who 'uninstall-library)
;;; FIXME: check that no other import is in progress
;;; FIXME: need to unintern labels and locations of
;;; library bindings
(let ([lib
(find-library-by
(lambda (x) (equal? (library-name x) name)))])
(when (and err? (not lib))
(assertion-violation who "library not installed" name))
((current-library-collection) lib #t))]
[(name) (uninstall-library name #t)]))
(define (library-exists? name) (define (library-exists? name)
(and (find-library-by (and (find-library-by
(lambda (x) (equal? (library-name x) name))) (lambda (x) (equal? (library-name x) name)))
@ -276,7 +295,6 @@
(assertion-violation #f (assertion-violation #f
"cannot find library with required spec" spec)))) "cannot find library with required spec" spec))))
(define label->binding-table (make-eq-hashtable))
(define (install-library-record lib) (define (install-library-record lib)
(let ((exp-env (library-env lib))) (let ((exp-env (library-env lib)))
@ -292,7 +310,7 @@
((global-macro!) ((global-macro!)
(cons 'global-macro! (cons lib (cdr binding)))) (cons 'global-macro! (cons lib (cdr binding))))
(else binding)))) (else binding))))
(hashtable-set! label->binding-table label binding)))) (set-label-binding! label binding))))
exp-env)) exp-env))
((current-library-collection) lib)) ((current-library-collection) lib))
@ -316,7 +334,7 @@
(install-library-record lib)))))) (install-library-record lib))))))
(define (imported-label->binding lab) (define (imported-label->binding lab)
(hashtable-ref label->binding-table lab #f)) (label-binding lab))
(define (invoke-library lib) (define (invoke-library lib)
(let ((invoke (library-invoke-state lib))) (let ((invoke (library-invoke-state lib)))