82 lines
2.8 KiB
Scheme
82 lines
2.8 KiB
Scheme
|
|
;;----------------------------------------------------------------------
|
|
;; cond
|
|
|
|
(module cond '#%kernel
|
|
(#%require (for-syntax "stx.ss" "qq-and-or.ss" '#%kernel))
|
|
|
|
(define-syntaxes (=>)
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "arrow not allowed as an expression" stx)))
|
|
|
|
(define-syntaxes (else)
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "not allowed as an expression" stx)))
|
|
|
|
(define-syntaxes (cond)
|
|
(let ([here (quote-syntax here)])
|
|
(lambda (in-form)
|
|
(if (identifier? in-form)
|
|
(raise-syntax-error #f "bad syntax" in-form)
|
|
(void))
|
|
(datum->syntax
|
|
here
|
|
(let ([form (stx-cdr in-form)]
|
|
[serror
|
|
(lambda (msg at)
|
|
(raise-syntax-error #f msg in-form at))])
|
|
(let loop ([tests form][first? #t])
|
|
(if (stx-null? tests)
|
|
(quote-syntax (void))
|
|
(if (not (stx-pair? tests))
|
|
(serror
|
|
"bad syntax (body must contain a list of pairs)"
|
|
tests)
|
|
(let ([line (stx-car tests)]
|
|
[rest (stx-cdr tests)])
|
|
(if (not (stx-pair? line))
|
|
(serror
|
|
"bad syntax (clause is not a test-value pair)"
|
|
line)
|
|
(let* ([test (stx-car line)]
|
|
[value (stx-cdr line)]
|
|
[else? (and (identifier? test)
|
|
(free-identifier=? test (quote-syntax else)))])
|
|
(if (and else? (stx-pair? rest))
|
|
(serror "bad syntax (`else' clause must be last)" line)
|
|
(void))
|
|
(if (and (not else?)
|
|
(stx-pair? value)
|
|
(identifier? (stx-car value))
|
|
(free-identifier=? (stx-car value) (quote-syntax =>)))
|
|
(if (and (stx-pair? (stx-cdr value))
|
|
(stx-null? (stx-cdr (stx-cdr value))))
|
|
(let ([test (if else?
|
|
#t
|
|
test)]
|
|
[gen (gen-temp-id 'c)])
|
|
`(,(quote-syntax let-values) ([(,gen) ,test])
|
|
(,(quote-syntax if) ,gen
|
|
(,(stx-car (stx-cdr value)) ,gen)
|
|
,(loop rest #f))))
|
|
(serror
|
|
"bad syntax (bad clause form with =>)"
|
|
line))
|
|
(if else?
|
|
(if first?
|
|
;; first => be careful not to introduce a splicable begin...
|
|
`(,(quote-syntax if) #t ,(cons (quote-syntax begin) value) (void))
|
|
;; we're in an `if' branch already...
|
|
(cons (quote-syntax begin) value))
|
|
(if (stx-null? value)
|
|
(let ([gen (gen-temp-id 'c)])
|
|
`(,(quote-syntax let-values) ([(,gen) ,test])
|
|
(,(quote-syntax if) ,gen ,gen ,(loop rest #f))))
|
|
(list
|
|
(quote-syntax if) test
|
|
(cons (quote-syntax begin) value)
|
|
(loop rest #f))))))))))))
|
|
in-form))))
|
|
|
|
(#%provide cond else =>))
|