a lot of progress on classes
This commit is contained in:
Jay McCarthy
parent
decdb6d3ff
commit
33bb5bf17e
162
remix/class0.rkt
162
remix/class0.rkt
|
|
@ -1,14 +1,24 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
racket/generic
|
||||
racket/set
|
||||
syntax/id-set
|
||||
remix/stx/singleton-struct0
|
||||
(prefix-in remix: remix/stx0))
|
||||
racket/stxparam
|
||||
racket/splicing
|
||||
remix/theory0
|
||||
remix/static-interface0
|
||||
(prefix-in remix: remix/stx0))
|
||||
|
||||
(struct object (interface->implementation rep))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-generics interface
|
||||
(interface-vtable interface)))
|
||||
|
||||
(define-syntax interface
|
||||
(singleton-struct
|
||||
#:property prop:procedure
|
||||
|
|
@ -23,26 +33,39 @@
|
|||
;; XXX support properties?
|
||||
;; XXX make expandable position
|
||||
v:id ...)
|
||||
(syntax/loc stx
|
||||
;; XXX instead, make an int-vtable and then a separate int
|
||||
;; def transformer that looks at objects.
|
||||
(remix:def (remix:#%brackets theory int)
|
||||
;; XXX add a property for interfaces
|
||||
;; XXX support defaults?
|
||||
v ...))]))]))
|
||||
(with-syntax ([int-vtable
|
||||
(format-id #f "~a-vtable" #'int)]
|
||||
[(obj-v ...)
|
||||
(for/list ([v (in-list (syntax->list #'(v ...)))])
|
||||
(format-id #f "~a-~a" #'int v))])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(remix:def int-vtable-id (gensym 'int-vtable))
|
||||
(remix:def (remix:#%brackets theory int-vtable)
|
||||
;; XXX add a property for vtables
|
||||
;; XXX support defaults?
|
||||
v ...)
|
||||
(remix:def (obj-v o)
|
||||
(remix:def (remix:#%brackets int-vtable vt)
|
||||
(hash-ref (object-interface->implementation o)
|
||||
int-vtable-id))
|
||||
(remix:#%dot vt v))
|
||||
...
|
||||
(remix:def (remix:#%brackets static-interface int)
|
||||
(remix:#%brackets v obj-v)
|
||||
...
|
||||
#:extensions
|
||||
#:methods gen:interface
|
||||
[(define (interface-vtable _) #'int-vtable)]))))]))]))
|
||||
|
||||
(define-syntax-parameter representation
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'representation "Illegal outside class" stx)))
|
||||
(define-syntax-parameter new
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'new "Illegal outside class" stx)))
|
||||
(define-syntax-parameter this
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'this "Illegal outside class" stx)))
|
||||
(define-syntax-parameter implementation
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'implementation "Illegal outside class" stx)))
|
||||
(begin-for-syntax
|
||||
(define-generics class)
|
||||
(struct class-expansion-data
|
||||
(cls-id [rep-id #:mutable] new-id [new-found? #:mutable] interface-set))
|
||||
(define (empty-class-expansion-data cls new-id)
|
||||
(class-expansion-data cls #f new-id #f (mutable-bound-id-set)))
|
||||
(define current-class-expansion-data
|
||||
(make-parameter #f)))
|
||||
|
||||
(define-syntax class
|
||||
(singleton-struct
|
||||
|
|
@ -51,14 +74,109 @@
|
|||
(raise-syntax-error 'class "Illegal outside def" stx))
|
||||
#:methods remix:gen:def-transformer
|
||||
[(define (def-transform _ stx)
|
||||
;; XXX ensure everything is expandable
|
||||
;; XXX
|
||||
#'(void))]))
|
||||
(syntax-parse stx
|
||||
#:literals (remix:#%brackets remix:def class)
|
||||
[(remix:def (remix:#%brackets class cls:id)
|
||||
body-expr ...)
|
||||
(define ctxt (syntax-local-context))
|
||||
(define cls-stop-list (list #'remix:def #'remix:#%brackets))
|
||||
(with-syntax ([cls-new (format-id #f "~a-new" #'cls)]
|
||||
[cls-Current (format-id #f "~a-Current" #'cls)]
|
||||
[cls-alloc (format-id #f "~a-alloc" #'cls)])
|
||||
(define the-ced (empty-class-expansion-data #'cls #'cls-new))
|
||||
(with-syntax ([(new-body ...)
|
||||
(parameterize ([current-class-expansion-data 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
|
||||
(struct rename-dot-transformer (id)
|
||||
#:methods remix:gen:dot-transformer
|
||||
[(define/generic super-dt dot-transform)
|
||||
(define (dot-transform rdt stx)
|
||||
(super-dt (syntax-local-value (rename-dot-transformer-id rdt)) stx))]))
|
||||
|
||||
(define-syntax (representation stx)
|
||||
(cond
|
||||
[(current-class-expansion-data)
|
||||
=> (λ (ced)
|
||||
(syntax-parse stx
|
||||
[(_ l:id)
|
||||
;; XXX ensure l is layout
|
||||
(cond
|
||||
[(class-expansion-data-rep-id ced)
|
||||
(raise-syntax-error
|
||||
'representation
|
||||
(format "Duplicate definition of representation for class ~a"
|
||||
(syntax-e (class-expansion-data-cls-id ced)))
|
||||
stx)]
|
||||
[else
|
||||
(set-class-expansion-data-rep-id! ced #'l)])
|
||||
#'(void)]))]
|
||||
[else
|
||||
(raise-syntax-error 'representation "Illegal outside class" stx)]))
|
||||
|
||||
(define-syntax (new stx)
|
||||
(cond
|
||||
[(current-class-expansion-data)
|
||||
=> (λ (ced)
|
||||
(syntax-parse stx
|
||||
[(_ args . body)
|
||||
(when (class-expansion-data-new-found? ced)
|
||||
(raise-syntax-error
|
||||
'new
|
||||
(format "Duplicate definition of constructor for class ~a"
|
||||
(syntax-e (class-expansion-data-cls-id ced)))
|
||||
stx))
|
||||
(set-class-expansion-data-new-found?! ced #t)
|
||||
(with-syntax ([cls-new (class-expansion-data-new-id ced)])
|
||||
(syntax/loc stx
|
||||
(remix:def (cls-new . args) . body)))]))]
|
||||
[else
|
||||
(raise-syntax-error 'new "Illegal outside class" stx)]))
|
||||
|
||||
(define-syntax (implementation stx)
|
||||
(cond
|
||||
[(current-class-expansion-data)
|
||||
=> (λ (ced)
|
||||
;; XXX
|
||||
#'(void))]
|
||||
[else
|
||||
(raise-syntax-error 'implementation "Illegal outside class" stx)]))
|
||||
|
||||
(define-syntax-parameter Current
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'Current "Illegal outside class definitions" stx)))
|
||||
(define-syntax-parameter this
|
||||
(λ (stx)
|
||||
(raise-syntax-error 'this "Illegal outside class definitions" stx)))
|
||||
|
||||
(provide interface
|
||||
representation
|
||||
(rename-out [representation rep])
|
||||
new
|
||||
Current
|
||||
this
|
||||
implementation
|
||||
(rename-out [implementation impl])
|
||||
|
|
|
|||
44
remix/exp/expand.rkt
Normal file
44
remix/exp/expand.rkt
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/splicing)
|
||||
|
||||
(begin-for-syntax
|
||||
(define special-define-set
|
||||
(make-parameter (box '())))
|
||||
(define (add-to-boxed-list! b v)
|
||||
(set-box! b (cons v (unbox b)))))
|
||||
|
||||
(define-syntax (detect-special-defines stx)
|
||||
(syntax-parse stx
|
||||
[(_ body-expr ...)
|
||||
(define the-b (box '()))
|
||||
(define ctxt (syntax-local-context))
|
||||
(printf "ctxt: ~v\n" ctxt)
|
||||
(with-syntax ([(new-body-begin ...)
|
||||
(parameterize ([special-define-set the-b])
|
||||
(for/list ([be (in-list (syntax->list #'(body-expr ...)))])
|
||||
(local-expand/capture-lifts
|
||||
be
|
||||
ctxt
|
||||
(list #'define-values))))])
|
||||
(with-syntax ([(d ...) (unbox the-b)])
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
new-body-begin ...
|
||||
(printf "Defined: ~a\n"
|
||||
'(d ...))))))]))
|
||||
|
||||
(define-syntax (special-define stx)
|
||||
(syntax-parse stx
|
||||
[(_ x:id b:expr)
|
||||
(printf "special-define ran!\n")
|
||||
(add-to-boxed-list! (special-define-set) #'x)
|
||||
(syntax/loc stx
|
||||
(define x b))]))
|
||||
|
||||
(detect-special-defines
|
||||
(special-define x 1)
|
||||
(special-define y 2))
|
||||
|
||||
(+ x y)
|
||||
|
|
@ -183,6 +183,20 @@
|
|||
(syntax/loc stx
|
||||
(remix-block sf ... (the-#%braces s.tail-form ...)))])]))
|
||||
|
||||
(require (for-syntax (prefix-in dangerous:stxparamkey: racket/private/stxparamkey)))
|
||||
(begin-for-syntax
|
||||
(define (syntax-parameter? id)
|
||||
;; Copied from syntax-parameter-value
|
||||
(let* ([v (syntax-local-value id (λ () #f))]
|
||||
[v (if (set!-transformer? v)
|
||||
(set!-transformer-procedure v)
|
||||
v)])
|
||||
(dangerous:stxparamkey:syntax-parameter? v)))
|
||||
(define (syntax-local-value/maybe-syntax-parameter id)
|
||||
(if (syntax-parameter? id)
|
||||
(syntax-parameter-value id)
|
||||
(syntax-local-value id (λ () #f)))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-generics dot-transformer
|
||||
(dot-transform dot-transformer stx)))
|
||||
|
|
|
|||
|
|
@ -16,17 +16,18 @@
|
|||
;; A class is a representation, a constructor, and implementations of
|
||||
;; interfaces.
|
||||
(def [class Circle]
|
||||
(def [rep] circle) ;; rep = representation
|
||||
(def ([new] x y r)
|
||||
(this.#:alloc [c (posn.#:alloc [x x] [y y])]
|
||||
[r r]))
|
||||
(rep circle) ;; rep = representation
|
||||
(new (x y r)
|
||||
(Current.#:alloc
|
||||
[c (posn.#:alloc [x x] [y y])]
|
||||
[r r]))
|
||||
|
||||
;; xxx make a macro from "layout's fields implements this interface"
|
||||
(def [implementation Circle<%>]
|
||||
(implementation Circle<%>
|
||||
[(c) this.c]
|
||||
[(r) this.r])
|
||||
|
||||
(def [impl 2d<%>]
|
||||
(impl 2d<%>
|
||||
[(translate x y)
|
||||
{this.#:set
|
||||
[c (this.c.#:set [x {x + this.c.x}]
|
||||
|
|
@ -35,7 +36,11 @@
|
|||
{3 * this.r * this.r}]))
|
||||
|
||||
;; XXX allow w/o #:new?, like layout
|
||||
#;(def [Circle C1] (Circle.#:new 1 2 3))
|
||||
|
||||
;; XXX
|
||||
#;
|
||||
(def [Circle C1] (Circle.#:new 1 2 3))
|
||||
;; XXX
|
||||
#;
|
||||
(module+ test
|
||||
;; If you know something is a particular class, then you can access
|
||||
|
|
@ -57,6 +62,7 @@
|
|||
{C1-as-Circ.c.y ≡ 2}
|
||||
{C1-as-Circ.r ≡ 3})
|
||||
|
||||
;; XXX
|
||||
#;
|
||||
(module+ test
|
||||
;; Like theories, you can define functions that are generic over an
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user