conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* library manager now attempts to load imported libraries from file 

according to some library-name->file-name mapping.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-11 20:32:48 -04:00
parent 4ca7b2780e
commit 1932db8d65
4 changed files with 121 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

133
src/ikarus.library-manager.ss
View File

@ -6,7 +6,8 @@
installed-libraries visit-library
find-library-by-name install-library
library-spec invoke-library
extend-library-subst! extend-library-env!)
extend-library-subst! extend-library-env!
current-library-expander)
(import (except (ikarus) installed-libraries))
(define (make-collection)
@ -46,12 +47,104 @@
[(pred (car ls)) (car ls)]
[else (f (cdr ls))])))
(define (install-library-by-name name)
#f)
(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 #\A)
(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)
(find-library-by
(lambda (x) (equal? (library-name x) name))))
(or (find-library-by
(lambda (x) (equal? (library-name x) name)))
(find-external-library name)))
(define (library-exists? name)
(and (find-library-by
@ -66,6 +159,22 @@
(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*)]
@ -78,19 +187,7 @@
(let ([lib (make-library id name ver imp-lib* vis-lib* inv-lib*
exp-subst exp-env visit-code invoke-code
visible?)])
(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))))
(install-library-record lib))))
(define extend-library-subst!
(lambda (lib sym label)

5
src/ikarus.syntax.ss
View File

@ -2231,7 +2231,6 @@
(cond
[loc (set-symbol-value! loc (eval-core expr))]
[else (eval-core expr)])))
(let ([rtc (make-collector)]
[vtc (make-collector)])
(let ([init*
@ -2247,6 +2246,10 @@
(for-each eval-binding (reverse (cdr init*)))
(eval-binding (car init*))])))))
;;; FIXME: export the rest of the syntax-case procedures
(current-library-expander
(lambda (x)
(library-expander x)
(void)))
)

2
src/makefile.ss
View File

@ -332,6 +332,7 @@
[open-output-file i r]
[open-output-string i]
[get-output-string i]
[with-output-to-string i]
[close-input-port i r]
[close-output-port i r]
[console-input-port i]
@ -343,6 +344,7 @@
[standard-error-port i]
[flush-output-port i]
[reset-input-port! i]
[file-exists? i]
[display i r]
[write i r]
[write-char i]