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

Reduce duplication in construction of syntax-infos.

Browse Source
This commit is contained in:
Eric Dobson 2013-05-25 11:16:03 -07:00
parent 1bcdeaea24
commit c851fad6bc
1 changed files with 35 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/typed-racket/base-env/prims.rkt
View File

@ -636,8 +636,6 @@ This file defines two sorts of primitives. All of them are provided into any mod
(pattern (~seq #:constructor-name name:id) #:attr extra #f) (pattern (~seq #:constructor-name name:id) #:attr extra #f)
(pattern (~seq #:extra-constructor-name name:id) #:attr extra #t)) (pattern (~seq #:extra-constructor-name name:id) #:attr extra #t))
(define (maybe-add-quote-syntax stx)
(if (and stx (syntax-e stx)) #`(quote-syntax #,stx) stx))
(define ((rts legacy) stx) (define ((rts legacy) stx)
(syntax-parse stx #:literals (:) (syntax-parse stx #:literals (:)
@ -662,44 +660,50 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse id #:context stx (syntax-parse id #:context stx
[(~var id (static struct-info? "identifier bound to a structure type")) [(~var id (static struct-info? "identifier bound to a structure type"))
(extract-struct-info (syntax-local-value #'parent))])) (extract-struct-info (syntax-local-value #'parent))]))
(define (maybe-add-quote-syntax stx)
(if (and stx (syntax-e stx)) #`(quote-syntax #,stx) stx))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(require (only-in lib type-des (nm orig-struct-info))) (require (only-in lib type-des (nm orig-struct-info)))
(define-for-syntax si (define-for-syntax si
(let () (let ()
(define-values (orig-type-des orig-maker orig-pred orig-sels orig-muts orig-parent) (define-values (orig-type-des orig-maker orig-pred orig-sels orig-muts orig-parent)
(apply values (extract-struct-info (syntax-local-value (quote-syntax orig-struct-info))))) (apply values (extract-struct-info (syntax-local-value (quote-syntax orig-struct-info)))))
(define (id-drop sels muts num) (define (id-drop sels muts num)
(cond
((zero? num) (values sels muts))
((null? sels) (int-err "id-drop: Too short of list"))
((pair? sels)
(cond (cond
((not (car sels)) (values sels muts)) [(zero? num) (values sels muts)]
(else (id-drop (cdr sels) (cdr muts) (sub1 num))))) [(null? sels) (int-err "id-drop: Too short of list")]
(else (int-err "id-drop: Not a list")))) [(pair? sels)
(cond
[(not (car sels)) (values sels muts)]
[else (id-drop (cdr sels) (cdr muts) (sub1 num))])]
[else (int-err "id-drop: Not a list")]))
(make-struct-info (define (struct-info-list new-sels new-muts)
(lambda () (list (quote-syntax type-des)
#,(if (syntax-e #'parent) (quote-syntax real-maker)
(let-values (((parent-type-des parent-maker parent-pred (quote-syntax pred)
parent-sel parent-mut grand-parent) (append (list #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(sel ...)))))
(apply values (extract-struct-info* #'parent)))) new-sels)
#`(list (quote-syntax type-des) (append (list #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(mut ...)))))
(quote-syntax real-maker) new-muts)
(quote-syntax pred) orig-parent))
(list #,@(map maybe-add-quote-syntax (append (reverse (syntax->list #'(sel ...))) parent-sel)))
(list #,@(map maybe-add-quote-syntax (append (reverse (syntax->list #'(mut ...))) parent-mut))) (make-struct-info
(quote-syntax parent))) (lambda ()
#`(let-values (((new-sels new-muts) (id-drop orig-sels orig-muts num-fields))) #,(if (syntax-e #'parent)
(list (quote-syntax type-des) (let-values (((parent-type-des parent-maker parent-pred
(quote-syntax real-maker) parent-sel parent-mut grand-parent)
(quote-syntax pred) (apply values (extract-struct-info* #'parent))))
(list* #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(sel ...)))) new-sels) #`(struct-info-list
(list* #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(mut ...)))) new-muts) (list #,@(map maybe-add-quote-syntax parent-sel))
orig-parent))))))) (list #,@(map maybe-add-quote-syntax parent-mut))))
#`(let-values (((new-sels new-muts) (id-drop orig-sels orig-muts num-fields)))
(struct-info-list new-sels new-muts)))))))
(define-syntax nm (define-syntax nm
(if id-is-ctor? (if id-is-ctor?