624 lines
29 KiB
Scheme
624 lines
29 KiB
Scheme
|
|
;; Based on
|
|
;; (planet "struct.ss" ("ryanc" "macros.plt" 1 0)))
|
|
|
|
(module define-struct '#%kernel
|
|
(#%require "more-scheme.ss" "small-scheme.ss" "define.ss" "../stxparam.ss"
|
|
(for-syntax '#%kernel "define.ss"
|
|
"stx.ss" "stxcase-scheme.ss" "small-scheme.ss"
|
|
"stxloc.ss" "qqstx.ss"
|
|
"struct-info.ss"))
|
|
|
|
(#%provide define-struct*
|
|
define-struct/derived
|
|
struct-field-index
|
|
struct-copy
|
|
(for-syntax
|
|
(rename checked-struct-info-rec? checked-struct-info?)))
|
|
|
|
(define-values-for-syntax
|
|
(struct:checked-struct-info
|
|
make-checked-struct-info
|
|
checked-struct-info-rec?
|
|
checked-struct-info-ref
|
|
checked-struct-info-set!)
|
|
(make-struct-type 'checked-struct-info struct:struct-info
|
|
0 0 #f
|
|
null (current-inspector)
|
|
(lambda (v stx)
|
|
(raise-syntax-error
|
|
#f
|
|
"identifier for static struct-type information cannot be used as an expression"
|
|
stx))
|
|
null
|
|
(lambda (proc info)
|
|
(if (and (procedure? proc)
|
|
(procedure-arity-includes? proc 0))
|
|
proc
|
|
(raise-type-error 'make-struct-info
|
|
"procedure (arity 0)"
|
|
proc)))))
|
|
|
|
(define-syntax-parameter struct-field-index
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "allowed only within a structure type definition" stx)))
|
|
|
|
(define (check-struct-type name what)
|
|
(when what
|
|
(unless (struct-type? what)
|
|
(raise-type-error name "struct-type or #f" what)))
|
|
what)
|
|
|
|
(define (check-inspector name what)
|
|
(when what
|
|
(unless (inspector? what)
|
|
(raise-type-error name "inspector or #f" what)))
|
|
what)
|
|
|
|
(define-syntax (define-struct* stx)
|
|
(syntax-case stx ()
|
|
[(_ . rest)
|
|
(with-syntax ([stx stx])
|
|
#'(define-struct/derived stx . rest))]))
|
|
|
|
(define-syntax (define-struct/derived full-stx)
|
|
(define make-field list)
|
|
(define field-id car)
|
|
(define field-default-value cadr)
|
|
(define field-auto? caddr)
|
|
(define field-mutable? cadddr)
|
|
|
|
(define (build-name id . parts)
|
|
(datum->syntax
|
|
id
|
|
(string->symbol
|
|
(apply string-append
|
|
(map (lambda (p)
|
|
(if (syntax? p)
|
|
(symbol->string (syntax-e p))
|
|
p))
|
|
parts)))
|
|
id))
|
|
|
|
(define (bad why kw where . alt)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "~a ~a specification~a"
|
|
why
|
|
(if (string? kw)
|
|
kw
|
|
(syntax-e kw))
|
|
where)
|
|
stx
|
|
(if (null? alt) kw (car alt))))
|
|
|
|
(define (check-exprs orig-n ps)
|
|
(let loop ([nps (cdr ps)][n orig-n])
|
|
(unless (zero? n)
|
|
(unless (and (pair? nps)
|
|
(not (keyword? (syntax-e (car nps)))))
|
|
(raise-syntax-error
|
|
#f
|
|
(format "expected ~a expression~a after keyword~a"
|
|
orig-n
|
|
(if (= orig-n 1) "" "s")
|
|
(if (pair? nps)
|
|
", found a keyword"
|
|
""))
|
|
stx
|
|
(car ps)))
|
|
(loop (cdr nps) (sub1 n)))))
|
|
|
|
;; Parse one field with a sequence of keyword-based specs:
|
|
(define (parse-field f)
|
|
(syntax-case f ()
|
|
[id
|
|
(identifier? #'id)
|
|
(make-field #'id #f #f #f)]
|
|
[(id p ...)
|
|
(identifier? #'id)
|
|
(let loop ([ps (syntax->list #'(p ...))]
|
|
[def-val #f]
|
|
[auto? #f]
|
|
[mutable? #f])
|
|
(cond
|
|
[(null? ps) (make-field #'id def-val auto? mutable?)]
|
|
[(eq? '#:mutable (syntax-e (car ps)))
|
|
(when mutable?
|
|
(bad "redundant" (car ps) " for field"))
|
|
(loop (cdr ps) def-val auto? #t)]
|
|
#;
|
|
[(eq? #:default (syntax-e (car ps)))
|
|
(check-exprs 1 ps)
|
|
(when def-val
|
|
(bad "multiple" (car ps) " for field"))
|
|
(loop (cddr ps) (cadr ps) auto? mutable?)]
|
|
[(eq? '#:auto (syntax-e (car ps)))
|
|
(when auto?
|
|
(bad "redundant" (car ps) " for field"))
|
|
(loop (cdr ps) def-val #t mutable?)]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
(if (keyword? (syntax-e (car ps)))
|
|
"unrecognized field-specification keyword"
|
|
"expected a field-specification keyword")
|
|
stx
|
|
(car ps))]))]
|
|
[_else
|
|
(raise-syntax-error
|
|
#f
|
|
"expected a field identifier or a parenthesized identifier and field-specification sequence"
|
|
stx
|
|
f)]))
|
|
|
|
(define (lookup config s)
|
|
(cdr (assq s config)))
|
|
|
|
(define (extend-config config s val)
|
|
(cond
|
|
[(null? config) (error 'struct "internal error: can't find config element: ~s" s)]
|
|
[(eq? (caar config) s) (cons (cons s val) (cdr config))]
|
|
[else (cons (car config) (extend-config (cdr config) s val))]))
|
|
|
|
(define insp-keys
|
|
"#:inspector, #:transparent, or #:prefab")
|
|
|
|
;; Parse sequence of keyword-based struct specs
|
|
(define (parse-props fm p super-id)
|
|
(let loop ([p p]
|
|
[config '((#:super . #f)
|
|
(#:inspector . #f)
|
|
(#:auto-value . #f)
|
|
(#:props . ())
|
|
(#:mutable . #f)
|
|
(#:guard . #f)
|
|
(#:omit-define-values . #f)
|
|
(#:omit-define-syntaxes . #f))]
|
|
[nongen? #f])
|
|
(cond
|
|
[(null? p) config]
|
|
[(eq? '#:super (syntax-e (car p)))
|
|
(check-exprs 1 p)
|
|
(when (lookup config '#:super)
|
|
(bad "multiple" (car p) "s"))
|
|
(when super-id
|
|
(raise-syntax-error
|
|
#f
|
|
(string-append
|
|
"#:super specification disallowed because a struct supertype id"
|
|
" was supplied with the struct type id")
|
|
stx
|
|
(car p)))
|
|
(loop (cddr p)
|
|
(extend-config config '#:super (cadr p))
|
|
nongen?)]
|
|
[(memq (syntax-e (car p))
|
|
'(#:guard #:auto-value))
|
|
(let ([key (syntax-e (car p))])
|
|
(check-exprs 1 p)
|
|
(when (lookup config key)
|
|
(bad "multiple" (car p) "s"))
|
|
(when (and nongen?
|
|
(eq? key '#:guard))
|
|
(bad "cannot provide" (car p) " for prefab structure type"))
|
|
(loop (cddr p)
|
|
(extend-config config key (cadr p))
|
|
nongen?))]
|
|
[(eq? '#:property (syntax-e (car p)))
|
|
(check-exprs 2 p)
|
|
(when nongen?
|
|
(bad "cannot use" (car p) " for prefab structure type"))
|
|
(loop (cdddr p)
|
|
(extend-config config
|
|
'#:props
|
|
(cons (cons (cadr p) (caddr p))
|
|
(lookup config '#:props)))
|
|
nongen?)]
|
|
[(eq? '#:inspector (syntax-e (car p)))
|
|
(check-exprs 1 p)
|
|
(when (lookup config '#:inspector)
|
|
(bad "multiple" insp-keys "s" (car p)))
|
|
(loop (cddr p)
|
|
(extend-config config '#:inspector
|
|
#`(check-inspector '#,fm #,(cadr p)))
|
|
nongen?)]
|
|
[(eq? '#:transparent (syntax-e (car p)))
|
|
(when (lookup config '#:inspector)
|
|
(bad "multiple" insp-keys "s" (car p)))
|
|
(loop (cdr p)
|
|
(extend-config config '#:inspector #'#f)
|
|
nongen?)]
|
|
[(eq? '#:prefab (syntax-e (car p)))
|
|
(when (lookup config '#:inspector)
|
|
(bad "multiple" insp-keys "s" (car p)))
|
|
(when (pair? (lookup config '#:props))
|
|
(bad "cannot use" (car p) " for a structure type with properties"))
|
|
(when (lookup config '#:guard)
|
|
(bad "cannot use" (car p) " for a structure type with a guard"))
|
|
(loop (cdr p)
|
|
(extend-config config '#:inspector #''prefab)
|
|
#t)]
|
|
[(memq (syntax-e (car p))
|
|
'(#:mutable #:omit-define-values #:omit-define-syntaxes))
|
|
(let ([key (syntax-e (car p))])
|
|
(when (lookup config key)
|
|
(bad "redundant" (car p) ""))
|
|
(loop (cdr p)
|
|
(extend-config config key #t)
|
|
nongen?))]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
(if (keyword? (syntax-e (car p)))
|
|
"unrecognized struct-specification keyword"
|
|
"expected a struct-specification keyword")
|
|
stx
|
|
(car p))])))
|
|
|
|
(define stx (syntax-case full-stx ()
|
|
[(_ stx . _) #'stx]))
|
|
|
|
(syntax-case full-stx ()
|
|
[(_ (fm . _) id (field ...) prop ...)
|
|
(let-values ([(id super-id)
|
|
(if (identifier? #'id)
|
|
(values #'id #f)
|
|
(syntax-case #'id ()
|
|
[(id super-id)
|
|
(and (identifier? #'id)
|
|
(identifier? #'super-id))
|
|
(values #'id #'super-id)]
|
|
[else
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax; expected <id> for structure-type name or (<id> <id>) for name and supertype name"
|
|
stx
|
|
#'id)]))])
|
|
(let-values ([(super-info super-info-checked?)
|
|
(if super-id
|
|
(let ([v (syntax-local-value super-id (lambda () #f))])
|
|
(if (struct-info? v)
|
|
(values (extract-struct-info v) (checked-struct-info-rec? v))
|
|
(raise-syntax-error
|
|
#f
|
|
(format "parent struct type not defined~a"
|
|
(if v
|
|
(format " (~a does not name struct type information)"
|
|
(syntax-e super-id))
|
|
""))
|
|
stx
|
|
super-id)))
|
|
;; if there's no super type, it's like it was checked
|
|
(values #f #t))])
|
|
(when (and super-info
|
|
(not (car super-info)))
|
|
(raise-syntax-error
|
|
#f
|
|
"no structure type descriptor available for supertype"
|
|
stx
|
|
super-id))
|
|
(let* ([field-stxes (syntax->list #'(field ...))]
|
|
[fields (map parse-field field-stxes)]
|
|
[dup (check-duplicate-identifier (map field-id fields))])
|
|
(when dup
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate field identifier"
|
|
stx
|
|
dup))
|
|
(let ([auto-count
|
|
(let loop ([fields fields] [field-stxes field-stxes] [auto? #f])
|
|
(cond
|
|
[(null? fields) 0]
|
|
[(field-auto? (car fields))
|
|
(+ 1 (loop (cdr fields) (cdr field-stxes) #t))]
|
|
[auto?
|
|
(raise-syntax-error
|
|
#f
|
|
"non-auto field after an auto field disallowed"
|
|
stx
|
|
(car field-stxes))]
|
|
[else
|
|
(loop (cdr fields) (cdr field-stxes) #f)]))])
|
|
(let-values ([(inspector super-expr props auto-val guard mutable?
|
|
omit-define-values? omit-define-syntaxes?)
|
|
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
|
|
(values (lookup config '#:inspector)
|
|
(lookup config '#:super)
|
|
(lookup config '#:props)
|
|
(lookup config '#:auto-value)
|
|
(lookup config '#:guard)
|
|
(lookup config '#:mutable)
|
|
(lookup config '#:omit-define-values)
|
|
(lookup config '#:omit-define-syntaxes)))])
|
|
(when mutable?
|
|
(for-each (lambda (f f-stx)
|
|
(when (field-mutable? f)
|
|
(raise-syntax-error
|
|
#f
|
|
"redundant #:mutable specification in field"
|
|
stx
|
|
f-stx)))
|
|
fields field-stxes))
|
|
(let ([struct: (build-name id "struct:" id)]
|
|
[make- (build-name id "make-" id)]
|
|
[? (build-name id id "?")]
|
|
[sels (map (lambda (f)
|
|
(build-name id ; (field-id f)
|
|
id "-" (field-id f)))
|
|
fields)]
|
|
[sets (let loop ([fields fields])
|
|
(cond
|
|
[(null? fields) null]
|
|
[(not (or mutable? (field-mutable? (car fields))))
|
|
(loop (cdr fields))]
|
|
[else
|
|
(cons (build-name id ; (field-id (car fields))
|
|
"set-"
|
|
id
|
|
"-"
|
|
(field-id (car fields))
|
|
"!")
|
|
(loop (cdr fields)))]))]
|
|
[super-struct: (if super-info
|
|
(or (car super-info)
|
|
(raise-syntax-error
|
|
#f
|
|
"no structure type descriptor available for supertype"
|
|
stx
|
|
super-id))
|
|
(and super-expr
|
|
#`(check-struct-type 'fm #,super-expr)))])
|
|
(let ([run-time-defns
|
|
(lambda ()
|
|
(quasisyntax/loc stx
|
|
(define-values (#,struct: #,make- #,? #,@sels #,@sets)
|
|
(let-values ([(struct: make- ? -ref -set!)
|
|
(syntax-parameterize ([struct-field-index
|
|
(lambda (stx)
|
|
(syntax-case stx #,(map field-id fields)
|
|
#,@(let loop ([fields fields][pos 0])
|
|
(cond
|
|
[(null? fields) null]
|
|
[else (cons #`[(_ #,(field-id (car fields))) #'#,pos]
|
|
(loop (cdr fields) (add1 pos)))]))
|
|
[(_ name) (raise-syntax-error #f "no such field" stx #'name)]))])
|
|
(make-struct-type '#,id
|
|
#,super-struct:
|
|
#,(- (length fields) auto-count)
|
|
#,auto-count
|
|
#,auto-val
|
|
#,(if (null? props)
|
|
#'null
|
|
#`(list #,@(map (lambda (p)
|
|
#`(cons #,(car p) #,(cdr p)))
|
|
props)))
|
|
#,(or inspector
|
|
#`(current-inspector))
|
|
#f
|
|
'#,(let loop ([i 0]
|
|
[fields fields])
|
|
(cond
|
|
[(null? fields) null]
|
|
[(field-auto? (car fields)) null]
|
|
[(not (or mutable? (field-mutable? (car fields))))
|
|
(cons i (loop (add1 i) (cdr fields)))]
|
|
[else (loop (add1 i) (cdr fields))]))
|
|
#,guard))])
|
|
(values struct: make- ?
|
|
#,@(let loop ([i 0][fields fields])
|
|
(if (null? fields)
|
|
null
|
|
(cons #`(make-struct-field-accessor -ref #,i '#,(field-id (car fields)))
|
|
(loop (add1 i) (cdr fields)))))
|
|
#,@(let loop ([i 0][fields fields])
|
|
(if (null? fields)
|
|
null
|
|
(if (not (or mutable? (field-mutable? (car fields))))
|
|
(loop (add1 i) (cdr fields))
|
|
(cons #`(make-struct-field-mutator -set! #,i '#,(field-id (car fields)))
|
|
(loop (add1 i) (cdr fields)))))))))))]
|
|
[compile-time-defns
|
|
(lambda ()
|
|
(let ([protect (lambda (sel)
|
|
(and sel
|
|
(if (syntax-e sel)
|
|
#`(c (quote-syntax #,sel))
|
|
sel)))]
|
|
[mk-info (if super-info-checked?
|
|
#'make-checked-struct-info
|
|
#'make-struct-info)])
|
|
(quasisyntax/loc stx
|
|
(define-syntaxes (#,id)
|
|
(let ([c (syntax-local-certifier)])
|
|
(#,mk-info
|
|
(lambda ()
|
|
(list
|
|
(c (quote-syntax #,struct:))
|
|
(c (quote-syntax #,make-))
|
|
(c (quote-syntax #,?))
|
|
(list
|
|
#,@(map protect (reverse sels))
|
|
#,@(if super-info
|
|
(map protect (list-ref super-info 3))
|
|
(if super-expr
|
|
'(#f)
|
|
null)))
|
|
(list
|
|
#,@(reverse
|
|
(let loop ([fields fields][sets sets])
|
|
(cond
|
|
[(null? fields) null]
|
|
[(not (or mutable? (field-mutable? (car fields))))
|
|
(cons #f (loop (cdr fields) sets))]
|
|
[else
|
|
(cons (protect (car sets))
|
|
(loop (cdr fields) (cdr sets)))])))
|
|
#,@(if super-info
|
|
(map protect (list-ref super-info 4))
|
|
(if super-expr
|
|
'(#f)
|
|
null)))
|
|
#,(if super-id
|
|
(protect super-id)
|
|
(if super-expr
|
|
#f
|
|
#t))))))))))])
|
|
(let ([result
|
|
(cond
|
|
[(and (not omit-define-values?) (not omit-define-syntaxes?))
|
|
#`(begin #,(run-time-defns) #,(compile-time-defns))]
|
|
[omit-define-syntaxes?
|
|
(run-time-defns)]
|
|
[omit-define-values?
|
|
(compile-time-defns)]
|
|
[else #'(begin)])])
|
|
(if super-id
|
|
(syntax-property result
|
|
'disappeared-use
|
|
(syntax-local-introduce super-id))
|
|
result)))))))))]
|
|
[(_ _ id . _)
|
|
(not (or (identifier? #'id)
|
|
(and (syntax->list #'id)
|
|
(= 2 (length (syntax->list #'id)))
|
|
(andmap identifier? (syntax->list #'id)))))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax; expected <id> for structure-type name or (<id> <id>) for name and supertype name"
|
|
stx
|
|
#'id)]
|
|
[(_ _ id (field ...) . _)
|
|
(begin
|
|
(for-each parse-field (syntax->list #'(field ...)))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax after field sequence"
|
|
stx))]
|
|
[(_ _ id fields . _)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax; expected a parenthesized sequence of field descriptions"
|
|
stx
|
|
#'fields)]
|
|
[(_ _ id)
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax; missing fields"
|
|
stx)]
|
|
[_
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
stx)]))
|
|
|
|
(define-syntax (struct-copy stx)
|
|
(if (not (eq? (syntax-local-context) 'expression))
|
|
(quasisyntax/loc stx (#%expression #,stx))
|
|
(syntax-case stx ()
|
|
[(form-name info struct-expr field+val ...)
|
|
(let ([ans (syntax->list #'(field+val ...))])
|
|
;; Check syntax:
|
|
(unless (identifier? #'info)
|
|
(raise-syntax-error #f "not an identifier for structure type" stx #'info))
|
|
(for-each (lambda (an)
|
|
(syntax-case an ()
|
|
[(field val)
|
|
(unless (identifier? #'field)
|
|
(raise-syntax-error #f
|
|
"not an identifier for field name"
|
|
stx
|
|
#'field))]
|
|
[_
|
|
(raise-syntax-error #f
|
|
"expected a field update fo the form (<field-id> <expr>)"
|
|
stx
|
|
an)]))
|
|
ans)
|
|
|
|
(let ([new-fields
|
|
(map (lambda (an)
|
|
(syntax-case an ()
|
|
[(field expr)
|
|
(list (datum->syntax #'field
|
|
(string->symbol
|
|
(format "~a-~a"
|
|
(syntax-e #'info)
|
|
(syntax-e #'field)))
|
|
#'field)
|
|
#'expr
|
|
(car (generate-temporaries (list #'field))))]))
|
|
ans)])
|
|
|
|
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
|
|
(let ([new-binding-for
|
|
(lambda (f)
|
|
(ormap (lambda (new-field)
|
|
(and (free-identifier=? (car new-field) f)
|
|
(caddr new-field)))
|
|
new-fields))])
|
|
|
|
(let-values ([(construct pred accessors)
|
|
(let ([v (syntax-local-value #'info (lambda () #f))])
|
|
(unless (struct-info? v)
|
|
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
|
|
(let ([v (extract-struct-info v)])
|
|
(values (cadr v)
|
|
(caddr v)
|
|
(cadddr v))))])
|
|
(unless construct
|
|
(raise-syntax-error #f
|
|
"constructor not statically known for structure type"
|
|
stx
|
|
#'info))
|
|
(unless pred
|
|
(raise-syntax-error #f
|
|
"predicate not statically known for structure type"
|
|
stx
|
|
#'info))
|
|
(unless (andmap values accessors)
|
|
(raise-syntax-error #f
|
|
"not all accessors are statically known for structure type"
|
|
stx
|
|
#'info))
|
|
(let ([dests
|
|
(map (lambda (new-field)
|
|
(or (ormap (lambda (f2)
|
|
(and f2
|
|
(free-identifier=? (car new-field) f2)
|
|
f2))
|
|
accessors)
|
|
(raise-syntax-error #f
|
|
"accessor name not associated with the given structure type"
|
|
stx
|
|
(car new-field))))
|
|
new-fields)])
|
|
;; Check for duplicates using dests, not as, because mod=? as might not be id=?
|
|
(let ((dupe (check-duplicate-identifier dests)))
|
|
(when dupe
|
|
(raise-syntax-error #f
|
|
"duplicate field assignment"
|
|
stx
|
|
;; Map back to an original field:
|
|
(ormap (lambda (nf)
|
|
(and nf
|
|
(free-identifier=? dupe (car nf))
|
|
(car nf)))
|
|
(reverse new-fields)))))
|
|
|
|
;; the actual result
|
|
#`(let ((the-struct struct-expr))
|
|
(if (#,pred the-struct)
|
|
(let #,(map (lambda (new-field)
|
|
#`[#,(caddr new-field) #,(cadr new-field)])
|
|
new-fields)
|
|
(#,construct
|
|
#,@(map
|
|
(lambda (field) (or (new-binding-for field)
|
|
#`(#,field the-struct)))
|
|
(reverse accessors))))
|
|
(raise-type-error 'form-name
|
|
#,(format "~a" (syntax-e #'info))
|
|
the-struct))))))))]))))
|