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

Better class implementation?

Browse Source
This commit is contained in:
Jay McCarthy 2016-01-14 17:11:12 -05:00
parent 33bb5bf17e
commit 1733a5ec7e
1 changed files with 91 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
remix/class0.rkt
View File

@ -4,6 +4,7 @@
racket/syntax racket/syntax
racket/generic racket/generic
racket/set racket/set
racket/match
syntax/id-set syntax/id-set
remix/stx/singleton-struct0 remix/stx/singleton-struct0
(prefix-in remix: remix/stx0)) (prefix-in remix: remix/stx0))
@ -61,11 +62,13 @@
(begin-for-syntax (begin-for-syntax
(define-generics class) (define-generics class)
(struct class-expansion-data (struct class-expansion-data
(cls-id [rep-id #:mutable] new-id [new-found? #:mutable] interface-set)) (cls-id [rep-id #:mutable] [new-found? #:mutable] interface-set))
(define (empty-class-expansion-data cls new-id) (define (empty-class-expansion-data cls)
(class-expansion-data cls #f new-id #f (mutable-bound-id-set))) (class-expansion-data cls #f #f (mutable-bound-id-set))))
(define current-class-expansion-data
(make-parameter #f))) (define-syntax default-ced #f)
(define-rename-transformer-parameter current-ced
(make-rename-transformer #'default-ced))
(define-syntax class (define-syntax class
(singleton-struct (singleton-struct
@ -78,96 +81,97 @@
#:literals (remix:#%brackets remix:def class) #:literals (remix:#%brackets remix:def class)
[(remix:def (remix:#%brackets class cls:id) [(remix:def (remix:#%brackets class cls:id)
body-expr ...) body-expr ...)
(define ctxt (syntax-local-context)) (syntax/loc stx
(define cls-stop-list (list #'remix:def #'remix:#%brackets)) (begin
(with-syntax ([cls-new (format-id #f "~a-new" #'cls)] (define-syntax the-ced (empty-class-expansion-data #'cls))
[cls-Current (format-id #f "~a-Current" #'cls)] (splicing-syntax-parameterize
[cls-alloc (format-id #f "~a-alloc" #'cls)]) ([current-ced
(define the-ced (empty-class-expansion-data #'cls #'cls-new)) (make-rename-transformer #'the-ced)])
(with-syntax ([(new-body ...) body-expr ...)
(parameterize ([current-class-expansion-data the-ced]) (class-after-body the-ced)))]))]))
(for/list ([be (in-list (syntax->list #'(body-expr ...)))])
(local-expand/capture-lifts
be
ctxt cls-stop-list)))])
(printf "after body local-expand\n")
(with-syntax ([((int cls-int-impl) ...)
;; XXX
'()])
(syntax/loc stx
(begin
(remix:def (remix:#%brackets static-interface cls)
(remix:#%brackets #:new cls-new)
(remix:#%brackets int cls-int-impl)
...
#:extensions
#:methods gen:class
[])
(remix:def (remix:#%brackets static-interface cls-Current)
(remix:#%brackets #:alloc cls-alloc))
;; XXX bind this
(splicing-syntax-parameterize
([Current (rename-dot-transformer #'cls-Current)])
new-body ...))))))]))]))
(begin-for-syntax (define-syntax (class-after-body stx)
(struct rename-dot-transformer (id) (syntax-parse stx
#:methods remix:gen:dot-transformer [(_ the-ced)
[(define/generic super-dt dot-transform) #:declare the-ced (static class-expansion-data? "class expansion data")
(define (dot-transform rdt stx) (match-define (class-expansion-data cls-id rep-id new-found? interface-set)
(super-dt (syntax-local-value (rename-dot-transformer-id rdt)) stx))])) (attribute the-ced.value))
(unless new-found?
(raise-syntax-error 'class
(format "no constructor found for class ~a" cls-id)
stx))
(with-syntax*
([cls cls-id]
[rep rep-id]
[cls-new (format-id #f "~a-new" #'cls)]
[cls-Current (format-id #f "~a-Current" #'cls)]
[cls-alloc (format-id #f "~a-alloc" #'cls)]
[((int cls-int-impl) ...)
;; XXX
'()])
(syntax/loc stx
(begin
(remix:def (remix:#%brackets static-interface cls-Current)
(remix:#%brackets #:alloc cls-alloc))
(splicing-syntax-parameterize
([Current (make-rename-transformer #'cls-Current)])
(remix:def (remix:#%brackets static-interface cls)
(remix:#%brackets #:new cls-new)
(remix:#%brackets int cls-int-impl)
...
#:extensions
#:methods gen:class
[])))))]))
(define-syntax (representation stx) (define-syntax (representation stx)
(cond (define ced
[(current-class-expansion-data) (or (syntax-local-value #'current-ced (λ () #f))
=> (λ (ced) (raise-syntax-error 'representation "Illegal outside class" stx)))
(syntax-parse stx (syntax-parse stx
[(_ l:id) [(_ l:id)
;; XXX ensure l is layout ;; XXX ensure l is layout
(cond (cond
[(class-expansion-data-rep-id ced) [(class-expansion-data-rep-id ced)
(raise-syntax-error (raise-syntax-error
'representation 'representation
(format "Duplicate definition of representation for class ~a" (format "Duplicate definition of representation for class ~a"
(syntax-e (class-expansion-data-cls-id ced))) (syntax-e (class-expansion-data-cls-id ced)))
stx)] stx)]
[else [else
(set-class-expansion-data-rep-id! ced #'l)]) (set-class-expansion-data-rep-id! ced #'l)
#'(void)]))] #'(void)])]))
[else
(raise-syntax-error 'representation "Illegal outside class" stx)]))
(define-syntax (new stx) (define-syntax (new stx)
(cond (define ced
[(current-class-expansion-data) (or (syntax-local-value #'current-ced (λ () #f))
=> (λ (ced) (raise-syntax-error 'new "Illegal outside class" stx)))
(syntax-parse stx (syntax-parse stx
[(_ args . body) [(_ args . body)
(when (class-expansion-data-new-found? ced) (when (class-expansion-data-new-found? ced)
(raise-syntax-error (raise-syntax-error
'new 'new
(format "Duplicate definition of constructor for class ~a" (format "Duplicate definition of constructor for class ~a"
(syntax-e (class-expansion-data-cls-id ced))) (syntax-e (class-expansion-data-cls-id ced)))
stx)) stx))
(set-class-expansion-data-new-found?! ced #t) (set-class-expansion-data-new-found?!
(with-syntax ([cls-new (class-expansion-data-new-id ced)]) ced
(syntax/loc stx (λ (new-id)
(remix:def (cls-new . args) . body)))]))] (with-syntax ([cls-new new-id])
[else (syntax/loc stx
(raise-syntax-error 'new "Illegal outside class" stx)])) (remix:def (cls-new . args) . body)))))
#'(void)]))
(define-syntax (implementation stx) (define-syntax (implementation stx)
(cond (define ced
[(current-class-expansion-data) (or (syntax-local-value #'current-ced (λ () #f))
=> (λ (ced) (raise-syntax-error 'implementation "Illegal outside class" stx)))
;; XXX ;; XXX
#'(void))] #'(void))
[else
(raise-syntax-error 'implementation "Illegal outside class" stx)])) (remix:def (remix:#%brackets static-interface default-Current))
(define-rename-transformer-parameter Current
(make-rename-transformer #'default-Current))
(define-syntax-parameter Current
(λ (stx)
(raise-syntax-error 'Current "Illegal outside class definitions" stx)))
(define-syntax-parameter this (define-syntax-parameter this
(λ (stx) (λ (stx)
(raise-syntax-error 'this "Illegal outside class definitions" stx))) (raise-syntax-error 'this "Illegal outside class definitions" stx)))