* added initial code for a library manager

This commit is contained in:
Abdulaziz Ghuloum 2007-05-02 04:48:41 -04:00
parent 8383fd79d6
commit 896a4408fd
5 changed files with 61 additions and 4 deletions

Binary file not shown.

53
src/library-manager.ss Normal file
View File

@ -0,0 +1,53 @@
(library (ikarus library-manager)
(export)
(import (scheme))
(define-record library
(id name ver imp* vis* inv* exp-subst exp-env visit-state invoke-state))
(define (find-dependencies ls)
(cond
[(null? ls) '()]
[else (error 'find-dependencies "cannot handle deps yet")]))
(define *all-libraries* '())
(define (find-library-by pred)
(let f ([ls *all-libraries*])
(cond
[(null? ls) #f]
[(pred (car ls)) (car ls)]
[else (f (cdr ls))])))
(define (find-library-by-name name)
(find-library-by
(lambda (x) (equal? (library-name x) name))))
(define (find-library-by-name/die name)
(or (find-library-by-name name)
(error #f "cannot find library ~s" name)))
(define (lm:install-library id name ver
imp* vis* inv* exp-subst exp-env visit-code invoke-code)
(let ([imp-lib* (map find-library-by-name/die imp*)]
[vis-lib* (map find-library-by-name/die vis*)]
[inv-lib* (map find-library-by-name/die inv*)])
(unless (and (symbol? id) (list? name) (list? ver))
(error 'install-library "invalid spec ~s ~s ~s" id name ver))
(when (find-library-by-name 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)])
(set! *all-libraries* (cons lib *all-libraries*)))))
(lm:install-library (gensym "null") ;;; id
'(null) '() ;;; name/version
'() ;;; import libs
'() ;;; visit libs
'() ;;; invoke libs
'() ;;; subst
'() ;;; env
void void)
;(printf "ALL LIBRARIES:\n~s\n" *all-libraries*)
(primitive-set! 'install-library lm:install-library)
)

View File

@ -940,7 +940,8 @@
[new-cafe new-cafe-label (core-prim . new-cafe)]
[command-line-arguments command-line-arguments-label (core-prim . command-line-arguments)]
[list*->code* list*->code*-label (core-prim . list*->code*)]
[primitive-location primitive-location-label (core-prim . primitive-location)]
;[primitive-location primitive-location-label (core-prim . primitive-location)]
[install-library install-library-label (core-prim . install-library)]
;;; record/mid-level
[record? record?-label (core-prim . record?)]
[make-record-type make-record-type-label (core-prim . make-record-type)]
@ -1017,6 +1018,7 @@
[$frame->continuation $frame->continuation-label (core-prim . $frame->continuation)]
[$current-frame $current-frame-label (core-prim . $current-frame)]
[$seal-frame-and-call $seal-frame-and-call-label (core-prim . $seal-frame-and-call)]
[foo foo-label (core-prim . foo)]
))
(define make-scheme-rib
(lambda ()

View File

@ -5,10 +5,10 @@
;;; Finally, we're ready to evaluate the files and enter the cafe.
(library (ikarus interaction)
(export foo)
(export bar)
(import (scheme))
(define foo 'i-am-an-exported-primitive-named-foo)
(define bar 'i-am-an-exported-primitive-named-foo)
(define sc-expand
(lambda (x)
(if (and (pair? x) (equal? (car x) "noexpand"))

View File

@ -43,6 +43,7 @@
"libcafe.ss"
"libposix.ss"
"libtimers.ss"
"library-manager.ss"
"libtoplevel.ss"))
(define (read-file file)
@ -80,7 +81,8 @@
[else #f])))]
[else #f]))
(lambda (x)
(if (procedure? x) x
(if (procedure? x)
x
(error 'primitive-location
"~s is not a procedure" x)))))))