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

* install-library now takes an extra visibility flag. 

* installed-libraries now takes an optional "all?" flag:
  - if all? is true, it returns all libraries.
  - if all? is false, it returns only the visible libraries
  - all? defaults to #t.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-07 04:52:22 -04:00
parent 4c8029ab3e
commit 8226619438
6 changed files with 69 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
bin/ikarus
View File

Binary file not shown.

1
bin/ikarus-fasl.c
View File

@ -73,6 +73,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
bzero(p.marks, p.marks_size * sizeof(ikp*));
}
ikp val = ik_exec_code(pcb, v);
val = void_object;
if(val != void_object){
ik_print(val);
}

BIN
src/ikarus.boot
View File

Binary file not shown.

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

@ -3,7 +3,7 @@
(library (ikarus library-manager)
(export imported-label->binding library-subst
installed-libraries
installed-libraries
find-library-by-name install-library
library-spec invoke-library)
(import (except (ikarus) installed-libraries))
@ -30,7 +30,8 @@
x)))
(define-record library
(id name ver imp* vis* inv* subst env visit-state invoke-state))
(id name ver imp* vis* inv* subst env visit-state invoke-state
visible?))
(define (find-dependencies ls)
(cond
@ -64,28 +65,36 @@
(define label->binding-table (make-hash-table))
(define (install-library id name ver
imp* vis* inv* exp-subst exp-env visit-code invoke-code)
(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)])
(for-each
(lambda (x)
(let ([label (car x)] [binding (cdr x)])
(let ([binding
(case (car binding)
[(global)
(cons 'global (cons lib (cdr binding)))]
[else binding])])
(put-hash-table! label->binding-table label binding))))
exp-env)
((current-library-collection) lib))))
(define install-library
(case-lambda
; [(id name ver imp* vis* inv* exp-subst exp-env
; visit-code invoke-code)
; (install-library id name ver imp* vis* inv* exp-subst exp-env
; visit-code invoke-code #t)]
[(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?)])
(for-each
(lambda (x)
(let ([label (car x)] [binding (cdr x)])
(let ([binding
(case (car binding)
[(global)
(cons 'global (cons lib (cdr binding)))]
[else binding])])
(put-hash-table! label->binding-table label binding))))
exp-env)
((current-library-collection) lib)
lib))]))
(define (imported-label->binding lab)
(get-hash-table label->binding-table lab #f))
@ -105,7 +114,16 @@
(invoke-library (find-library-by-spec/die spec)))
(define installed-libraries
(lambda () ((current-library-collection))))
(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)

3
src/ikarus.syntax.ss
View File

@ -2166,7 +2166,8 @@
(install-library id name ver
imp* vis* inv* export-subst export-env
void ;;; FIXME
(lambda () (eval-core invoke-code)))
(lambda () (eval-core invoke-code))
#t)
(values invoke-code export-subst export-env))))
(define (boot-library-expand x)
(let-values ([(invoke-code export-subst export-env)

44
src/makefile.ss
View File

@ -97,25 +97,25 @@
[or (macro . or)]))
(define library-legend
'([i (ikarus)]
[r (r6rs)]
[$all (ikarus system $all)]
[$pairs (ikarus system $pairs)]
[$lists (ikarus system $lists)]
[$chars (ikarus system $chars)]
[$strings (ikarus system $strings)]
[$vectors (ikarus system $vectors)]
[$fx (ikarus system $fx)]
[$symbols (ikarus system $symbols)]
[$records (ikarus system $records)]
[$ports (ikarus system $ports)]
[$codes (ikarus system $codes)]
[$tcbuckets (ikarus system $tcbuckets)]
[$io (ikarus system $io)]
[$arg-list (ikarus system $arg-list)]
[$stack (ikarus system $stack)]
[$interrupts (ikarus system $interrupts)]
[$boot (ikarus system $bootstrap)]
'([i (ikarus) #t]
[r (r6rs) #t]
[$all (ikarus system $all) #f]
[$pairs (ikarus system $pairs) #f]
[$lists (ikarus system $lists) #f]
[$chars (ikarus system $chars) #f]
[$strings (ikarus system $strings) #f]
[$vectors (ikarus system $vectors) #f]
[$fx (ikarus system $fx) #f]
[$symbols (ikarus system $symbols) #f]
[$records (ikarus system $records) #f]
[$ports (ikarus system $ports) #f]
[$codes (ikarus system $codes) #f]
[$tcbuckets (ikarus system $tcbuckets) #f]
[$io (ikarus system $io) #f]
[$arg-list (ikarus system $arg-list) #f]
[$stack (ikarus system $stack) #f]
[$interrupts (ikarus system $interrupts) #f]
[$boot (ikarus system $bootstrap) #f]
))
(define ikarus-macros-map
@ -629,7 +629,9 @@
(define (build-system-library export-subst export-env primlocs)
(define (build-library legend-entry)
(let ([key (car legend-entry)] [name (cadr legend-entry)])
(let ([key (car legend-entry)]
[name (cadr legend-entry)]
[visible? (caddr legend-entry)])
(let ([id (gensym)]
[name name]
[version '()]
@ -644,7 +646,7 @@
'()))])
`(install-library
',id ',name ',version ',import-libs ',visit-libs ',invoke-libs
',subst ',env void void)))))
',subst ',env void void ',visible?)))))
(let ([code `(library (ikarus primlocs)
(export) ;;; must be empty
(import