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

Added useless statements so that Check Syntax will see all uses of interfaces,

Browse Source 
even those that get erased in the transition to MzScheme classes.

svn: r336
This commit is contained in:
Stevie Strickland 2005-07-04 22:31:33 +00:00
parent 57e8d8dab4
commit 03aba477f7
5 changed files with 90 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/honu/base.ss
View File

@ -9,6 +9,13 @@
(error "Attempt to access member of null") (error "Attempt to access member of null")
(send obj msg arg ...))])) (send obj msg arg ...))]))
;; We just use this so that Check Syntax correctly matches up
;; types that don't appear otherwise. Yes, this is a hack.
;; For obvious reasons, this can't just be a macro that ignores
;; its arguments, but must instead be a _function_ that ignores them.
(define (honu:type . types)
(void))
(define null% (define null%
(class object% (class object%
(inspect #f) (inspect #f)

42
collects/honu/private/compiler/translate-class-utils.ss
View File

@ -99,9 +99,10 @@
(define (translate-export in-super? export) (define (translate-export in-super? export)
(cons 'begin (cons 'begin
(map (lambda (b) (cons `(honu:type ,(translate-type-for-syntax (comp:export-type export)))
(translate-exp-bind in-super? (comp:export-type export) b)) (map (lambda (b)
(comp:export-binds export)))) (translate-exp-bind in-super? (comp:export-type export) b))
(comp:export-binds export)))))
(define (translate-exp-bind in-super? type binding) (define (translate-exp-bind in-super? type binding)
(let ([right-defn (if in-super? 'define/override 'define/public)]) (let ([right-defn (if in-super? 'define/override 'define/public)])
@ -125,27 +126,34 @@
(honu:super-new-args super-new))))) (honu:super-new-args super-new)))))
(define (translate-inits inits) (define (translate-inits inits)
(cons 'init (map (lambda (i) `(begin
(at-ctxt (honu:formal-name i))) (honu:type ,@(map (lambda (i) (translate-type-for-syntax (honu:formal-type i))) inits))
inits))) ,(cons 'init (map (lambda (i)
(at-ctxt (honu:formal-name i)))
inits))))
(define (mangle-init-name name) (define (mangle-init-name name)
(at name (string->symbol (string-append "init-" (symbol->string (syntax-e name)))))) (at name (string->symbol (string-append "init-" (symbol->string (syntax-e name))))))
(define (translate-member member) (define (translate-member member)
(match member (match member
[(struct honu:init-field (stx name _ value)) [(struct honu:init-field (stx name type value))
(if value (if value
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] (at stx`(begin (honu:type ,(translate-type-for-syntax type))
,(translate-expression value))) (init ([,(mangle-init-name name) ,(at-ctxt name)]
(define ,(at-ctxt name) ,(mangle-init-name))) ,(translate-expression value)))
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)])) (define ,(at-ctxt name) ,(mangle-init-name))))
(define ,(at-ctxt name) ,(mangle-init-name name))))] (at stx `(begin (honu:type ,(translate-type-for-syntax type))
[(struct honu:field (stx name _ value)) (init ([,(mangle-init-name name) ,(at-ctxt name)]))
`(define ,(at-ctxt name) ,(translate-expression value))] (define ,(at-ctxt name) ,(mangle-init-name name)))))]
[(struct honu:method (stx name _ formals body)) [(struct honu:field (stx name type value))
(translate-function stx name formals (at stx `(begin (honu:type ,(translate-type-for-syntax type))
(translate-expression body))])) (define ,(at-ctxt name) ,(translate-expression value))))]
[(struct honu:method (stx name type formals body))
(at stx `(begin (honu:type ,(translate-type-for-syntax type))
(honu:type ,@(map (lambda (f) (translate-type-for-syntax (honu:formal-type f))) formals))
,(translate-function stx name formals
(translate-expression body))))]))
) )

7
collects/honu/private/compiler/translate-expression.ss
View File

@ -21,7 +21,8 @@
;; list is a bindable name in Honu, so... we use list*, which isn't. ;; list is a bindable name in Honu, so... we use list*, which isn't.
(at stx `(list* ,@(map translate-expression args) ()))] (at stx `(list* ,@(map translate-expression args) ()))]
[(struct honu:lambda (stx _ formals body)) [(struct honu:lambda (stx _ formals body))
(translate-function stx #f formals (translate-expression body))] (at stx `(begin (honu:type ,@(map (lambda (f) (translate-type-for-syntax (honu:formal-type f))) formals))
,(translate-function stx #f formals (translate-expression body))))]
[(struct honu:call (stx func arg)) [(struct honu:call (stx func arg))
(match func (match func
[(struct honu:member (stx 'my _ name #t)) [(struct honu:member (stx 'my _ name #t))
@ -229,7 +230,9 @@
(translate-expression (honu:binding-value b)))]) (translate-expression (honu:binding-value b)))])
;; make sure to give the let binding the appropriate syntax, ;; make sure to give the let binding the appropriate syntax,
;; otherwise errors will highlight the entire let expression. ;; otherwise errors will highlight the entire let expression.
(at (honu:ast-stx b) `(,bound-names ,body)))) (at (honu:ast-stx b) `(,bound-names (begin (honu:type ,@(map translate-type-for-syntax
(honu:binding-types b)))
,body)))))
bindings) bindings)
,(translate-expression body)))] ,(translate-expression body)))]
[(struct honu:seq (stx effects value)) [(struct honu:seq (stx effects value))

24
collects/honu/private/compiler/translate-utils.ss
View File

@ -1,6 +1,7 @@
(module translate-utils mzscheme (module translate-utils mzscheme
(require (all-except (lib "list.ss" "srfi" "1") any) (require (all-except (lib "list.ss" "srfi" "1") any)
(lib "plt-match.ss")
(lib "contract.ss") (lib "contract.ss")
"../../ast.ss" "../../ast.ss"
"../../parameters.ss" "../../parameters.ss"
@ -67,7 +68,7 @@
translate-field-getter-name translate-field-setter-name) translate-field-getter-name translate-field-setter-name)
(define (translate-iface-name type) (define (translate-iface-name type)
(let ([name (if (honu:type-iface-top? type) (let ([name (if (honu:type-iface-top? type)
(datum->syntax-object #f 'Any #f) (datum->syntax-object #f 'Any (honu:ast-stx type))
(honu:type-iface-name type))]) (honu:type-iface-name type))])
(at name (string->symbol (string-append (symbol->string (syntax-e name)) "<%>"))))) (at name (string->symbol (string-append (symbol->string (syntax-e name)) "<%>")))))
@ -132,6 +133,25 @@
`(begin (set! ,(at-ctxt name) ,arg) `(begin (set! ,(at-ctxt name) ,arg)
,void-value))) ,void-value)))
`(begin (set! ,(at-ctxt name) ,arg) `(begin (set! ,(at-ctxt name) ,arg)
,void-value))) ,void-value)))
;; Yes, this is just part of the hack that gives us Check Syntax-correctness on all the types that
;; are not otherwise used in the compiled code.
(provide translate-type-for-syntax)
(define (translate-type-for-syntax type)
(define (real-translation type)
(match type
[(struct honu:type-iface (stx name))
(list (translate-iface-name type))]
[(struct honu:type-iface-top (stx))
(list (translate-iface-name type))]
[(struct honu:type-prim (stx name))
'()]
[(struct honu:type-func (stx arg ret))
(append (real-translation arg)
(real-translation ret))]
[(struct honu:type-tuple (stx args))
(apply append (map real-translation args))]))
`(list* ,@(real-translation type) '()))
) )

44
collects/honu/private/compiler/translate.ss
View File

@ -35,7 +35,7 @@
[else [else
(loop (cdr defns-to-go) (cons (translate-defn (car defns-to-go)) syntaxes))]))) (loop (cdr defns-to-go) (cons (translate-defn (car defns-to-go)) syntaxes))])))
(define (translate-member-names name) (define (translate-iface-member-names name)
(let* ([iface (make-iface-type name name)] (let* ([iface (make-iface-type name name)]
[type-entry (get-type-entry iface)]) [type-entry (get-type-entry iface)])
(let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] (let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
@ -50,23 +50,39 @@
(cons (translate-field-setter-name iface (tenv:member-name (car members))) (cons (translate-field-setter-name iface (tenv:member-name (car members)))
(cons (translate-field-getter-name iface (tenv:member-name (car members))) (cons (translate-field-getter-name iface (tenv:member-name (car members)))
names)))))))) names))))))))
(define (translate-iface-member-types members)
(define (get-member-type-list m)
(match m
[(struct honu:field-decl (_ _ type))
(list (translate-type-for-syntax type))]
[(struct honu:method-decl (_ _ type arg-types))
(cons (translate-type-for-syntax type)
(map translate-type-for-syntax arg-types))]))
(apply append (map get-member-type-list members)))
(define (translate-defn defn) (define (translate-defn defn)
(match defn (match defn
[(struct honu:bind-top (stx names _ value)) [(struct honu:bind-top (stx names types value))
(let-values ([(bound-names body) (translate-binding-clause names (translate-expression value))]) (let-values ([(bound-names body) (translate-binding-clause names (translate-expression value))])
(at stx `(define-values ,bound-names ,body)))] (at stx `(begin (honu:type ,@(map translate-type-for-syntax types))
[(struct honu:function (stx name _ args body)) (define-values ,bound-names ,body))))]
(translate-function stx name args (translate-expression body))] [(struct honu:function (stx name type args body))
(at stx `(begin (honu:type ,(translate-type-for-syntax type))
(honu:type ,@(map (lambda (a) (translate-type-for-syntax (honu:formal-type a))) args))
,(translate-function stx name args (translate-expression body))))]
[(struct honu:iface (stx name supers members)) [(struct honu:iface (stx name supers members))
(at stx `(define ,(translate-iface-name (make-iface-type name name)) (at stx `(begin
(interface ,(if (null? supers) (define ,(translate-iface-name (make-iface-type name name))
(list (translate-iface-name (make-any-type #f))) (interface ,(if (null? supers)
(map translate-iface-name supers)) (list (translate-iface-name (make-any-type #f)))
,@(translate-member-names name))))] (map translate-iface-name supers))
[(struct honu:class (stx name _ _ impls inits members exports)) ,@(translate-iface-member-names name)))
(honu:type ,@(translate-iface-member-types members))))]
[(struct honu:class (stx name selftype _ impls inits members exports))
(at stx `(define ,(translate-class-name name) (at stx `(define ,(translate-class-name name)
(class* object% ,(map translate-iface-name impls) (class* object% ,(map translate-iface-name impls)
(honu:type ,(translate-type-for-syntax selftype))
(inspect #f) (inspect #f)
,(translate-inits inits) ,(translate-inits inits)
,@(map translate-member members) ,@(map translate-member members)
@ -80,7 +96,7 @@
(define (translate-subclass mixin-defn defn) (define (translate-subclass mixin-defn defn)
(match (list mixin-defn defn) (match (list mixin-defn defn)
[(list (struct honu:mixin (mstx mname _ arg-type _ impls inits _ super-new members-before members-after exports)) [(list (struct honu:mixin (mstx mname selftype arg-type _ impls inits withs super-new members-before members-after exports))
(struct honu:subclass (stx name base mixin))) (struct honu:subclass (stx name base mixin)))
(parameterize ([current-mixin-argument-type arg-type]) (parameterize ([current-mixin-argument-type arg-type])
(let* ([base-entry (get-class-entry base)] (let* ([base-entry (get-class-entry base)]
@ -88,6 +104,8 @@
(tenv:class-impls base-entry))]) (tenv:class-impls base-entry))])
(at stx `(define ,(translate-class-name name) (at stx `(define ,(translate-class-name name)
(class* ,(translate-class-name base) ,(map translate-iface-name impls) (class* ,(translate-class-name base) ,(map translate-iface-name impls)
(honu:type ,(translate-type-for-syntax selftype))
(honu:type ,@(map (lambda (w) (translate-type-for-syntax (honu:formal-type w)))))
(inspect #f) (inspect #f)
,(translate-inits inits) ,(translate-inits inits)
,@(map translate-member members-before) ,@(map translate-member members-before)