Hi Guilers,
Find attached a very early, definitely broken first draft of R6RS
library support. I was hoping to send this before / during Libre
Planet '09, but AC outlets were scarce (and boozing at The Red Line so
much easier than hacking) so I'm attempting to send this using the
free WiFi on the Acela back to NYC.
As discussed, this version uses the following approach for mapping
Guile's module search / autoloading mechanism onto locating R6RS
libraries: When a user or a library calls `import' with an import
spec,
1. The import spec is unwrapped until an actual library reference is found.
2. If a matching library reference has already been loaded, an
interface meeting the import spec's requirements is created and
returned.
3. Otherwise, `resolve-interface' is called on the name portion of the
library reference. If a satisficing interface cannot be loaded, the
import fails.
4. Otherwise, the import system expects that either:
a. The loaded Guile module has registered one or more versions of a
corresponding R6RS library under the library name in the internal
library registry via the `register-library' or `register-from-path'
functions in `(ice-9 r6rs-libraries)'. If any versions of the library
can be found in the registry, their versions are matched against the
version in the library reference as per R6RS.
b. The loaded Guile module is a non-R6RS Guile module (e.g.,
`(guile)' or `(ice-9 syncase)'). In this case, it is wrapped in an
R6RS compatibility layer to make it accessible to the library system.
What this means is that `(ice-9 r6rs-libraries)' can automatically
load normal Guile modules, and that R6RS library expressions don't
need to be modified in order to be loadable. It does require,
however, that every installed set of versions of an R6RS library have
a Guile module that serves as a catalog of sorts. This catalog module
file might use `register-library' to register the entire library
expression:
(define-module (mystuff mylibrary)
#:use-module (ice-9 r6rs-libraries))
(register-library
'(library (mystuff mylibrary (1 2))
(export foo)
(import (mystuff myotherlibrary))
(define (foo) (display "Hello, world!"))))
...or it could use the search path to register a library expression
from an external file:
(define-module (mystuff mylibrary)
#:use-module (ice-9 r6rs-libraries))
(register-from-path "mystuff/mylibrary.scm.1")
(register-from-path "mystuff/mylibrary.scm.1.2")
This mechanism might need some tweaking, but I think it resolves some
of the issues we were discussing earlier re: users installing R6RS
libraries having to keep them separate from other Guile modules.
If anyone's interested, I've created catalog modules and library
expressions for the bits and pieces of the core set of R6RS libraries
(including `(rnrs base)') necessary for testing, and I'd be happy to
tar them up and make them available somewhere.
Some other points:
* This draft doesn't do any real validation of the `library' form.
* Phased imports for the `define-syntax' form sort of work, but there
are issues with cross-module visibility of bindings for symbols
included in the output of transformers, as discussed here [1].
* Phased imports for the `letrec-syntax' and `let-syntax' forms don't
work at all yet.
Regards,
Julian
[1] - http://lists.gnu.org/archive/html/guile-user/2009-03/msg00015.html
;;; r6rs-libraries.scm --- Support for R6RS libraries
;; Copyright (C) 2009 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Author: Julian Graham <[email protected]>
;;; Date: 2009-03-05
;;; Commentary:
(define-module (ice-9 r6rs-libraries)
:use-module (ice-9 optargs)
:use-module (ice-9 receive)
:use-module (ice-9 syncase)
:use-module (srfi srfi-1)
:use-module (srfi srfi-2)
:use-module (srfi srfi-9)
:use-module (srfi srfi-11)
:export (import
register-library
register-from-path))
(define (library-name library) (list-ref library 1))
(define (library-exports library) (cdr (list-ref library 2)))
(define (library-imports library) (cdr (list-ref library 3)))
(define (library-body library) (cddddr library))
(define library-registry (make-hash-table))
(define interface-registry (make-hash-table))
(define-record-type r6rs-library-type
(make-r6rs-library name)
r6rs-library?
(name r6rs-library-name)
(exports r6rs-library-exports set-r6rs-library-exports!)
(module r6rs-library-module set-r6rs-library-module!)
(interface r6rs-library-interface set-r6rs-library-interface!)
(parent r6rs-library-parent set-r6rs-library-parent!))
(define* (create-empty-module #:optional name)
(define module (make-module))
(set-module-name! module (or name (list (gensym))))
(let ((interface (make-module)))
(set-module-name! interface (module-name module))
(set-module-kind! interface 'interface)
(set-module-public-interface! module interface))
module)
(define* (create-module-interface module exports #:optional name)
(let ((i (make-module)))
(set-module-name! i (or name (list (gensym))))
(set-module-kind! i 'custom-interface)
(for-each
(lambda (import)
(if (pair? import)
(module-add! i (cadr import) (module-variable module (car import)))
(module-add! i import (module-variable module import))))
exports)
i))
(define* (create-library-interface lib exports #:optional name)
(let* ((name (or name (list (gensym))))
(l (make-r6rs-library name)))
(set-r6rs-library-interface!
l (create-module-interface (r6rs-library-interface lib) exports name))
(set-r6rs-library-exports!
l (map (lambda (x) (if (pair? x) (cadr x) x)) exports))
(set-r6rs-library-parent! l lib)
l))
(define (instantiate-library lib-expr)
(define name (library-name lib-expr))
(define imports (library-imports lib-expr))
(define exports
(fold (lambda (x lst) (append lst (if (pair? x) (cdr x) (list x))))
'()
(library-exports lib-expr)))
(define library (make-r6rs-library (library-name lib-expr)))
(define module (create-empty-module))
(define (binding-name binding) (if (list? binding) (car binding) binding))
(define local-definitions (list 'exports))
(define phase-library-cache (make-hash-table))
(define (inject-bindings-for-phase! m phase)
(and=> (hashv-ref phase-library-cache phase)
(lambda (ifaces) (for-each (lambda (i) (module-use! m i))
(map r6rs-library-interface ifaces)))))
(define (expand expr m p)
(if (pair? expr)
(let ((ce (car expr)))
(cond ((eq? ce 'define)
(eval (cons* ce (cadr expr) (expand (cddr expr) m p)) m))
((eq? ce 'define-syntax)
(let ((m+ (create-empty-module))
(p (+ p 1)))
(inject-bindings-for-phase! m+ p)
(let ((rhs (eval (expand (caddr expr) m+ p) m+)))
(let ((e `(define-syntax ,(cadr expr) ,rhs)))
(eval e m)))))
(else (map (lambda (x) (expand x m p)) expr))))
expr))
(define (hashv-append! h k v)
(or (and=> (hashv-ref h k) (lambda (ov) (hashv-set! h k (append ov `(,v)))))
(hashv-set! h k `(,v))))
(for-each
(lambda (import)
(let* ((import-set (if (eq? (car import) 'for) (cadr import) import))
(interface (import-library import-set)))
(if (equal? (r6rs-library-name interface) '(rnrs (6)))
(begin (hashv-append! phase-library-cache 0 interface)
(hashv-append! phase-library-cache 1 interface)))
(if (eq? (car import) 'for)
(for-each
(lambda (phase)
(cond ((eq? phase 'run)
(hashv-append! phase-library-cache 0 interface))
((eq? phase 'expand)
(hashv-append! phase-library-cache 1 interface))
((and (list? phase) (eq? (car phase 'meta)))
(hashv-append! phase-library-cache (cadr phase) interface))
(else (error "Invalid import level specification"))))
(cddr import))
(hashv-append! phase-library-cache 0 interface))))
imports)
(inject-bindings-for-phase! module 0)
(for-each (lambda (expr)
(if (and (list? expr) (memq (car expr) '(define define-syntax)))
(begin (expand expr module 0)
(append! local-definitions
(list (binding-name (cadr expr)))))
(eval expr module)))
(library-body lib-expr))
(let ((locals (cdr local-definitions)))
(receive
(export-vars export-names)
(let f ((vars (list)) (names (list)) (lst exports))
(cond ((null? lst) (values vars names))
((pair? (car lst))
(f (cons (caar lst) vars) (cons (cadar lst) names) (cdr lst)))
(else (f (cons (car lst) vars)
(cons (car lst) names)
(cdr lst)))))
(if (not (null? locals))
(module-export! module locals))
(module-re-export! module (lset-difference eq? export-vars locals))
(let ((module-interface (create-module-interface module exports name)))
(set-module-public-interface! module module-interface)
(set-r6rs-library-module! library module)
(set-r6rs-library-interface! library module-interface)
(set-r6rs-library-exports! library export-names))))
(hash-set! interface-registry name library))
(define (version-matches? version-ref target)
(define (sub-versions-match? v-refs t)
(define (sub-version-matches? v-ref t)
(define (curried-sub-version-matches? v) (sub-version-matches? v t))
(cond ((number? v-ref) (eqv? v-ref t))
((list? v-ref)
(let ((cv (car v-ref)))
(cond ((eq? cv '>=) (>= t (cadr v-ref)))
((eq? cv '<=) (<= t (cadr v-ref)))
((eq? cv 'and)
(every curried-sub-version-matches? (cdr v-ref)))
((eq? cv 'or)
(any curried-sub-version-matches? (cdr v-ref)))
((eq? cv 'not) (not (sub-version-matches? (cadr v-ref) t)))
(else (error "Incompatible sub-version reference" cv)))))
(else (error "Incompatible sub-version reference" v-ref))))
(or (null? v-refs)
(and (not (null? t))
(sub-version-matches? (car v-refs) (car t))
(sub-versions-match? (cdr v-refs) (cdr t)))))
(define (curried-version-matches? v) (version-matches? v target))
(or (null? version-ref)
(let ((cv (car version-ref)))
(cond ((eq? cv 'and) (every curried-version-matches? (cdr version-ref)))
((eq? cv 'or) (any curried-version-matches? (cdr version-ref)))
((eq? cv 'not) (not version-matches? (cadr version-ref) target))
(else (sub-versions-match? version-ref target))))))
(define (import-library import-spec)
(define (wrap-guile-module module)
(let ((li (make-r6rs-library (module-name module))))
(set-r6rs-library-module! li module)
(set-r6rs-library-interface! li module)
(set-r6rs-library-exports!
li (hash-map->list (lambda (x y) x) (module-obarray module)))
li))
(define (locate-library library-reference)
(receive
(name version)
(partition symbol? library-reference)
(let ((interface (false-if-exception (resolve-interface name))))
(or (hash-ref interface-registry library-reference)
(and-let* ((version-table (hash-ref library-registry name))
(cversion (if (null? version) version (car version))))
(or (and=> (assoc cversion version-table version-matches?)
(lambda (x) (instantiate-library (cdr x))))
(error "No version of library found to match version-ref"
name
cversion
version-table)))
(and interface (hash-set! interface-registry
library-reference
(wrap-guile-module interface)))
(error "Unable to resolve interface for library"
library-reference)))))
(define (resolve-library-interface import)
(let ((ci (car import)))
(cond
((eq? ci 'library) (locate-library (cadr import)))
((or (eq? ci 'only) (eq? ci 'rename))
(create-library-interface (resolve-library-interface (cadr import))
(cddr import)))
((eq? ci 'except)
(let ((i (resolve-library-interface (cadr import))))
(create-library-interface
i (lset-difference eq? (r6rs-library-exports i) (cddr import)))))
((eq? ci 'prefix)
(let* ((i (resolve-library-interface (cadr import)))
(prefix-str (symbol->string (caddr import))))
(create-library-interface
i (map (lambda (x)
(cons x (list (string->symbol
(string-append prefix-str
(symbol->string x))))))
(r6rs-library-exports i)))))
(else (locate-library import)))))
(resolve-library-interface import-spec))
(define (import import-spec)
(let ((lib (import-library import-spec)))
(or lib (error "Unable to import library for import spec " import-spec))
(module-use! (current-module) (r6rs-library-interface lib))))
(define (register-library library-expr)
(define (version-less? x y)
(cond ((null? x) #f)
((null? y) #t)
(else (let ((cx (car x))
(cy (car y)))
(cond ((< cx cy) #t)
((> cx cy) #f)
(else (version-less? (cdr x) (cdr y))))))))
(receive
(name version)
(partition symbol? (library-name library-expr))
(let ((cversion (if (null? version) version (car version))))
(or (and=> (hash-ref library-registry name)
(lambda (version-table)
(merge! version-table
`(,(cons cversion library-expr))
version-less?)))
(hash-set! library-registry name `(,(cons cversion library-expr)))))))
(define (register-from-path filename)
(define (quoting-read port)
(let ((library-expr (read port)))
(if (eof-object? library-expr)
library-expr
(begin (register-library library-expr) *unspecified*))))
(with-fluids ((current-reader quoting-read)) (load-from-path filename)))
