suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Redo `define-cstruct' with proper errors and more concisely.

Browse Source
This commit is contained in:
Eli Barzilay 2010-11-12 05:42:54 -05:00
parent 578fadb3a9
commit 4f36ce9635
1 changed files with 40 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
collects/ffi/unsafe.rkt
View File

@ -1347,67 +1347,47 @@
(values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag
make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ...
list->TYPE list*->TYPE TYPE->list TYPE->list*))))))))
(define (identifiers? stx)
(andmap identifier? (syntax->list stx)))
(define (_-identifier? id stx)
(and (identifier? id)
(or (regexp-match #rx"^_." (symbol->string (syntax-e id)))
(raise-syntax-error #f "cstruct name must begin with a `_'"
stx id))))
;; there is something wrong with the syntax, this function will find what it is
(define (syntax-error stx)
(define (check-rest rest)
(syntax-case rest ()
[() (void)]
[else (raise-syntax-error #f "extra arguments given" rest)]))
(define (check-alignment alignment)
(syntax-case alignment ()
[(#:alignment alignment-expr rest ...)
(check-rest #'(rest ...))]
[else (raise-syntax-error #f "the last argument can only be #:alignment" alignment)]))
(define (check-slots slots)
(define (check-slot slot)
(syntax-case slot ()
[(name field) (void)]
[else (raise-syntax-error #f "a field must be a pair of a name and a ctype such as [x _int]" slot)]))
;; check that some slots are given
(syntax-case slots ()
[([name-id expr-id] ... . rest)
(when (and (identifiers? #'(name-id ...))
(identifiers? #'(expr-id ...)))
(raise-syntax-error #f "fields must be a parenthesized list of name and a ctype such as ([x _int] [y _int])" slots))])
(syntax-case slots ()
[((slot ...) rest ...)
(begin
(for ([slot-stx (in-list (syntax->list #'(slot ...)))])
(check-slot slot-stx))
(check-alignment #'(rest ...)))]
[else (raise-syntax-error #f "fields must be a parenthesized list such as ([x _int] [y _int])" slots)]))
(define (check-name stx)
(syntax-case stx ()
[(_ _TYPE rest ...)
(check-slots #'(rest ...))]
[else (raise-syntax-error #f "a name must be provided to cstruct" stx)]))
(check-name stx))
(define (err what . xs)
(apply raise-syntax-error #f
(if (list? what) (apply string-append what) what)
stx xs))
(syntax-case stx ()
[(_ _TYPE ([slot slot-type] ...))
(and (_-identifier? #'_TYPE stx)
(identifiers? #'(slot ...)))
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'#f)]
[(_ _TYPE ([slot slot-type] ...) #:alignment alignment-expr)
(and (_-identifier? #'_TYPE stx)
(identifiers? #'(slot ...)))
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'alignment-expr)]
[(_ (_TYPE _SUPER) ([slot slot-type] ...))
(and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
(with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'#f))]
[(_ (_TYPE _SUPER) ([slot slot-type] ...) #:alignment alignment-expr)
(and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...)))
(with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'alignment-expr))]
[else (syntax-error stx)]))
[(_ type ([slot slot-type] ...) . more)
(let-values ([(_TYPE _SUPER)
(syntax-case #'type ()
[(t s) (values #'t #'s)]
[_ (values #'type #f)])]
[(alignment)
(syntax-case #'more ()
[() #'#f]
[(#:alignment) (err "missing expression for #:alignment")]
[(#:alignment a) #'a]
[(#:alignment a x . _) (err "unexpected form" #'x)]
[(x . _) (err (if (keyword? (syntax-e #'x))
"unknown keyword" "unexpected form")
#'x)])])
(unless (identifier? _TYPE)
(err "bad type, expecting a _name identifier or (_name super-ctype)"
_TYPE))
(unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE)))
(err "cstruct name must begin with a `_'" _TYPE))
(for ([s (in-list (syntax->list #'(slot ...)))])
(unless (identifier? s)
(err "bad field name, expecting an identifier identifier" s)))
(if _SUPER
(make-syntax _TYPE #t
#`(#,(datum->syntax _TYPE 'super _TYPE) slot ...)
#`(#,_SUPER slot-type ...)
alignment)
(make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))]
;; specific errors for bad slot specs, leave the rest for a generic error
[(_ type (bad ...) . more)
(err "bad slot specification, expecting [name ctype]"
(ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s]))
(syntax->list #'(bad ...))))]
[(_ type bad . more)
(err "bad slot specification, expecting a sequence of [name ctype]"
#'bad)]))
;; helper for the above: keep runtime information on structs
(define cstruct-info