~ chicken-core (chicken-5) 9aaabd5ff9e7ffd8b162bbb6b9dfc57376367e2c
commit 9aaabd5ff9e7ffd8b162bbb6b9dfc57376367e2c
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Feb 9 07:22:39 2016 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:35 2016 +1300
Check library requirement against alternates list in load-extension
Rather than expanding `##core#require` into a conditional, pass the list
of alternate requirements along to `##sys#load-extension` and check it
there. This simlifies the generated code somewhat.
diff --git a/core.scm b/core.scm
index d5cf54ed..9541644e 100644
--- a/core.scm
+++ b/core.scm
@@ -138,7 +138,7 @@
; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>}) <exp>)
; (##core#define-external-variable <name> <type> <bool> [<symbol>])
; (##core#check <exp>)
-; (##core#require-for-syntax <exp> ...)
+; (##core#require-for-syntax <id> ...)
; (##core#require <id> <id> ...)
; (##core#app <exp> {<exp>})
; (##core#define-syntax <symbol> <expr>)
@@ -670,25 +670,17 @@
'(##core#undefined))
((##core#require)
- (walk
- (let loop ((ids (strip-syntax (cdr x)))
- (exps '()))
- (if (null? ids)
- (foldl (lambda (expr e)
- `(##core#if ,e (##core#undefined) ,expr))
- (car exps)
- (cdr exps))
- (let ((id (car ids))
- (rest (cdr ids)))
- (let-values (((exp found type)
- (##sys#process-require id #t (null? rest) used-units)))
- (unless (not type)
- (##sys#hash-table-update!
- file-requirements type
- (cut lset-adjoin/eq? <> id)
- (cut list id)))
- (if found exp (loop rest (cons exp exps)))))))
- e se dest ldest h ln))
+ (let ((id (cadr x))
+ (alternates (cddr x)))
+ (let-values (((exp found type)
+ (##sys#process-require id #t alternates used-units)))
+ (unless (not type)
+ (##sys#hash-table-update!
+ file-requirements type
+ (cut lset-adjoin/eq? <> id)
+ (cut list id)))
+ (walk `(##core#begin ,exp (##core#undefined))
+ e se dest ldest h ln))))
((##core#let)
(let* ((bindings (cadr x))
diff --git a/eval.scm b/eval.scm
index 9b3784ee..80f7c25c 100644
--- a/eval.scm
+++ b/eval.scm
@@ -714,13 +714,10 @@
[(##core#require)
(compile
- (let loop ((ids (strip-syntax (cdr x))))
- (if (null? ids)
- '(##core#undefined)
- (let ((id (car ids))
- (rest (cdr ids)))
- (let-values (((exp _ _) (##sys#process-require id #f (null? rest))))
- `(##core#if ,exp (##core#undefined) ,(loop rest))))))
+ (let ((id (cadr x))
+ (alternates (cddr x)))
+ (let-values (((exp _ _) (##sys#process-require id #f alternates)))
+ `(##core#begin ,exp (##core#undefined))))
e #f tf cntr se)]
[(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
@@ -1219,10 +1216,9 @@
(or (check pa)
(loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
-(define (##sys#load-extension id #!optional loc)
- (define (fail message)
- (##sys#error loc message id))
+(define (##sys#load-extension id #!optional (alternates '()) loc)
(cond ((##sys#provided? id))
+ ((any ##sys#provided? alternates))
((memq id core-units)
(or (load-library-0 id #f)
(fail "cannot load core library")))
@@ -1237,11 +1233,11 @@
(define (load-extension id)
(##sys#check-symbol id 'load-extension)
- (##sys#load-extension id 'load-extension))
+ (##sys#load-extension id '() 'load-extension))
(define (require . ids)
(for-each (cut ##sys#check-symbol <> 'require) ids)
- (for-each (cut ##sys#load-extension <> 'require) ids))
+ (for-each (cut ##sys#load-extension <> '() 'require) ids))
(define (provide . ids)
(for-each (cut ##sys#check-symbol <> 'provide) ids)
@@ -1287,7 +1283,7 @@
;; - a library id if the library was found, #f otherwise
;; - a requirement type (e.g. 'dynamic) or #f if provided statically
;;
-(define (##sys#process-require lib #!optional compiling? dynamic? (static-units '()))
+(define (##sys#process-require lib #!optional compiling? (alternates '()) (static-units '()))
(let ((id (library-id lib)))
(cond
((assq id core-unit-requirements) =>
@@ -1296,14 +1292,14 @@
(values '(##core#undefined) id #f))
((memq id static-units)
(values '(##core#undefined) id #f))
+ ((any (cut memq <> static-units) alternates)
+ (values '(##core#undefined) id #f))
((memq id core-units)
(values
(if compiling?
`(##core#declare (uses ,id))
`(##sys#load-library (##core#quote ,id)))
id #f))
- ((not dynamic?)
- (values `(##sys#provided? (##core#quote ,id)) #f #f))
((extension-information/internal id #f) =>
(lambda (info)
(let ((s (assq 'syntax info))
@@ -1317,13 +1313,19 @@
,@(if (or nr (and (not rr) s))
'()
(map (lambda (id)
- `(##sys#load-extension (##core#quote ,id)))
+ `(##sys#load-extension
+ (##core#quote ,id)
+ (##core#quote ,alternates)))
(cond (rr (cdr rr))
(else (list id))))))
id
(if s 'dynamic/syntax 'dynamic)))))
(else
- (values `(##sys#load-extension (##core#quote ,id)) #f 'dynamic)))))
+ (values `(##sys#load-extension
+ (##core#quote ,id)
+ (##core#quote ,alternates))
+ #f
+ 'dynamic)))))
;;; Environments:
diff --git a/expand.scm b/expand.scm
index 7774f97a..43f48c5f 100644
--- a/expand.scm
+++ b/expand.scm
@@ -966,7 +966,7 @@
##sys#current-environment ##sys#macro-environment #f #f 'import))
(if (not lib)
'(##core#undefined)
- `(##core#require ,(module-requirement name) ,lib))))
+ `(##core#require ,lib ,(module-requirement name)))))
(cdr x))))))
(##sys#extend-macro-environment
@@ -1462,7 +1462,9 @@
`(##core#begin
,@(map (lambda (x)
(let-values (((name lib _ _ _ _) (##sys#decompose-import x r c 'import)))
- `(##core#require ,(module-requirement name) ,lib)))
+ (if (not lib)
+ '(##core#undefined)
+ `(##core#require ,lib ,(module-requirement name)))))
(cdr x))))))
(##sys#extend-macro-environment
Trap