mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Make `cond-expand' compilable.

Browse source 
* module/ice-9/boot-9.scm (cond-expand): Changed into a `define-macro'
  macro.
This commit is contained in:
Ludovic Courtès 2009-06-19 22:46:07 +02:00
parent 23044464c2
commit f4bf64b4d4
1 changed files with 60 additions and 63 deletions
Download patch file Download diff file Expand all files Collapse all files

123
module/ice-9/boot-9.scm
View file

@ -3192,69 +3192,66 @@ module '(ice-9 q) '(make-q q-length))}."
(append (hashq-ref %cond-expand-table mod '()) (append (hashq-ref %cond-expand-table mod '())
features))))) features)))))
(define cond-expand (define-macro (cond-expand . clauses)
(procedure->memoizing-macro (let ((syntax-error (lambda (cl)
(lambda (exp env) (error "invalid clause in `cond-expand'" cl))))
(let ((clauses (cdr exp)) (letrec
(syntax-error (lambda (cl) ((test-clause
(error "invalid clause in `cond-expand'" cl)))) (lambda (clause)
(letrec (cond
((test-clause ((symbol? clause)
(lambda (clause) (or (memq clause %cond-expand-features)
(cond (let lp ((uses (module-uses (current-module))))
((symbol? clause) (if (pair? uses)
(or (memq clause %cond-expand-features) (or (memq clause
(let lp ((uses (module-uses (env-module env)))) (hashq-ref %cond-expand-table
(if (pair? uses) (car uses) '()))
(or (memq clause (lp (cdr uses)))
(hashq-ref %cond-expand-table #f))))
(car uses) '())) ((pair? clause)
(lp (cdr uses))) (cond
#f)))) ((eq? 'and (car clause))
((pair? clause) (let lp ((l (cdr clause)))
(cond (cond ((null? l)
((eq? 'and (car clause)) #t)
(let lp ((l (cdr clause))) ((pair? l)
(cond ((null? l) (and (test-clause (car l)) (lp (cdr l))))
#t) (else
((pair? l) (syntax-error clause)))))
(and (test-clause (car l)) (lp (cdr l)))) ((eq? 'or (car clause))
(else (let lp ((l (cdr clause)))
(syntax-error clause))))) (cond ((null? l)
((eq? 'or (car clause)) #f)
(let lp ((l (cdr clause))) ((pair? l)
(cond ((null? l) (or (test-clause (car l)) (lp (cdr l))))
#f) (else
((pair? l) (syntax-error clause)))))
(or (test-clause (car l)) (lp (cdr l)))) ((eq? 'not (car clause))
(else (cond ((not (pair? (cdr clause)))
(syntax-error clause))))) (syntax-error clause))
((eq? 'not (car clause)) ((pair? (cddr clause))
(cond ((not (pair? (cdr clause))) ((syntax-error clause))))
(syntax-error clause)) (not (test-clause (cadr clause))))
((pair? (cddr clause)) (else
((syntax-error clause)))) (syntax-error clause))))
(not (test-clause (cadr clause)))) (else
(else (syntax-error clause))))))
(syntax-error clause)))) (let lp ((c clauses))
(else (cond
(syntax-error clause)))))) ((null? c)
(let lp ((c clauses)) (error "Unfulfilled `cond-expand'"))
(cond ((not (pair? c))
((null? c) (syntax-error c))
(error "Unfulfilled `cond-expand'")) ((not (pair? (car c)))
((not (pair? c)) (syntax-error (car c)))
(syntax-error c)) ((test-clause (caar c))
((not (pair? (car c))) `(begin ,@(cdar c)))
(syntax-error (car c))) ((eq? (caar c) 'else)
((test-clause (caar c)) (if (pair? (cdr c))
`(begin ,@(cdar c))) (syntax-error c))
((eq? (caar c) 'else) `(begin ,@(cdar c)))
(if (pair? (cdr c)) (else
(syntax-error c)) (lp (cdr 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.