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

* re-integrated the library-manager from the psyntax distro.

This commit is contained in:
Abdulaziz Ghuloum 2007-10-09 07:56:30 -04:00
parent 658ad73ed2
commit 09fd6ff1b3
8 changed files with 163 additions and 139 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.

32
src/ikarus.hash-tables.ss
View File

@ -1,13 +1,14 @@
(library (ikarus hash-tables)
(export hash-table? make-hash-table get-hash-table put-hash-table!)
(export hash-table? make-hash-table get-hash-table put-hash-table!
make-hashtable hashtable-ref hashtable-set!)
(import
(ikarus system $pairs)
(ikarus system $vectors)
(ikarus system $tcbuckets)
(ikarus system $fx)
(except (ikarus) hash-table? make-hash-table get-hash-table
put-hash-table!))
make-hashtable put-hash-table! hashtable-ref hashtable-set!))
(define-record hasht (vec count tc))
@ -27,29 +28,6 @@
(syntax-rules ()
[(_ x) x]))
#;(define-syntax inthash
(syntax-rules ()
[(_ x) ($fxinthash x)]))
#;(define inthash
(lambda (key)
;static int inthash(int key) { /* from Bob Jenkin's */
; key += ~(key << 15);
; key ^= (key >> 10);
; key += (key << 3);
; key ^= (key >> 6);
; key += ~(key << 11);
; key ^= (key >> 16);
; return key;
;}
(let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
[key ($fxlogxor key ($fxsra key 10))]
[key ($fx+ key ($fxsll key 3))]
[key ($fxlogxor key ($fxsra key 6))]
[key ($fx+ key ($fxlognot ($fxsll key 11)))]
[key ($fxlogxor key ($fxsra key 16))])
key)))
;;; assq-like lookup
(define direct-lookup
(lambda (x b)
@ -219,4 +197,8 @@
(put-hash! h x v)
(error 'put-hash-table! "~s is not a hash table" h))))
(define hashtable-ref get-hash-table)
(define hashtable-set! put-hash-table!)
(define make-hashtable make-hash-table)
)

11
src/ikarus.io.output-strings.ss
View File

@ -1,6 +1,7 @@
(library (ikarus io output-strings)
(export open-output-string get-output-string with-output-to-string)
(export open-output-string get-output-string with-output-to-string
open-string-output-port)
(import
(ikarus system $strings)
(ikarus system $bytevectors)
@ -9,7 +10,8 @@
(ikarus system $pairs)
(ikarus system $ports)
(ikarus system $io)
(except (ikarus) open-output-string get-output-string with-output-to-string))
(except (ikarus) open-output-string get-output-string with-output-to-string
open-string-output-port))
(define-syntax message-case
(syntax-rules (else)
@ -165,5 +167,10 @@
(parameterize ([current-output-port p]) (f))
(get-output-string p))))
(define (open-string-output-port)
(let ([p (open-output-string)])
;;; FIXME: should empty string
(values p (lambda () (get-output-string p)))))
)

9
src/ikarus.lists.ss
View File

@ -3,14 +3,15 @@
(export $memq list? list cons* make-list append length list-ref reverse
last-pair memq memp memv member find assq assp assv assoc
remq remv remove remp filter map for-each andmap ormap list-tail
partition)
partition for-all exists)
(import
(ikarus system $fx)
(ikarus system $pairs)
(except (ikarus) list? list cons* make-list append reverse
last-pair length list-ref memq memp memv member find
assq assp assv assoc remq remv remove remp filter
map for-each andmap ormap list-tail partition))
map for-each andmap ormap list-tail partition
for-all exists))
(define $memq
(lambda (x ls)
@ -851,5 +852,9 @@
(error 'partition "~s is not a procedure" p))
(race ls ls ls p))))
;;; FIXME: lost in crash.
(define for-all andmap)
(define exists ormap)
)

5
src/ikarus.syntax.ss
View File

@ -17,12 +17,13 @@
environment environment? identifier? eval
generate-temporaries free-identifier=? bound-identifier=?
datum->syntax syntax->datum make-variable-transformer
null-environment)
null-environment define-record)
(psyntax compat)
(rnrs base)
(rnrs lists)
(rnrs control)
(rnrs io simple)
(except (ikarus library-manager) installed-libraries)
(except (psyntax library-manager) installed-libraries)
(only (ikarus system $bootstrap) eval-core)
(chez modules)
(ikarus symbols)

7
src/makefile.ss
View File

