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

44
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,6 +660,10 @@ 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)))
@ -673,13 +675,23 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define (id-drop sels muts num) (define (id-drop sels muts num)
(cond (cond
((zero? num) (values sels muts)) [(zero? num) (values sels muts)]
((null? sels) (int-err "id-drop: Too short of list")) [(null? sels) (int-err "id-drop: Too short of list")]
((pair? sels) [(pair? sels)
(cond (cond
((not (car sels)) (values sels muts)) [(not (car sels)) (values sels muts)]
(else (id-drop (cdr sels) (cdr muts) (sub1 num))))) [else (id-drop (cdr sels) (cdr muts) (sub1 num))])]
(else (int-err "id-drop: Not a list")))) [else (int-err "id-drop: Not a list")]))
(define (struct-info-list new-sels new-muts)
(list (quote-syntax type-des)
(quote-syntax real-maker)
(quote-syntax pred)
(append (list #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(sel ...)))))
new-sels)
(append (list #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(mut ...)))))
new-muts)
orig-parent))
(make-struct-info (make-struct-info
(lambda () (lambda ()
@ -687,19 +699,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
(let-values (((parent-type-des parent-maker parent-pred (let-values (((parent-type-des parent-maker parent-pred
parent-sel parent-mut grand-parent) parent-sel parent-mut grand-parent)
(apply values (extract-struct-info* #'parent)))) (apply values (extract-struct-info* #'parent))))
#`(list (quote-syntax type-des) #`(struct-info-list
(quote-syntax real-maker) (list #,@(map maybe-add-quote-syntax parent-sel))
(quote-syntax pred) (list #,@(map maybe-add-quote-syntax parent-mut))))
(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)))
(quote-syntax parent)))
#`(let-values (((new-sels new-muts) (id-drop orig-sels orig-muts num-fields))) #`(let-values (((new-sels new-muts) (id-drop orig-sels orig-muts num-fields)))
(list (quote-syntax type-des) (struct-info-list new-sels new-muts)))))))
(quote-syntax real-maker)
(quote-syntax pred)
(list* #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(sel ...)))) new-sels)
(list* #,@(map maybe-add-quote-syntax (reverse (syntax->list #'(mut ...)))) new-muts)
orig-parent)))))))
(define-syntax nm (define-syntax nm
(if id-is-ctor? (if id-is-ctor?