diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-06-19 22:46:07 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-06-19 22:46:07 +0200 |
commit | f4bf64b4d422bb093a3e857380d99e4f08b9c8af (patch) | |
tree | 44ec7d260f8a04016e8da6939acc702543ee356a | |
parent | 23044464c2e26649329b422380a6850d53eec725 (diff) | |
download | guile-f4bf64b4d422bb093a3e857380d99e4f08b9c8af.tar.gz |
Make `cond-expand' compilable.release_1-9-0
* module/ice-9/boot-9.scm (cond-expand): Changed into a `define-macro'
macro.
-rw-r--r-- | module/ice-9/boot-9.scm | 123 |
1 files changed, 60 insertions, 63 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ed561d2ff..36a463ad3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3192,69 +3192,66 @@ module '(ice-9 q) '(make-q q-length))}." (append (hashq-ref %cond-expand-table mod '()) features))))) -(define cond-expand - (procedure->memoizing-macro - (lambda (exp env) - (let ((clauses (cdr exp)) - (syntax-error (lambda (cl) - (error "invalid clause in `cond-expand'" cl)))) - (letrec - ((test-clause - (lambda (clause) - (cond - ((symbol? clause) - (or (memq clause %cond-expand-features) - (let lp ((uses (module-uses (env-module env)))) - (if (pair? uses) - (or (memq clause - (hashq-ref %cond-expand-table - (car uses) '())) - (lp (cdr uses))) - #f)))) - ((pair? clause) - (cond - ((eq? 'and (car clause)) - (let lp ((l (cdr clause))) - (cond ((null? l) - #t) - ((pair? l) - (and (test-clause (car l)) (lp (cdr l)))) - (else - (syntax-error clause))))) - ((eq? 'or (car clause)) - (let lp ((l (cdr clause))) - (cond ((null? l) - #f) - ((pair? l) - (or (test-clause (car l)) (lp (cdr l)))) - (else - (syntax-error clause))))) - ((eq? 'not (car clause)) - (cond ((not (pair? (cdr clause))) - (syntax-error clause)) - ((pair? (cddr clause)) - ((syntax-error clause)))) - (not (test-clause (cadr clause)))) - (else - (syntax-error clause)))) - (else - (syntax-error clause)))))) - (let lp ((c clauses)) - (cond - ((null? c) - (error "Unfulfilled `cond-expand'")) - ((not (pair? c)) - (syntax-error c)) - ((not (pair? (car c))) - (syntax-error (car c))) - ((test-clause (caar c)) - `(begin ,@(cdar c))) - ((eq? (caar c) 'else) - (if (pair? (cdr c)) - (syntax-error c)) - `(begin ,@(cdar c))) - (else - (lp (cdr c)))))))))) +(define-macro (cond-expand . clauses) + (let ((syntax-error (lambda (cl) + (error "invalid clause in `cond-expand'" cl)))) + (letrec + ((test-clause + (lambda (clause) + (cond + ((symbol? clause) + (or (memq clause %cond-expand-features) + (let lp ((uses (module-uses (current-module)))) + (if (pair? uses) + (or (memq clause + (hashq-ref %cond-expand-table + (car uses) '())) + (lp (cdr uses))) + #f)))) + ((pair? clause) + (cond + ((eq? 'and (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #t) + ((pair? l) + (and (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'or (car clause)) + (let lp ((l (cdr clause))) + (cond ((null? l) + #f) + ((pair? l) + (or (test-clause (car l)) (lp (cdr l)))) + (else + (syntax-error clause))))) + ((eq? 'not (car clause)) + (cond ((not (pair? (cdr clause))) + (syntax-error clause)) + ((pair? (cddr clause)) + ((syntax-error clause)))) + (not (test-clause (cadr clause)))) + (else + (syntax-error clause)))) + (else + (syntax-error clause)))))) + (let lp ((c clauses)) + (cond + ((null? c) + (error "Unfulfilled `cond-expand'")) + ((not (pair? c)) + (syntax-error c)) + ((not (pair? (car c))) + (syntax-error (car c))) + ((test-clause (caar c)) + `(begin ,@(cdar c))) + ((eq? (caar c) 'else) + (if (pair? (cdr c)) + (syntax-error c)) + `(begin ,@(cdar c))) + (else + (lp (cdr c)))))))) ;; This procedure gets called from the startup code with a list of ;; numbers, which are the numbers of the SRFIs to be loaded on startup. |