mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 08:50:23 +02:00
Code Activity

(cond-expand): Define using

Browse source 
`procedure->memoizing-macro' to get at the lexical environment.
Use `env-module' instead of `current-module' to get the right
module.
This commit is contained in:
Marius Vollmer 2001-05-25 13:18:52 +00:00
parent e24ca5385a
commit 9f79272ab3
1 changed files with 61 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

120
ice-9/boot-9.scm
View file

@ -2741,67 +2741,69 @@
(append (hashq-ref %cond-expand-table mod '()) (append (hashq-ref %cond-expand-table mod '())
features))))) features)))))
(define-macro (cond-expand clause . clauses) (define cond-expand
(procedure->memoizing-macro
(let ((clauses (cons clause clauses)) (lambda (exp env)
(syntax-error (lambda (cl) (let ((clauses (cdr exp))
(error "invalid clause in `cond-expand'" cl)))) (syntax-error (lambda (cl)
(letrec (error "invalid clause in `cond-expand'" cl))))
((test-clause (letrec
(lambda (clause) ((test-clause
(cond (lambda (clause)
((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 (cond
((eq? 'and (car clause)) ((symbol? clause)
(let lp ((l (cdr clause))) (or (memq clause %cond-expand-features)
(cond ((null? l) (let lp ((uses (module-uses (env-module env))))
#t) (if (pair? uses)
((pair? l) (or (memq clause
(and (test-clause (car l)) (lp (cdr l)))) (hashq-ref %cond-expand-table
(else (car uses) '()))
(syntax-error clause))))) (lp (cdr uses)))
((eq? 'or (car clause)) #f))))
(let lp ((l (cdr clause))) ((pair? clause)
(cond ((null? l) (cond
#f) ((eq? 'and (car clause))
((pair? l) (let lp ((l (cdr clause)))
(or (test-clause (car l)) (lp (cdr l)))) (cond ((null? l)
(else #t)
(syntax-error clause))))) ((pair? l)
((eq? 'not (car clause)) (and (test-clause (car l)) (lp (cdr l))))
(cond ((not (pair? (cdr clause))) (else
(syntax-error clause)) (syntax-error clause)))))
((pair? (cddr clause)) ((eq? 'or (car clause))
((syntax-error clause)))) (let lp ((l (cdr clause)))
(not (test-clause (cadr clause)))) (cond ((null? l)
(else #f)
(syntax-error clause)))) ((pair? l)
(else (or (test-clause (car l)) (lp (cdr l))))
(syntax-error clause)))))) (else
(let lp ((c clauses)) (syntax-error clause)))))
(cond ((eq? 'not (car clause))
((null? c) (cond ((not (pair? (cdr clause)))
(error "Unfulfilled `cond-expand'")) (syntax-error clause))
((not (pair? c)) ((pair? (cddr clause))
(syntax-error c)) ((syntax-error clause))))
((not (pair? (car c))) (not (test-clause (cadr clause))))
(syntax-error (car c))) (else
((test-clause (caar c)) (syntax-error clause))))
`(begin ,@(cdar c))) (else
((eq? (caar c) 'else) (syntax-error clause))))))
(if (pair? (cdr c)) (let lp ((c clauses))
(cond
((null? c)
(error "Unfulfilled `cond-expand'"))
((not (pair? c))
(syntax-error c)) (syntax-error c))
`(begin ,@(cdar c))) ((not (pair? (car c)))
(else (syntax-error (car c)))
(lp (cdr 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 ;; 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. ;; numbers, which are the numbers of the SRFIs to be loaded on startup.