@ -63,8 +63,7 @@
"ikarus.fasl.write.ss"
"ikarus.fasl.ss"
"ikarus.compiler.ss"
"ikarus.library-manager.ss"
;"psyntax.library-manager.ss"
"psyntax.library-manager.ss"
"ikarus.syntax.ss"
"ikarus.load.ss"
"ikarus.pretty-print.ss"
@ -217,7 +216,7 @@
[foreign-call i]
[type-descriptor i]
[parameterize i parameters]
[define-record i r]
[define-record i]
[include i r]
[time i]
[trace-lambda i]
@ -2027,7 +2026,7 @@
(let ([code `(library (ikarus primlocs)
(export) ;;; must be empty
(import
(only (ikarus library-manager)
(only (psyntax library-manager)
install-library)
(only (ikarus compiler)
current-primitive-locations)

221
src/ikarus.library-manager.ss → src/psyntax.library-manager.ss
View File

@ -1,25 +1,39 @@
;;; Copyright (c) 2006, 2007 Abdulaziz Ghuloum and Kent Dybvig
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
(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))
(library (psyntax library-manager)
(export imported-label->binding library-subst installed-libraries
visit-library library-name library-exists? find-library-by-name
install-library library-spec invoke-library extend-library-subst!
extend-library-env! current-library-expander current-library-collection)
(import (rnrs) (psyntax compat) (rnrs r5rs))
(define (make-collection)
(let ([set '()])
(let ((set '()))
(define (set-cons x ls)
(cond
[(memq x ls) ls]
[else (cons x ls)]))
((memq x ls) ls)
(else (cons x ls))))
(case-lambda
[() set]
[(x) (set! set (set-cons x set))])))
(() set)
((x) (set! set (set-cons x set))))))
(define current-library-collection
;;; this works now because make-collection is a lambda
@ -33,80 +47,87 @@
x)))
(define-record library
(id name ver imp* vis* inv* subst env visit-state invoke-state
visible?))
(id name ver imp* vis* inv* subst env visit-state invoke-state visible?)
(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)))
(define (find-dependencies ls)
(cond
[(null? ls) '()]
[else (error 'find-dependencies "cannot handle deps yet")]))
((null? ls) '())
(else (error 'find-dependencies "cannot handle deps yet"))))
(define (find-library-by pred)
(let f ([ls ((current-library-collection))])
(let f ((ls ((current-library-collection))))
(cond
[(null? ls) #f]
[(pred (car ls)) (car ls)]
[else (f (cdr ls))])))
((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)
(if (and (list? x) (for-all string? x))
;(map values x)
(map (lambda (x) x) 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))])))))
(let-values (((p extract) (open-string-output-port)))
(define (display-hex n)
(cond
((<= 0 n 9) (display n p))
(else (display
(integer->char
(+ (char->integer #\A)
(- 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)))))
(extract)))
(define file-locator
(make-parameter
(lambda (x)
(let ([str (library-name->file-name x)])
(let f ([ls (library-path)])
(let ((str (library-name->file-name x)))
(let f ((ls (library-path)))
(and (pair? ls)
(let ([name (string-append (car ls) str)])
(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)))))
(error 'file-locator "~s is not a procedure" f)))))
(define library-locator
(make-parameter
(lambda (x)
(let ([file-name ((file-locator) x)])
(let ((file-name ((file-locator) x)))
(and (string? file-name)
(with-input-from-file file-name read))))
(lambda (f)
@ -132,9 +153,9 @@
(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)])
(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)
@ -153,41 +174,43 @@
#t))
(define (find-library-by-spec/die spec)
(let ([id (car 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 label->binding-table (make-hashtable))
(define (install-library-record lib)
(let ([exp-env (library-env lib)])
(let ((exp-env (library-env lib)))
(for-each
(lambda (x)
(let ([label (car x)] [binding (cdr x)])
(let ([binding
(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))))
((global)
(cons 'global (cons lib (cdr binding))))
((global-macro)
(cons 'global-macro (cons lib (cdr binding))))
((global-macro!)
(cons 'global-macro! (cons lib (cdr binding))))
(else binding))))
(hashtable-set! 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*)])
(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*
(let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib*
exp-subst exp-env visit-code invoke-code
visible?)])
visible?)))
(install-library-record lib))))
(define extend-library-subst!
@ -199,13 +222,13 @@
(lambda (lib label binding)
(set-library-env! lib
(cons (cons label binding) (library-env lib)))
(put-hash-table! label->binding-table label binding)))
(hashtable-set! label->binding-table label binding)))
(define (imported-label->binding lab)
(get-hash-table label->binding-table lab #f))
(hashtable-ref label->binding-table lab #f))
(define (invoke-library lib)
(let ([invoke (library-invoke-state lib)])
(let ((invoke (library-invoke-state lib)))
(when (procedure? invoke)
(set-library-invoke-state! lib
(lambda () (error 'invoke "circularity detected for ~s" lib)))
@ -217,7 +240,7 @@
(define (visit-library lib)
(let ([visit (library-visit-state lib)])
(let ((visit (library-visit-state lib)))
(when (procedure? visit)
(set-library-visit-state! lib
(lambda () (error 'visit "circularity detected for ~s" lib)))
@ -233,29 +256,19 @@
(define installed-libraries
(case-lambda
[(all?)
(let f ([ls ((current-library-collection))])
((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)]))
((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)))
(list (library-id x) (library-name x) (library-ver x))))
)

17
src/psyntax/compat.ss Normal file
View File

@ -0,0 +1,17 @@
(library (psyntax compat)
(export define-record make-parameter parameterize format)
(import
(rename (ikarus) (define-record sys.define-record)))
(define-syntax define-record
(syntax-rules ()
[(_ name (field* ...) printer)
(begin
(sys.define-record name (field* ...))
(module ()
(set-rtd-printer! (type-descriptor name)
printer)))]
[(_ name (field* ...))
(sys.define-record name (field* ...))])))