Hi all, Find attached a working prototype of R6RS library support, in the form of a Guile module called `(r6rs-libraries)'. The module depends on the two attached patches, which add, respectively, support for the `#:version' keyword [1] and support for renaming bindings on export [2]. It works by transforming the R6RS `library' form into Guile's native `define-module' form. Because it's implemented as a macro, it's only required at expansion time -- the resulting compiled module has no dependencies on anything besides other Guile modules.
Andreas Rottmann's quasisyntax implementation is included as part of `(r6rs-libraries)' since it's not yet in master and I was finding it difficult to model some things without `unsyntax-splicing'. Also attached are a minimal set of R6RS libraries (as `r6rs-libs.tar.gz') needed to bootstrap the examples from chapter 7 of the R6RS spec (attached as `r6rs-examples.tar.gz'). If you place the r6rs-libraries.scm and the contents of these tarballs somwhere in your `%load-path', you can run the "balloon party" example as follows: scheme@(guile-user)> (use-modules (r6rs-libraries)) scheme@(guile-user)> (use-modules (main)) Boom 108 Boom 24 ...and the "let-div" example as follows: scheme@(guile-user)> (use-modules (r6rs-libraries)) scheme@(guile-user)> (use-modules (let-div)) scheme@(guile-user)> (let-div 5 2 (q r) (display "q: ") (display q) (display " r: ") (display r) (newline)) q: 2 r: 1 There are certainly some aspects of this implementation that require review -- in particular, I've added infrastructure to distinguish between imports targeted for different "phases" (i.e., `run', `expand' ... (meta n)), but at the moment, all imports are currently included via #:use-module, which means they're visible at every point from expansion to runtime. R6RS seems to explicitly allow this, though, and, quite frankly, it's much easier to implement. As I said earlier, I'm happy to provide full documentation for all of this code if the consensus is that I'm on the right track. Regards, Julian [1] - http://www.mail-archive.com/guile-devel@gnu.org/msg04506.html [2] - http://www.mail-archive.com/guile-devel@gnu.org/msg04660.html
From adcbc77ca4ca68f26da05a204154d826a832a7b7 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.gra...@aya.yale.edu>
Date: Sun, 25 Oct 2009 13:17:40 -0400
Subject: [PATCH] Complete support for version information in Guile's `module' form.
* module/ice-9/boot-9.scm (try-load-module, try-module-autoload): Check for version argument and use `find-versioned-module' if present.
* module/ice-9/boot-9.scm (find-versioned-module, version-matches?, module-version, set-module-version!, version-matches?): New functions.
* module/ice-9/boot-9.scm (module-type, make-module, resolve-module, try-load-module, process-define-module, make-autoload-interface, compile-interface-spec): Add awareness and checking of version information.
---
module/ice-9/boot-9.scm | 149 ++++++++++++++++++++++++++++++++++++++++++-----
1 files changed, 133 insertions(+), 16 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 5852477..3d92fad 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1333,7 +1333,7 @@
(make-record-type 'module
'(obarray uses binder eval-closure transformer name kind
duplicates-handlers import-obarray
- observers weak-observers)
+ observers weak-observers version)
%print-module))
;; make-module &opt size uses binder
@@ -1374,7 +1374,7 @@
#f #f #f
(make-hash-table %default-import-size)
'()
- (make-weak-key-hash-table 31))))
+ (make-weak-key-hash-table 31) #f)))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
@@ -1396,6 +1396,8 @@
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
+(define module-version (record-accessor module-type 'version))
+(define set-module-version! (record-modifier module-type 'version))
;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
@@ -2001,6 +2003,7 @@
(eq? interface module))
(let ((interface (make-module 31)))
(set-module-name! interface (module-name module))
+ (set-module-version! interface (module-version module))
(set-module-kind! interface 'interface)
(set-module-public-interface! module interface))))
(if (and (not (memq the-scm-module (module-uses module)))
@@ -2008,6 +2011,101 @@
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
+(define (version-matches? version-ref target)
+ (define (any prec lst)
+ (and (not (null? lst)) (or (prec (car lst)) (any prec (cdr lst)))))
+ (define (every prec lst)
+ (or (null? lst) (and (prec (car lst)) (every prec (cdr lst)))))
+ (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 (find-versioned-module dir-hint name version-ref roots)
+ (define (subdir-pair-less pair1 pair2)
+ (define (numlist-less lst1 lst2)
+ (or (null? lst2)
+ (and (not (null? lst1))
+ (cond ((> (car lst1) (car lst2)) #t)
+ ((< (car lst1) (car lst2)) #f)
+ (else (numlist-less (cdr lst1) (cdr lst2)))))))
+ (numlist-less (car pair1) (car pair2)))
+
+ (define (match-version-and-file pair)
+ (and (version-matches? version-ref (car pair))
+ (let ((filenames
+ (filter (lambda (file)
+ (let ((s (false-if-exception (stat file))))
+ (and s (eq? (stat:type s) 'regular))))
+ (map (lambda (ext)
+ (string-append (cdr pair) "/" name ext))
+ %load-extensions))))
+ (and (not (null? filenames))
+ (cons (car pair) (car filenames))))))
+
+ (define (match-version-recursive root-pairs leaf-pairs)
+ (define (filter-subdirs root-pairs ret)
+ (define (filter-subdir root-pair dstrm subdir-pairs)
+ (let ((entry (readdir dstrm)))
+ (if (eof-object? entry)
+ subdir-pairs
+ (let* ((subdir (string-append (cdr root-pair) "/" entry))
+ (num (string->number entry))
+ (num (and num (append (car root-pair) (list num)))))
+ (if (and num (eq? (stat:type (stat subdir)) 'directory))
+ (filter-subdir
+ root-pair dstrm (cons (cons num subdir) subdir-pairs))
+ (filter-subdir root-pair dstrm subdir-pairs))))))
+
+ (or (and (null? root-pairs) ret)
+ (let* ((rp (car root-pairs))
+ (dstrm (false-if-exception (opendir (cdr rp)))))
+ (if dstrm
+ (let ((subdir-pairs (filter-subdir rp dstrm '())))
+ (closedir dstrm)
+ (filter-subdirs (cdr root-pairs)
+ (or (and (null? subdir-pairs) ret)
+ (append ret subdir-pairs))))
+ (filter-subdirs (cdr root-pairs) ret)))))
+
+ (or (and (null? root-pairs) leaf-pairs)
+ (let ((matching-subdir-pairs (filter-subdirs root-pairs '())))
+ (match-version-recursive
+ matching-subdir-pairs
+ (append leaf-pairs (filter pair? (map match-version-and-file
+ matching-subdir-pairs)))))))
+
+ (define (make-root-pair root) (cons '() (string-append root "/" dir-hint)))
+ (let* ((root-pairs (map make-root-pair roots))
+ (matches (if (null? version-ref)
+ (filter pair? (map match-version-and-file root-pairs))
+ '()))
+ (matches (append matches (match-version-recursive root-pairs '()))))
+ (and (null? matches) (error "No matching modules found."))
+ (cdar (sort matches subdir-pair-less))))
+
(define (make-fresh-user-module)
(let ((m (make-module)))
(beautify-user-module! m)
@@ -2017,20 +2115,25 @@
;;
(define resolve-module
(let ((the-root-module the-root-module))
- (lambda (name . maybe-autoload)
+ (lambda (name . args)
(if (equal? name '(guile))
the-root-module
(let ((full-name (append '(%app modules) name)))
- (let ((already (nested-ref the-root-module full-name))
- (autoload (or (null? maybe-autoload) (car maybe-autoload))))
+ (let* ((already (nested-ref the-root-module full-name))
+ (numargs (length args))
+ (autoload (or (= numargs 0) (car args)))
+ (version (and (> numargs 1) (cadr args))))
(cond
((and already (module? already)
(or (not autoload) (module-public-interface already)))
;; A hit, a palpable hit.
- already)
- (autoload
+ (and version
+ (not (version-matches? version (module-version already)))
+ (error "incompatible module version already loaded" name))
+ already)
+ (autoload
;; Try to autoload the module, and recurse.
- (try-load-module name)
+ (try-load-module name version)
(resolve-module name #f))
(else
;; A module is not bound (but maybe something else is),
@@ -2076,8 +2179,8 @@
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
-(define (try-load-module name)
- (try-module-autoload name))
+(define (try-load-module name version)
+ (try-module-autoload name version))
(define (purify-module! module)
"Removes bindings in MODULE which are inherited from the (guile) module."
@@ -2137,7 +2240,8 @@
(let ((prefix (get-keyword-arg args #:prefix #f)))
(and prefix (symbol-prefix-proc prefix)))
identity))
- (module (resolve-module name))
+ (version (get-keyword-arg args #:version #f))
+ (module (resolve-module name #t version))
(public-i (and module (module-public-interface module))))
(and (or (not module) (not public-i))
(error "no code for module" name))
@@ -2258,6 +2362,14 @@
(purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
+ ((#:version)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (let ((version (cadr kws)))
+ (set-module-version! module version)
+ (set-module-version! (module-public-interface module) version))
+ (loop (cddr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
@@ -2321,7 +2433,7 @@
(set-car! autoload i)))
(module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
- (make-hash-table 0) '() (make-weak-value-hash-table 31))))
+ (make-hash-table 0) '() (make-weak-value-hash-table 31) #f)))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
@@ -2351,9 +2463,10 @@ module '(ice-9 q) '(make-q q-length))}."
;; This function is called from "modules.c". If you change it, be
;; sure to update "modules.c" as well.
-(define (try-module-autoload module-name)
+(define (try-module-autoload module-name . args)
(let* ((reverse-name (reverse module-name))
(name (symbol->string (car reverse-name)))
+ (version (and (not (null? args)) (car args)))
(dir-hint-module-name (reverse (cdr reverse-name)))
(dir-hint (apply string-append
(map (lambda (elt)
@@ -2369,8 +2482,11 @@ module '(ice-9 q) '(make-q q-length))}."
(lambda ()
(save-module-excursion
(lambda ()
- (primitive-load-path (in-vicinity dir-hint name) #f)
- (set! didit #t))))))
+ (if version
+ (load (find-versioned-module
+ dir-hint name version %load-path))
+ (primitive-load-path (in-vicinity dir-hint name) #f))
+ (set! didit #t))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
@@ -2927,7 +3043,8 @@ module '(ice-9 q) '(make-q q-length))}."
'((:select #:select #t)
(:hide #:hide #t)
(:prefix #:prefix #t)
- (:renamer #:renamer #f)))
+ (:renamer #:renamer #f)
+ (:version #:version #t)))
(if (not (pair? (car spec)))
`(',spec)
`(',(car spec)
--
1.6.0.4
From d5b1ca509e6888119702e75ce35cd1e55d295525 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.gra...@aya.yale.edu>
Date: Sat, 31 Oct 2009 13:02:13 -0400
Subject: [PATCH] Support for renaming bindings on module export.
* module/ice-9/boot-9.scm (module-export!, module-replace!, module-re-export!):
Allow members of export list to be pairs, mapping internal names to external ones.
---
module/ice-9/boot-9.scm | 24 +++++++++++++++---------
1 files changed, 15 insertions(+), 9 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 3d92fad..63f1493 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3165,16 +3165,20 @@ module '(ice-9 q) '(make-q q-length))}."
(define (module-export! m names)
(let ((public-i (module-public-interface m)))
(for-each (lambda (name)
- (let ((var (module-ensure-local-variable! m name)))
- (module-add! public-i name var)))
+ (let* ((internal-name (if (pair? name) (car name) name))
+ (external-name (if (pair? name) (cdr name) name))
+ (var (module-ensure-local-variable! m internal-name)))
+ (module-add! public-i external-name var)))
names)))
(define (module-replace! m names)
(let ((public-i (module-public-interface m)))
(for-each (lambda (name)
- (let ((var (module-ensure-local-variable! m name)))
+ (let* ((internal-name (if (pair? name) (car name) name))
+ (external-name (if (pair? name) (cdr name) name))
+ (var (module-ensure-local-variable! m internal-name)))
(set-object-property! var 'replace #t)
- (module-add! public-i name var)))
+ (module-add! public-i external-name var)))
names)))
;; Re-export a imported variable
@@ -3182,13 +3186,15 @@ module '(ice-9 q) '(make-q q-length))}."
(define (module-re-export! m names)
(let ((public-i (module-public-interface m)))
(for-each (lambda (name)
- (let ((var (module-variable m name)))
+ (let* ((internal-name (if (pair? name) (car name) name))
+ (external-name (if (pair? name) (cdr name) name))
+ (var (module-variable m internal-name)))
(cond ((not var)
- (error "Undefined variable:" name))
- ((eq? var (module-local-variable m name))
- (error "re-exporting local variable:" name))
+ (error "Undefined variable:" internal-name))
+ ((eq? var (module-local-variable m internal-name))
+ (error "re-exporting local variable:" internal-name))
(else
- (module-add! public-i name var)))))
+ (module-add! public-i external-name var)))))
names)))
(defmacro export names
--
1.6.0.4
(define-module (r6rs-libraries)
#:export-syntax (library))
(use-modules (ice-9 receive))
(use-modules (srfi srfi-1))
(define-syntax quasisyntax
(lambda (e)
;; Expand returns a list of the form
;; [template[t/e, ...] (replacement ...)]
;; Here template[t/e ...] denotes the original template
;; with unquoted expressions e replaced by fresh
;; variables t, followed by the appropriate ellipses
;; if e is also spliced.
;; The second part of the return value is the list of
;; replacements, each of the form (t e) if e is just
;; unquoted, or ((t ...) e) if e is also spliced.
;; This will be the list of bindings of the resulting
;; with-syntax expression.
(define (expand x level)
(syntax-case x (quasisyntax unsyntax unsyntax-splicing)
((quasisyntax e)
(with-syntax (((k _) x) ;; original identifier must be copied
((e* reps) (expand (syntax e) (+ level 1))))
(syntax ((k e*) reps))))
((unsyntax e)
(= level 0)
(with-syntax (((t) (generate-temporaries '(t))))
(syntax (t ((t e))))))
(((unsyntax e ...) . r)
(= level 0)
(with-syntax (((r* (rep ...)) (expand (syntax r) 0))
((t ...) (generate-temporaries (syntax (e ...)))))
(syntax ((t ... . r*)
((t e) ... rep ...)))))
(((unsyntax-splicing e ...) . r)
(= level 0)
(with-syntax (((r* (rep ...)) (expand (syntax r) 0))
((t ...) (generate-temporaries (syntax (e ...)))))
(with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
(syntax ((t ... ... . r*)
(((t ...) e) ... rep ...))))))
((k . r)
(and (> level 0)
(identifier? (syntax k))
(or (free-identifier=? (syntax k) (syntax unsyntax))
(free-identifier=? (syntax k) (syntax unsyntax-splicing))))
(with-syntax (((r* reps) (expand (syntax r) (- level 1))))
(syntax ((k . r*) reps))))
((h . t)
(with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
((t* (rep2 ...)) (expand (syntax t) level)))
(syntax ((h* . t*)
(rep1 ... rep2 ...)))))
(#(e ...)
(with-syntax ((((e* ...) reps)
(expand (vector->list (syntax #(e ...))) level)))
(syntax (#(e* ...) reps))))
(other
(syntax (other ())))))
(syntax-case e ()
((_ template)
(with-syntax (((template* replacements) (expand (syntax template) 0)))
(syntax
(with-syntax replacements (syntax template*))))))))
(define-syntax unsyntax
(lambda (e)
(syntax-violation 'unsyntax "Invalid expression" e)))
(define-syntax unsyntax-splicing
(lambda (e)
(syntax-violation 'unsyntax "Invalid expression" e)))
(define (flatten-import-spec import-spec phase-map import-map)
(define (flatten-inner import-set)
(define (load-library library-ref)
(let* ((v (car (last-pair library-ref))))
(if (pair? v)
(resolve-interface
(drop-right library-ref 1) #:version v)
(resolve-interface library-ref #:version '()))))
(define (export-eq? x y)
(if (list? y) (eq? x (cadr y)) (eq? x y)))
(if (or (not (list? import-set)))
(error))
(case (car import-set)
((library)
(let ((l (load-library (cadr import-set))))
(cons l (module-map (lambda (sym var) sym) l))))
((only)
(let ((l (flatten-inner (cadr import-set))))
(cons (car l) (lset-intersection
export-eq? (cdr l) (cddr import-set)))))
((except)
(let ((l (flatten-inner (cadr import-set))))
(cons (car l) (lset-difference
export-eq? (cdr l) (cddr import-set)))))
((prefix)
(let ((l (flatten-inner (cadr import-set)))
(p (symbol-prefix-proc (caddr import-set))))
(cons (car l)
(map (lambda (x)
(if (list? x)
(cons (car x) (p (cadr x)))
(cons x (p x))))
(cdr l)))))
((rename)
(let ((l (flatten-inner (cadr import-set))))
(cons (car l)
(map (lambda (x)
(let ((r (find (lambda (y)
(eq? (car y)
(if (list? x)
(car x) x)))
(cddr import-set))))
(if r (cons (if (list? x) (car x) x)
(cadr x)) x)))
(cdr l)))))
(else (let ((l (load-library import-set)))
(cons l (module-map (lambda (sym var) sym) l))))))
(let* ((phase (and (eq? (car import-spec) 'for)
(let ((p (list-ref import-spec 2)))
(case p ((run) 0) ((expand) 1) (else (cadr p))))))
(unwrapped-import-spec (if phase (cadr import-spec) import-spec))
(ilist (flatten-inner unwrapped-import-spec))
(public-interface (car ilist))
(interface
(append (list (module-name public-interface))
(if (module-version public-interface)
(list #:version (module-version public-interface))
(list))
(if (null? (cdr ilist)) '() (list #:select (cdr ilist))))))
(for-each (lambda (x) (hashq-set! import-map x #t))
(map (lambda (x) (if (pair? x) (cdr x) x)) (cdr ilist)))
(let* ((phase (or phase 0))
(phased-imports (hashv-ref phase-map phase)))
(if phased-imports
(hashv-set! phase-map phase (append phased-imports (list interface)))
(hashv-set! phase-map phase (list interface))))))
(define (resolve-export-spec export-specs import-map)
(define (imported? sym) (hashq-ref import-map (if (pair? sym) (car sym) sym)))
(define (flatten-renames export-spec)
(if (list? export-spec)
(map (lambda (x) (cons (car x) (cadr x))) (cdr export-spec))
(list export-spec)))
(partition imported? (apply append (map flatten-renames export-specs))))
(define-syntax library
(lambda (x)
(syntax-case x (export import)
((_ library-name
(export . export-specs)
(import . import-specs)
. library-body)
(let* ((imports (syntax->datum (syntax import-specs)))
(import-map (make-hash-table))
(phase-map (make-hash-table))
(ln-datum (syntax->datum (syntax library-name)))
(version (let ((v (car (last-pair ln-datum)))) (and (list? v) v)))
(name (if version (drop-right ln-datum 1) ln-datum))
(exports (syntax->datum (syntax export-specs)))
(body-exprs (syntax->datum (syntax library-body))))
(for-each (lambda (x) (flatten-import-spec x phase-map import-map))
imports)
(let ((runtime-imports (hashv-ref phase-map 0))
(@@-import '(((guile) #:select (@@ quote)))))
(if runtime-imports
(hashv-set! phase-map 0 (append runtime-imports @@-import))))
(receive
(re-exports exports)
(resolve-export-spec exports import-map)
(with-syntax
((name (datum->syntax #'library-name name))
(all-imports (if (not (null? imports))
(datum->syntax
#'import-specs
(apply append '()
(map (lambda (x) (list #:use-module x))
(apply append '()
(hash-map->list (lambda (k v) v)
phase-map)))))
'()))
(body-exprs (if (not (null? body-exprs))
(datum->syntax #'library-body body-exprs)
'())))
#`(begin
(define-module name
#,@(if version (list #:version version) '())
#:pure
#,@(syntax all-imports)
#,@(if (not (null? re-exports))
(datum->syntax #'export-specs `(#:re-export ,re-exports))
'())
#,@(if (not (null? exports))
(datum->syntax #'export-specs `(#:export ,exports))
'()))
#,@(syntax body-exprs)))))))))
r6rs-examples.tar.gz
Description: GNU Zip compressed data
r6rs-libs.tar.gz
Description: GNU Zip compressed data
