262 lines
8.5 KiB
Scheme
262 lines
8.5 KiB
Scheme
|
|
|
|
|
|
(library (ikarus library-manager)
|
|
(export imported-label->binding library-subst
|
|
installed-libraries visit-library
|
|
library-name
|
|
find-library-by-name install-library
|
|
library-spec invoke-library
|
|
extend-library-subst! extend-library-env!
|
|
current-library-expander current-library-collection)
|
|
(import (except (ikarus) installed-libraries))
|
|
|
|
(define (make-collection)
|
|
(let ([set '()])
|
|
(define (set-cons x ls)
|
|
(cond
|
|
[(memq x ls) ls]
|
|
[else (cons x ls)]))
|
|
(case-lambda
|
|
[() set]
|
|
[(x) (set! set (set-cons x set))])))
|
|
|
|
(define current-library-collection
|
|
;;; this works now because make-collection is a lambda
|
|
;;; binding and this turns into a complex binding as far
|
|
;;; as letrec is concerned. It will be more ok once we do
|
|
;;; letrec*.
|
|
(make-parameter (make-collection)
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
(error 'current-library-collection "~s is not a procedure" x))
|
|
x)))
|
|
|
|
(define-record library
|
|
(id name ver imp* vis* inv* subst env visit-state invoke-state
|
|
visible?))
|
|
|
|
(define (find-dependencies ls)
|
|
(cond
|
|
[(null? ls) '()]
|
|
[else (error 'find-dependencies "cannot handle deps yet")]))
|
|
|
|
(define (find-library-by pred)
|
|
(let f ([ls ((current-library-collection))])
|
|
(cond
|
|
[(null? ls) #f]
|
|
[(pred (car ls)) (car ls)]
|
|
[else (f (cdr ls))])))
|
|
|
|
(define library-path
|
|
(make-parameter
|
|
'(".")
|
|
(lambda (x)
|
|
(if (and (list? x) (andmap string? x))
|
|
(map values x)
|
|
(error 'library-path "~s is not a list of strings" x)))))
|
|
|
|
(define (library-name->file-name x)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(define (display-hex n)
|
|
(cond
|
|
[(<= 0 n 9) (display n)]
|
|
[else (display
|
|
(integer->char
|
|
(+ (char->integer #\A)
|
|
(- n 10))))]))
|
|
(let f ([ls x])
|
|
(cond
|
|
[(null? ls) (display ".ss")]
|
|
[else
|
|
(display "/")
|
|
(for-each
|
|
(lambda (c)
|
|
(cond
|
|
[(or (char<=? #\a c #\z)
|
|
(char<=? #\A c #\Z)
|
|
(char<=? #\0 c #\9)
|
|
(memv c '(#\- #\. #\_ #\~)))
|
|
(display c)]
|
|
[else
|
|
(display "%")
|
|
(let ([n (char->integer c)])
|
|
(display-hex (quotient n 16))
|
|
(display-hex (remainder n 16)))]))
|
|
(string->list
|
|
(symbol->string (car ls))))
|
|
(f (cdr ls))])))))
|
|
(define file-locator
|
|
(make-parameter
|
|
(lambda (x)
|
|
(let ([str (library-name->file-name x)])
|
|
(let f ([ls (library-path)])
|
|
(and (pair? ls)
|
|
(let ([name (string-append (car ls) str)])
|
|
(if (file-exists? name)
|
|
name
|
|
(f (cdr ls))))))))
|
|
(lambda (f)
|
|
(if (procedure? f)
|
|
f
|
|
(error 'file-locator
|
|
"~s is not a procedure" f)))))
|
|
|
|
(define library-locator
|
|
(make-parameter
|
|
(lambda (x)
|
|
(let ([file-name ((file-locator) x)])
|
|
(and (string? file-name)
|
|
(with-input-from-file file-name read))))
|
|
(lambda (f)
|
|
(if (procedure? f)
|
|
f
|
|
(error 'library-locator
|
|
"~s is not a procedure" f)))))
|
|
|
|
(define current-library-expander
|
|
(make-parameter
|
|
(lambda (x)
|
|
(error 'library-expander "not initialized"))
|
|
(lambda (f)
|
|
(if (procedure? f)
|
|
f
|
|
(error 'library-expander
|
|
"~s is not a procedure" f)))))
|
|
|
|
(define external-pending-libraries
|
|
(make-parameter '()))
|
|
|
|
(define (find-external-library name)
|
|
(when (member name (external-pending-libraries))
|
|
(error #f "circular attempt to import library ~s detected"
|
|
name))
|
|
(parameterize ([external-pending-libraries
|
|
(cons name (external-pending-libraries))])
|
|
(let ([lib-expr ((library-locator) name)])
|
|
(unless lib-expr
|
|
(error #f "cannot find library ~s" name))
|
|
((current-library-expander) lib-expr)
|
|
(or (find-library-by
|
|
(lambda (x) (equal? (library-name x) name)))
|
|
(error #f "handling external library of ~s did not yield the currect library" name)))))
|
|
|
|
(define (find-library-by-name name)
|
|
(or (find-library-by
|
|
(lambda (x) (equal? (library-name x) name)))
|
|
(find-external-library name)))
|
|
|
|
(define (library-exists? name)
|
|
(and (find-library-by
|
|
(lambda (x) (equal? (library-name x) name)))
|
|
#t))
|
|
|
|
(define (find-library-by-spec/die spec)
|
|
(let ([id (car spec)])
|
|
(or (find-library-by
|
|
(lambda (x) (eq? id (library-id x))))
|
|
(error #f "cannot find library with spec ~s" spec))))
|
|
|
|
(define label->binding-table (make-hash-table))
|
|
|
|
(define (install-library-record lib)
|
|
(let ([exp-env (library-env lib)])
|
|
(for-each
|
|
(lambda (x)
|
|
(let ([label (car x)] [binding (cdr x)])
|
|
(let ([binding
|
|
(case (car binding)
|
|
[(global)
|
|
(cons 'global (cons lib (cdr binding)))]
|
|
[(global-macro)
|
|
(cons 'global-macro (cons lib (cdr binding)))]
|
|
[else binding])])
|
|
(put-hash-table! label->binding-table label binding))))
|
|
exp-env))
|
|
((current-library-collection) lib))
|
|
|
|
(define (install-library id name ver imp* vis* inv*
|
|
exp-subst exp-env visit-code invoke-code visible?)
|
|
(let ([imp-lib* (map find-library-by-spec/die imp*)]
|
|
[vis-lib* (map find-library-by-spec/die vis*)]
|
|
[inv-lib* (map find-library-by-spec/die inv*)])
|
|
(unless (and (symbol? id) (list? name) (list? ver))
|
|
(error 'install-library "invalid spec ~s ~s ~s" id name ver))
|
|
(when (library-exists? name)
|
|
(error 'install-library "~s is already installed" name))
|
|
(let ([lib (make-library id name ver imp-lib* vis-lib* inv-lib*
|
|
exp-subst exp-env visit-code invoke-code
|
|
visible?)])
|
|
(install-library-record lib))))
|
|
|
|
(define extend-library-subst!
|
|
(lambda (lib sym label)
|
|
(set-library-subst! lib
|
|
(cons (cons sym label) (library-subst lib)))))
|
|
|
|
(define extend-library-env!
|
|
(lambda (lib label binding)
|
|
(set-library-env! lib
|
|
(cons (cons label binding) (library-env lib)))
|
|
(put-hash-table! label->binding-table label binding)))
|
|
|
|
(define (imported-label->binding lab)
|
|
(get-hash-table label->binding-table lab #f))
|
|
|
|
(define (invoke-library lib)
|
|
(let ([invoke (library-invoke-state lib)])
|
|
(when (procedure? invoke)
|
|
(set-library-invoke-state! lib
|
|
(lambda () (error 'invoke "circularity detected for ~s" lib)))
|
|
(for-each invoke-library (library-inv* lib))
|
|
(set-library-invoke-state! lib
|
|
(lambda () (error 'invoke "first invoke did not return for ~s" lib)))
|
|
(invoke)
|
|
(set-library-invoke-state! lib #t))))
|
|
|
|
|
|
(define (visit-library lib)
|
|
(let ([visit (library-visit-state lib)])
|
|
(when (procedure? visit)
|
|
(set-library-visit-state! lib
|
|
(lambda () (error 'visit "circularity detected for ~s" lib)))
|
|
(for-each invoke-library (library-vis* lib))
|
|
(set-library-visit-state! lib
|
|
(lambda () (error 'invoke "first visit did not return for ~s" lib)))
|
|
(visit)
|
|
(set-library-visit-state! lib #t))))
|
|
|
|
|
|
(define (invoke-library-by-spec spec)
|
|
(invoke-library (find-library-by-spec/die spec)))
|
|
|
|
(define installed-libraries
|
|
(case-lambda
|
|
[(all?)
|
|
(let f ([ls ((current-library-collection))])
|
|
(cond
|
|
[(null? ls) '()]
|
|
[(or all? (library-visible? (car ls)))
|
|
(cons (car ls) (f (cdr ls)))]
|
|
[else (f (cdr ls))]))]
|
|
[() (installed-libraries #f)]))
|
|
|
|
(define library-spec
|
|
(lambda (x)
|
|
(unless (library? x)
|
|
(error 'library-spec "~s is not a library" x))
|
|
(list (library-id x) (library-name x) (library-ver x))))
|
|
|
|
;;; init
|
|
(set-rtd-printer! (type-descriptor library)
|
|
(lambda (x p)
|
|
(unless (library? x)
|
|
(error 'record-type-printer "not a library"))
|
|
(display
|
|
(format "#<library ~s>" (append (library-name x) (library-ver x)))
|
|
p)))
|
|
|
|
)
|
|
|