113 lines
3.8 KiB
Scheme
113 lines
3.8 KiB
Scheme
#lang scheme
|
|
|
|
(provide define-keywords function-with-arity expr-with-check except err
|
|
->args
|
|
->kwds-in
|
|
clauses-use-kwd)
|
|
|
|
(require
|
|
(for-template "syn-aux-aux.ss"
|
|
scheme
|
|
(rename-in lang/prim (first-order->higher-order f2h))))
|
|
|
|
#|
|
|
transform the clauses into the initial arguments specification
|
|
for a new expression that instantiates the appropriate class
|
|
|
|
ensure that all clauses mention only keywords specified in AllSpec or PartSpec
|
|
move the contracts from AppSpecl and PartSpec to the clauses
|
|
|
|
run ->rec? over all used keywords to discover the presence of special clauses
|
|
|
|
if anything fails, use the legal keyword to specialize the error message
|
|
|#
|
|
(define (->args tag stx clauses AllSpec PartSpec ->rec? legal)
|
|
(define msg (format "not a legal clause in a ~a description" legal))
|
|
(define Spec (append AllSpec PartSpec))
|
|
(define kwds (map (compose (curry datum->syntax stx) car) Spec))
|
|
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
|
|
(duplicates? tag spec)
|
|
(map (lambda (x)
|
|
(define kw (car x))
|
|
(define-values (key coercion)
|
|
(let loop ([kwds kwds][Spec Spec])
|
|
(if (free-identifier=? (car kwds) kw)
|
|
(values (car kwds) (cadar Spec))
|
|
(loop (cdr kwds) (cdr Spec)))))
|
|
(list key (coercion (cdr x))))
|
|
spec))
|
|
|
|
;; Symbol [Listof kw] -> true
|
|
;; effect: raise syntax error about duplicated clause
|
|
(define (duplicates? tag lox)
|
|
(let duplicates? ([lox lox])
|
|
(cond
|
|
[(empty? lox) false]
|
|
[else
|
|
(let* ([f (caar lox)]
|
|
[id (syntax-e f)]
|
|
[x (memf (lambda (x) (free-identifier=? (car x) f)) (rest lox))])
|
|
(if x
|
|
(raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x))
|
|
(duplicates? (rest lox))))])))
|
|
|
|
;; check whether rec? occurs, produce list of keywords
|
|
(define (clauses-use-kwd stx:list ->rec? legal-clause kwds)
|
|
(define kwd-in? (->kwds-in kwds))
|
|
(define double (string-append legal-clause ", ~a has been redefined"))
|
|
(map (lambda (stx)
|
|
(syntax-case stx ()
|
|
[(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))]
|
|
[(kw . E)
|
|
(let ([kw (syntax-e #'kw)])
|
|
(if (member kw (map syntax-e kwds))
|
|
(raise-syntax-error #f (format double kw) stx)
|
|
(raise-syntax-error #f legal-clause stx)))]
|
|
[_ (raise-syntax-error #f legal-clause stx)]))
|
|
stx:list))
|
|
|
|
;; [Listof SyntaxIdentifier] -> (Syntax -> Boolean)
|
|
(define (->kwds-in kwds)
|
|
(lambda (k)
|
|
(and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
|
|
|
|
(define-syntax-rule (define-keywords the-list (kw coerce) ...)
|
|
(begin
|
|
(provide kw ...)
|
|
(define-syntax (kw x)
|
|
(raise-syntax-error 'kw "used out of context" x))
|
|
...
|
|
(define-for-syntax the-list (list (list #'kw (coerce ''kw)) ...))))
|
|
|
|
(define-syntax (expr-with-check stx)
|
|
(syntax-case stx ()
|
|
[(_ check> msg)
|
|
#`(lambda (tag)
|
|
(lambda (p)
|
|
(syntax-case p ()
|
|
[(_ x) #`(check> #,tag x)]
|
|
[_ (err tag p msg)])))]))
|
|
|
|
(define-syntax function-with-arity
|
|
(syntax-rules (except)
|
|
[(_ arity)
|
|
(lambda (tag)
|
|
(lambda (p)
|
|
(syntax-case p ()
|
|
[(_ x) #`(proc> #,tag (f2h x) arity)]
|
|
[_ (err tag p)])))]
|
|
[(_ arity except extra)
|
|
(lambda (tag)
|
|
(lambda (p)
|
|
(syntax-case p ()
|
|
[(_ x) #`(proc> #,tag (f2h x) arity)]
|
|
extra
|
|
[_ (err tag p)])))]))
|
|
|
|
(define (err spec p . xtras)
|
|
(raise-syntax-error (cadr spec)
|
|
(if (null? xtras)
|
|
"illegal specification"
|
|
(string-append "illegal specification: " (car xtras)))
|
|
p))
|