Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: wtetzner/racket
base: v5.3
...
head fork: wtetzner/racket
compare: struct-keyword-args
Checking mergeability… Don't worry, you can still create the pull request.
  • 5 commits
  • 1 file changed
  • 0 commit comments
  • 1 contributor
Showing with 159 additions and 14 deletions.
  1. +159 −14 collects/racket/private/define-struct.rkt
View
173 collects/racket/private/define-struct.rkt
@@ -2,11 +2,12 @@
;; (planet "struct.ss" ("ryanc" "macros.plt" 1 0)))
(module define-struct '#%kernel
- (#%require "small-scheme.rkt" "define.rkt" "../stxparam.rkt"
+ (#%require "small-scheme.rkt" "define.rkt" "../stxparam.rkt" "kw.rkt"
(for-syntax '#%kernel "define.rkt"
"stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt"
"stxloc.rkt" "qqstx.rkt"
- "struct-info.rkt"))
+ "struct-info.rkt"
+ "reverse.rkt"))
(#%provide define-struct*
define-struct/derived
@@ -115,6 +116,92 @@
(with-syntax ([stx stx])
#'(define-struct/derived stx . rest))]))
+ (define-for-syntax (id->keyword id)
+ (datum->syntax id
+ (string->keyword
+ (symbol->string
+ (syntax->datum id)))))
+
+ ;; Compute the argument syntax for defining a keyword argument
+ ;; constructor
+ (define-for-syntax (ids->keyword-args ids config)
+ (define (default? field)
+ (let ([field (if (syntax? field)
+ (syntax->datum field)
+ field)])
+ (or (and (assoc 'vals config)
+ (assoc field (cdr (assoc 'vals config))))
+ (assoc 'default config))))
+ (let* ([kparams
+ (map (λ (id)
+ (let ([default (default? id)]
+ [gen (car (generate-temporaries
+ (list id)))])
+ (list (id->keyword id)
+ (if default
+ (list gen
+ (cdr default))
+ gen))))
+ (syntax->list ids))]
+ [knames
+ (map (λ (param)
+ (if (list? (cadr param))
+ (caadr param)
+ (cadr param)))
+ kparams)])
+ (values (apply append kparams) knames)))
+
+ ;; Parse the value of #:keyword-constructor into a useful
+ ;; datastructure. Returns #f if it's invalid
+ (define-for-syntax (parse-keyword-constructor-val val)
+ (define (defaults->alist data)
+ (map (λ (val)
+ (let ([val (syntax->list val)])
+ (cons (syntax->datum (car val))
+ (cadr val))))
+ data))
+ (define (find-default data)
+ (if (equal? (syntax->datum (car data))
+ '#:default)
+ (list (cons 'default (cadr data))
+ (cons 'vals (defaults->alist (cddr data))))
+ (list (cons 'vals (defaults->alist data)))))
+ (let* ([data (syntax->list val)]
+ [len (if (list? data) (length data) -1)])
+ (cond [(identifier? val) (list (cons 'name val))]
+ [(< len 2) #f]
+ [(identifier? (car data))
+ (let ([defaults (find-default (cdr data))])
+ (cons (cons 'name (car data)) defaults))]
+ [else #f])))
+
+ ;; Check that the given value is a valid #:keyword-constructor
+ ;; value.
+ (define-for-syntax (keyword-constructor-val? val)
+ (if (syntax? val)
+ (parse-keyword-constructor-val val)
+ #f))
+
+ (define-syntax (define-keyword-constructor stx)
+ (syntax-case stx ()
+ [(_ id old-id keyword-config (arg ...))
+ (let-values ([(kparams knames)
+ (ids->keyword-args #'(arg ...)
+ (parse-keyword-constructor-val
+ #'keyword-config))])
+ (with-syntax ([(kparam ...) kparams]
+ [(kname ...) knames])
+ #`(new-define (id kparam ...)
+ (old-id kname ...))))]))
+
+ (define-for-syntax (filter f list)
+ (let loop ([l list] [result null])
+ (if (null? l)
+ (alt-reverse result)
+ (loop (cdr l) (if (f (car l))
+ (cons (car l) result)
+ result)))))
+
(define-syntax (define-struct/derived full-stx)
(define make-field list)
(define field-id car)
@@ -229,6 +316,7 @@
(#:mutable . #f)
(#:guard . #f)
(#:constructor-name . #f)
+ (#:keyword-constructor . #f)
(#:reflection-name . #f)
(#:only-constructor? . #f)
(#:omit-define-values . #f)
@@ -353,6 +441,17 @@
'#:only-constructor?
(eq? '#:constructor-name (syntax-e (car p))))
nongen?)]
+ [(eq? '#:keyword-constructor (syntax-e (car p)))
+ (check-exprs 1 p "identifier")
+ (when (lookup config '#:keyword-constructor)
+ (bad "multiple" "#:keyword-constructor" "s" (car p)))
+ (unless (keyword-constructor-val? (cadr p))
+ (bad "need a keyword constructor val after"
+ (car p) (cadr p)))
+ (loop (cddr p)
+ (extend-config config
+ '#:keyword-constructor (cadr p))
+ nongen?)]
[(eq? '#:reflection-name (syntax-e (car p)))
(check-exprs 1 p "expression")
(when (lookup config '#:reflection-name)
@@ -455,7 +554,9 @@
(car field-stxes))]
[else
(loop (cdr fields) (cdr field-stxes) #f)]))])
- (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only?
+ (let*-values ([(inspector super-expr props auto-val guard ctor-name
+ keyword-ctor
+ ctor-only?
reflect-name-expr mutable?
omit-define-values? omit-define-syntaxes?)
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
@@ -465,6 +566,7 @@
(lookup config '#:auto-value)
(lookup config '#:guard)
(lookup config '#:constructor-name)
+ (lookup config '#:keyword-constructor)
(lookup config '#:only-constructor?)
(lookup config '#:reflection-name)
(lookup config '#:mutable)
@@ -472,6 +574,11 @@
(lookup config '#:omit-define-syntaxes)))]
[(self-ctor?)
(and ctor-name (bound-identifier=? id ctor-name))]
+ [(self-keyword?) (and (keyword-constructor-val? keyword-ctor)
+ (equal?
+ (syntax->datum
+ (cdr (assoc 'name (parse-keyword-constructor-val keyword-ctor))))
+ (syntax->datum id)))]
[(name-as-ctor?) (or self-ctor? (not ctor-only?))])
(when mutable?
(for-each (lambda (f f-stx)
@@ -482,7 +589,7 @@
stx
f-stx)))
fields field-stxes))
- (let ([struct: (build-name id "struct:" id)]
+ (let* ([struct: (build-name id "struct:" id)]
[make- (if ctor-name
(if self-ctor?
(if omit-define-syntaxes?
@@ -490,6 +597,19 @@
(car (generate-temporaries (list id))))
ctor-name)
(build-name id "make-" id))]
+ [keyword-ctor-sym (and (keyword-constructor-val? keyword-ctor)
+ (syntax->datum
+ (cdr (assoc 'name (parse-keyword-constructor-val keyword-ctor)))))]
+ [keyword-ctor-name (let* ([name (and (keyword-constructor-val? keyword-ctor)
+ (cdr (assoc 'name (parse-keyword-constructor-val keyword-ctor))))])
+ (if (and name
+ (not (equal? (syntax->datum ctor-name)
+ keyword-ctor-sym)))
+ (list (if (equal? (syntax->datum id)
+ (syntax->datum name))
+ (car (generate-temporaries (list keyword-ctor-sym)))
+ name))
+ null))]
[? (build-name id id "?")]
[sels (map (lambda (f)
(build-name id ; (field-id f)
@@ -525,9 +645,11 @@
(let ([run-time-defns
(lambda ()
(quasisyntax/loc stx
- (define-values (#,struct: #,make- #,? #,@sels #,@sets)
+ (begin
+ (define-values (#,struct: #,make- #,? #,@sels #,@sets #,@keyword-ctor-name)
(let-values ([(struct: make- ? -ref -set!)
- (syntax-parameterize ([struct-field-index
+ (syntax-parameterize
+ ([struct-field-index
(lambda (stx)
(syntax-case stx #,(map field-id fields)
#,@(let loop ([fields fields][pos 0])
@@ -559,7 +681,26 @@
[else (loop (add1 i) (cdr fields))]))
#,guard
'#,(if ctor-only? ctor-name id)))])
- (values struct: make- ?
+ ;; Determine which constructors to define
+ #,(if (keyword-constructor-val? keyword-ctor)
+ (let ([key-name (cdr (assoc 'name (parse-keyword-constructor-val keyword-ctor)))])
+ (cond [(equal? (syntax->datum ctor-name)
+ (syntax->datum key-name))
+ #`(define-keyword-constructor make-thing make-
+ #,keyword-ctor
+ #,(map field-id (filter (λ (f)
+ (not (field-auto? f)))
+ fields)))]
+ [(keyword-constructor-val? keyword-ctor)
+ #`(begin
+ (define make-thing make-)
+ (define-keyword-constructor #,@keyword-ctor-name make-
+ #,keyword-ctor
+ #,(map field-id (filter (λ (f)
+ (not (field-auto? f)))
+ fields))))]))
+ #`(define make-thing make-))
+ (values struct: make-thing ?
#,@(let loop ([i 0][fields fields])
(if (null? fields)
null
@@ -571,7 +712,8 @@
(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)))))))))))]
+ (loop (add1 i) (cdr fields))))))
+ #,@keyword-ctor-name))))))]
[compile-time-defns
(lambda ()
(let* ([protect (lambda (sel)
@@ -586,10 +728,10 @@
(pair? (cadr super-autos))))
(positive? auto-count))]
[mk-info (if super-info-checked?
- (if name-as-ctor?
+ (if (or name-as-ctor? self-keyword?)
#'make-self-ctor-checked-struct-info
#'make-checked-struct-info)
- (if name-as-ctor?
+ (if (or name-as-ctor? self-keyword?)
#'make-self-ctor-struct-info
(if include-autos?
#'make-struct-auto-info
@@ -600,7 +742,8 @@
(lambda ()
(list
(quote-syntax #,(prune struct:))
- (quote-syntax #,(prune (if (and ctor-name self-ctor?)
+ (quote-syntax #,(prune (if (or (and ctor-name self-ctor?)
+ self-keyword?)
id
make-)))
(quote-syntax #,(prune ?))
@@ -643,9 +786,11 @@
(map protect (cadr super-autos))
null))))
null)
- #,@(if name-as-ctor?
- (list #`(lambda () (quote-syntax #,make-)))
- null))))))])
+ #,@(cond [name-as-ctor?
+ (list #`(lambda () (quote-syntax #,make-)))]
+ [self-keyword?
+ (list #`(lambda () (quote-syntax #,@keyword-ctor-name)))]
+ [else null]))))))])
(let ([result
(cond
[(and (not omit-define-values?) (not omit-define-syntaxes?))

No commit comments for this range

Something went wrong with that request. Please try again.