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

Ikarus now recognizes ".sls", ".ss", and ".scm" extensions as well 

as ".ikarus.sls", ".ikarus.ss", and ".ikarus.scm".
This commit is contained in:
Abdulaziz Ghuloum 2007-12-27 15:16:08 -05:00
parent 2a96ebf5b1
commit fc2d958419
5 changed files with 44 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

9
scheme/ikarus.main.ss
View File

@ -54,9 +54,12 @@
(cons "."
(append
(split (getenv "IKARUS_LIBRARY_PATH"))
(list ikarus-lib-dir)))))
)
(list ikarus-lib-dir))))
(library-extensions
(append
(map (lambda (x) (string-append ".ikarus" x))
(library-extensions))
(library-extensions)))))
;;; Finally, we're ready to evaluate the files and enter the cafe.

2
scheme/last-revision
View File

@ -1 +1 @@
1291
1292

1
scheme/makefile.ss
View File

@ -397,6 +397,7 @@
[waitpid i]
[installed-libraries i]
[library-path i]
[library-extensions i]
[current-primitive-locations $boot]
[boot-library-expand $boot]
[current-library-collection $boot]

61
scheme/psyntax.library-manager.ss
View File

@ -23,7 +23,7 @@
visit-library library-name library-version library-exists?
find-library-by-name install-library library-spec invoke-library
extend-library-subst! extend-library-env! current-library-expander
current-library-collection library-path)
current-library-collection library-path library-extensions)
(import (rnrs) (psyntax compat) (rnrs r5rs))
(define (make-collection)
@ -79,6 +79,15 @@
(map (lambda (x) x) x)
(assertion-violation 'library-path "not a list of strings" x)))))
(define library-extensions
(make-parameter
'(".sls" ".ss" ".scm")
(lambda (x)
(if (and (list? x) (for-all string? x))
(map (lambda (x) x) x)
(assertion-violation 'library-extensions
"not a list of strings" x)))))
(define (library-name->file-name x)
(let-values (((p extract) (open-string-output-port)))
(define (display-hex n)
@ -90,35 +99,35 @@
(- n 10)))
p))))
(let f ((ls x))
(cond
((null? ls) (display ".ss" p))
(else
(display "/" p)
(for-each
(lambda (c)
(cond
((or (char<=? #\a c #\z)
(char<=? #\A c #\Z)
(char<=? #\0 c #\9)
(memv c '(#\- #\. #\_ #\~)))
(display c p))
(else
(display "%" p)
(let ((n (char->integer c)))
(display-hex (quotient n 16))
(display-hex (remainder n 16))))))
(string->list
(symbol->string (car ls))))
(f (cdr ls)))))
(unless (null? ls)
(display "/" p)
(for-each
(lambda (c)
(cond
((or (char<=? #\a c #\z)
(char<=? #\A c #\Z)
(char<=? #\0 c #\9)
(memv c '(#\- #\. #\_ #\~)))
(display c p))
(else
(display "%" p)
(let ((n (char->integer c)))
(display-hex (quotient n 16))
(display-hex (remainder n 16))))))
(string->list
(symbol->string (car ls))))
(f (cdr ls))))
(extract)))
(define file-locator
(make-parameter
(lambda (x)
(let ((str (library-name->file-name x)))
(let f ((ls (library-path)) (failed-list '()))
(let f ((ls (library-path))
(exts (library-extensions))
(failed-list '()))
(cond
((null? ls)
((null? ls)
(let ()
(define-condition-type &library-resolution &condition
make-library-resolution-condition
@ -133,11 +142,13 @@
"cannot locate library in library-path")
(make-library-resolution-condition
x (reverse failed-list))))))
((null? exts)
(f (cdr ls) (library-extensions) failed-list))
(else
(let ((name (string-append (car ls) str)))
(let ((name (string-append (car ls) str (car exts))))
(if (file-exists? name)
name
(f (cdr ls) (cons name failed-list)))))))))
(f ls (cdr exts) (cons name failed-list)))))))))
(lambda (f)
(if (procedure? f)
f