mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +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 '())
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.