~ chicken-core (chicken-5) cfa7c4ded513b67a30c8a4c07db952e0359ee4ee
commit cfa7c4ded513b67a30c8a4c07db952e0359ee4ee
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Feb 8 13:42:11 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Feb 8 13:42:11 2010 +0100
removed user-defined extension-specifiers; require-extension handles import forms
diff --git a/eval.scm b/eval.scm
index d114149b..6e53e671 100644
--- a/eval.scm
+++ b/eval.scm
@@ -81,7 +81,7 @@
##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
open-output-string get-output-string make-parameter software-type software-version machine-type
- build-platform set-extensions-specifier! ##sys#string->symbol list->vector get-environment-variable
+ build-platform ##sys#string->symbol list->vector get-environment-variable
extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
vector->list store-string open-input-string eval ##sys#gc
with-exception-handler print-error-message read-char read ##sys#read-error
@@ -128,10 +128,10 @@
(define-constant builtin-features
'(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39
- srfi-88 srfi-98) )
+ srfi-55 srfi-88 srfi-98) )
(define-constant builtin-features/compiled
- '(srfi-6 srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26 srfi-55) )
+ '(srfi-6 srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26) )
(define ##sys#chicken-prefix
(let ((prefix (and-let* ((p (get-environment-variable prefix-environment-variable)))
@@ -1217,27 +1217,27 @@
(##sys#hash-table-update!
##compiler#file-requirements
(if syntax? 'dynamic/syntax 'dynamic)
- (cut lset-adjoin eq? <> id) ;XXX assumes compiler has srfi-1 loaded
+ (cut lset-adjoin eq? <> id) ;XXX assumes compiler has srfi-1 loaded
(lambda () (list id)))))
(define (impform x id builtin?)
`(##core#begin
- ,x
- ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
- `((import ,id)) ;XXX make hygienic
- '())))
- (define (doit id)
+ ,x
+ ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
+ `((import ,id)) ;XXX make hygienic
+ '())))
+ (define (doit id impid)
(cond ((or (memq id builtin-features)
(if comp?
(memq id builtin-features/compiled)
(##sys#feature? id) ) )
- (values (impform '(##core#undefined) id #t) #t) )
+ (values (impform '(##core#undefined) impid #t) #t) )
((memq id ##sys#core-library-modules)
(values
(impform
(if comp?
`(##core#declare (uses ,id))
`(##sys#load-library ',id #f) )
- id #t)
+ impid #t)
#t) )
((memq id ##sys#explicit-library-modules)
(let* ((info (##sys#extension-information id 'require-extension))
@@ -1245,14 +1245,14 @@
(s (assq 'syntax info)))
(values
`(##core#begin
- ,@(if s `((##core#require-for-syntax ',id)) '())
- ,(impform
- (if (not nr)
- (if comp?
- `(##core#declare (uses ,id))
- `(##sys#load-library ',id #f) )
- '(##core#undefined))
- id #f))
+ ,@(if s `((##core#require-for-syntax ',id)) '())
+ ,(impform
+ (if (not nr)
+ (if comp?
+ `(##core#declare (uses ,id))
+ `(##sys#load-library ',id #f) )
+ '(##core#undefined))
+ impid #f))
#t) ) )
(else
(let ((info (##sys#extension-information id 'require-extension)))
@@ -1264,93 +1264,48 @@
(values
(impform
`(##core#begin
- ,@(if s `((##core#require-for-syntax ',id)) '())
- ,@(if (or nr (and (not rr) s))
- '()
- `((##sys#require
- ,@(map (lambda (id) `',id)
- (cond (rr (cdr rr))
- (else (list id)) ) ) ) ) ) )
- id #f)
+ ,@(if s `((##core#require-for-syntax ',id)) '())
+ ,@(if (or nr (and (not rr) s))
+ '()
+ `((##sys#require
+ ,@(map (lambda (id) `',id)
+ (cond (rr (cdr rr))
+ (else (list id)) ) ) ) ) ) )
+ impid #f)
#t) ) )
(else
(add-req id #f)
(values
(impform
`(##sys#require ',id)
- id #f)
+ impid #f)
#f)))))))
- (if (and (pair? id) (symbol? (car id)))
- (let ((a (assq (##sys#slot id 0)
- ##sys#extension-specifiers)))
- (if a
- (let ((a ((##sys#slot a 1) id)))
- (cond ((string? a) (values `(load ,a) #f)) ;XXX hygiene
- ((vector? a)
- (let loop ((specs (vector->list a))
- (exps '())
- (f #f) )
- (if (null? specs)
- (values `(##core#begin ,@(reverse exps)) f)
- (let-values (((exp fi)
- (##sys#do-the-right-thing
- (car specs) comp? imp?)))
- (loop (cdr specs)
- (cons exp exps)
- (or fi f) ) ) ) ) )
- (else (##sys#do-the-right-thing a comp? imp?)) ) )
- (##sys#error "undefined extension specifier" id) ) )
- (if (symbol? id)
- (doit id)
- (##sys#error "invalid extension specifier" id) ) ) ) ) )
-
-(define ##sys#extension-specifiers '())
-
-(define (set-extension-specifier! name proc)
- (##sys#check-symbol name 'set-extension-specifier!)
- (let* ((name (##sys#strip-syntax name))
- (a (assq name ##sys#extension-specifiers)))
- (if a
- (let ([old (##sys#slot a 1)])
- (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
- (set! ##sys#extension-specifiers
- (cons (cons name (lambda (spec) (proc spec #f)))
- ##sys#extension-specifiers)) ) ) )
-
-
-;;; SRFI-55
-
-(set-extension-specifier!
- 'srfi
- (let ([list->vector list->vector])
- (lambda (spec old)
- (list->vector
- (let loop ([ids (cdr spec)])
- (if (null? ids)
- '()
- (let ([id (car ids)])
- (##sys#check-exact id 'require-extension)
- (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
- (loop (cdr ids)) ) ) ) ) ) ) ) )
-
-
-;;; Version checking
-
-(set-extension-specifier!
- 'version
- (lambda (spec _)
- (define (->string x)
- (cond ((string? x) x)
- ((symbol? x) (##sys#slot x 1))
- ((number? x) (##sys#number->string x))
- (else (error "invalid extension version" x)) ) )
- (if (and (list? spec) (fx= 3 (length spec)))
- (let* ((info (extension-information (cadr spec)))
- (vv (and info (assq 'version info))) )
- (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
- (error "installed extension does not match required version" id vv (caddr spec)))
- id)
- (##sys#syntax-error-hook "invalid version specification" spec)) ) )
+ (cond ((and (pair? id) (symbol? (car id)))
+ (case (car id)
+ ((srfi)
+ (let* ((f #f)
+ (exp
+ `(##core#begin
+ ,@(map (lambda (n)
+ (unless (fixnum? n)
+ (##sys#syntax-error 'require-extension "invalid SRFI number" n))
+ (let ((rid (string->symbol (string-append "srfi-" (number->string n)))))
+ (let-values (((exp f2) (doit rid rid)))
+ (set! f (or f f2))
+ exp)))
+ (cdr id)))))
+ (values exp f)))
+ ((rename except only prefix)
+ (doit
+ (let follow ((id2 id))
+ (if (and (pair? id2) (pair? (cdr id2)))
+ (follow (cadr id2))
+ id2))
+ id))
+ (else (##sys#error "invalid extension specifier" id) ) ) )
+ ((symbol? id)
+ (doit id id))
+ (else (##sys#error "invalid extension specifier" id) ) ) )))
;;; Convert string into valid C-identifier:
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 33e41c72..96db2094 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -50,7 +50,9 @@ See also: {{set-extension-specifier!}}
<macro>(require-extension ID ...)</macro>
This is equivalent to {{(require-library ID ...)}} but performs an implicit
-{{import}}, if necessary.
+{{import}}, if necessary. {{ID}} may also be an import specification
+(using {{rename}}, {{only}}, {{except}} or {{prefix}}).
+
This implementation of {{require-extension}} is compliant with [[http://srfi.schemers.org/srfi-55/srfi-55.html|SRFI-55]]
(see the [[http://srfi.schemers.org/srfi-55/srfi-55.html|SRFI-55]] document for more information).
diff --git a/manual/Unit eval b/manual/Unit eval
index f92997ca..aea201ea 100644
--- a/manual/Unit eval
+++ b/manual/Unit eval
@@ -162,35 +162,6 @@ from one of the following locations:
{{ID}} should be a string or a symbol.
-==== set-extension-specifier!
-
-<procedure>(set-extension-specifier! SYMBOL PROC)</procedure>
-
-Registers the handler-procedure {{PROC}} as a extension-specifier with the
-name {{SYMBOL}}. This facility allows extending the set of valid extension
-specifiers to be used with {{require-extension}}. When {{register-extension}}
-is called with an extension specifier of the form {{(SPEC ...)}} and {{SPEC}}
-has been registered with {{set-extension-specifier!}}, then {{PROC}} will
-be called with two arguments: the specifier and the previously installed handler
-(or {{#f}} if no such handler was defined). The handler should return a new
-specifier that will be processed recursively. If the handler returns a vector,
-then each element of the vector will be processed recursively.
-Alternatively the handler may return a string which specifies a file to be loaded:
-
-<enscript highlight=scheme>
-(eval-when (compile eval)
- (set-extension-specifier!
- 'my-package
- (lambda (spec old)
- (make-pathname my-package-directory (->string (cadr spec))) ) ) )
-
-(require-extension (my-package stuff)) ; --> expands into '(load "my-package-dir/stuff")
-</enscript>
-
-Note that the handler has to be registered at compile time, if it is to be
-visible in compiled code.
-
-
=== System information
==== chicken-home
Trap