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

Honu:

Browse Source 
- Updated todo list
- Promoted "name" field of member ASTs to member (rather than field/method/etc.)
- Added false? function
- Added extend-fenv for formal parameters
- Removed class env (folded in with lexical env)
- Added abstraction for member names of a type
- Added abstractions for enforcing distinct types and names
- Updated mixin typing rule

svn: r1854
This commit is contained in:
Carl Eastlund 2006-01-17 23:07:15 +00:00
parent 6a2fb814ea
commit 8efd89de41
12 changed files with 124 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/honu/ast.ss
View File

@ -56,15 +56,15 @@
(define-honu-struct (bind-top defn) (names types value)) ; used for top-level definitions
;; AST nodes for member declarations (in interfaces)
(define-honu-struct (member-decl ast) ()) ; member-decl?
(define-honu-struct (field-decl member-decl) (name type)) ; used for field declarations
(define-honu-struct (method-decl member-decl) (name type arg-types)) ; used for method declarations
(define-honu-struct (member-decl ast) (name)) ; member-decl?
(define-honu-struct (field-decl member-decl) (type)) ; used for field declarations
(define-honu-struct (method-decl member-decl) (type arg-types)) ; used for method declarations
;; AST nodes for member definitions (in classes/mixins)
(define-honu-struct (member-defn ast) ()) ; member-defn?
(define-honu-struct (init-field member-defn) (name type value)) ; used for init fields (value can be #f or expression AST)
(define-honu-struct (field member-defn) (name type value)) ; used for fields (value can be #f or expression AST)
(define-honu-struct (method member-defn) (name type formals body)) ; used for methods
(define-honu-struct (member-defn ast) (name)) ; member-defn?
(define-honu-struct (init-field member-defn) (type value)) ; used for init fields (value can be #f or expression AST)
(define-honu-struct (field member-defn) (type value)) ; used for fields (value can be #f or expression AST)
(define-honu-struct (method member-defn) (type formals body)) ; used for methods
;; AST node for super call (just in mixins/subclasses)
(define-honu-struct (super-new ast) (args))

10
collects/honu/cce-notes.txt
View File

@ -1,8 +1,12 @@
Todo:
mixin sealing
improve test suite
numeric functionality
Mixin Sealing
- environments
- single value->type environment (remove class-env)
- implement applicative environments
- define type equality
Test Suite Improvements
Numeric Library
------------------------------------------------------------

6
collects/honu/parsers/post-parsing.ss
View File

@ -106,7 +106,7 @@
[(null? members) (values (reverse results) env)]
[(honu:method? (car members))
(let-values ([(methods remaining) (span honu:method? members)])
(let ([env (append (map honu:method-name methods) env)])
(let ([env (append (map honu:member-defn-name methods) env)])
(loop remaining
env
;; reverse is here just to keep the order
@ -115,9 +115,7 @@
members))
results))))]
[else
(let ([name (if (honu:field? (car members))
(honu:field-name (car members))
(honu:init-field-name (car members)))])
(let ([name (honu:member-defn-name (car members))])
(loop (cdr members)
(cons name env)
(cons (convert-static-member (car members) env) results)))])))

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

@ -142,9 +142,7 @@
printable-smembers)))))))))
(define (translate-member-formatter member indent-delta)
(let ([name (if (honu:field? member)
(honu:field-name member)
(honu:init-field-name member))])
(let ([name (honu:member-defn-name member)])
`(format "~a~a = ~a;"
(make-string (+ indent ,indent-delta) #\space)
(quote ,(syntax-e name))

14
collects/honu/private/typechecker/type-utils.ss
View File

@ -1,5 +1,6 @@
(module type-utils mzscheme
(require (lib "list.ss" "srfi" "1")
(require (prefix srfi1: (lib "list.ss" "srfi" "1"))
(lib "contract.ss")
(lib "plt-match.ss")
"../../ast.ss"
"../../readerr.ss"
@ -59,7 +60,7 @@
(if (null? args)
"void"
(string-append "<"
(fold (lambda (t i)
(srfi1:fold (lambda (t i)
(string-append i ", " (printable-type t)))
(printable-type (car args))
(cdr args))
@ -174,7 +175,7 @@
(match type-entry
[(struct tenv:type (_ supers _ _))
(let ([super-names (map get-type-name supers)])
(s:member (get-type-name t2) super-names tenv-key=?))])))
(srfi1:s:member (get-type-name t2) super-names tenv-key=?))])))
;; is t1 a (ref-trans-closed) subtype of t2?
(provide <:_P)
@ -254,6 +255,13 @@
(<:_P t t2))
(tenv:type-supers type-entry))))]
[else #f]))
(provide/contract [type-member-names (honu:type? . -> . (listof identifier?))])
(define (type-member-names type)
(let* ([entry (get-type-entry type)])
(map tenv:member-name
(append (tenv:type-members entry)
(tenv:type-inherited entry)))))
(provide iface-name)
(define (iface-name type)

67
collects/honu/private/typechecker/typecheck-class-utils.ss
View File

@ -11,8 +11,9 @@
"typecheck-parameters.ss"
"type-utils.ss")
(provide extend-cenv-with-type-members typecheck-members typecheck-supernew typecheck-exports)
(define (typecheck-exports cenv selftype init-impls exports)
(provide extend-lenv-with-type-members typecheck-members typecheck-supernew typecheck-exports)
(define (typecheck-exports lenv selftype init-impls exports)
(let loop ([impls init-impls]
[exports exports])
(cond
@ -46,7 +47,7 @@
(printable-type selftype))
(honu:ast-stx selftype))
(let ([type-entry (get-type-entry selftype)])
(typecheck-export cenv type-entry matched)
(typecheck-export lenv type-entry matched)
(if (not (null? non-matches))
(raise-read-error-with-stx
(format "Extra export statement for unimplemented type ~a"
@ -64,10 +65,10 @@
(honu:ast-stx (car exports)))
(let* ([type-entry (get-type-entry matched)]
[export (car exports)])
(typecheck-export cenv type-entry export)
(typecheck-export lenv type-entry export)
(loop non-matches (cdr exports)))))])))
(define (typecheck-export cenv type-entry export)
(define (typecheck-export lenv type-entry export)
;; make sure to use both defined members and inherited members here
(let loop ([type-members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
[export-binds (honu:export-binds export)])
@ -92,9 +93,9 @@
(tenv-key=? (tenv:member-name m)
(honu:exp-bind-new (car export-binds))))
type-members)]
[(cenv-entry) (cenv (honu:exp-bind-old (car export-binds)))])
[(lenv-entry) (lenv (honu:exp-bind-old (car export-binds)))])
(cond
[(not cenv-entry)
[(not lenv-entry)
(raise-read-error-with-stx
(format "No static member named ~a"
(printable-key (honu:exp-bind-old (car export-binds))))
@ -107,39 +108,39 @@
(honu:exp-bind-new (car export-binds)))]
;; if it's a method, then allow exporting a subtype
[(honu:type-disp? (tenv:member-type matched))
(if (<:_P cenv-entry (tenv:member-type matched))
(if (<:_P lenv-entry (tenv:member-type matched))
(loop non-matches (cdr export-binds))
(raise-read-error-with-stx
(format "Exported static member ~a has type ~a which is not a subtype of ~a's type ~a"
(printable-key (honu:exp-bind-old (car export-binds)))
(printable-type cenv-entry)
(printable-type lenv-entry)
(printable-key (tenv:member-name matched))
(printable-type (tenv:member-type matched)))
(honu:exp-bind-old (car export-binds))))]
;; for fields, we just do invariance until we get read-only fields
[else
(if (type-equal? cenv-entry (tenv:member-type matched))
(if (type-equal? lenv-entry (tenv:member-type matched))
(loop non-matches (cdr export-binds))
(raise-read-error-with-stx
(format "Exported static member ~a has type ~a which is not the same type as ~a's type ~a"
(printable-key (honu:exp-bind-old (car export-binds)))
(printable-type cenv-entry)
(printable-type lenv-entry)
(printable-key (tenv:member-name matched))
(printable-type (tenv:member-type matched)))
(honu:exp-bind-old (car export-binds))))]))])))
(define (extend-cenv-with-type-members cenv type)
(define (extend-lenv-with-type-members lenv type)
(let ([type-entry (get-type-entry type)])
(fold (lambda (m e)
(extend-fenv (tenv:member-name m)
(tenv:member-type m)
e))
cenv
lenv
(tenv:type-members type-entry))))
(define (typecheck-supernew cenv lenv withs supernew)
(define (typecheck-supernew lenv withs supernew)
(let loop ([withs withs]
[args (honu:super-new-args supernew)]
[checked-args '()])
@ -169,10 +170,9 @@
(printable-key (honu:name-arg-name (car args))))
(honu:name-arg-name (car args)))
(let ([first-arg (car args)])
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv])
(typecheck-expression lenv
(honu:formal-type matched)
(honu:name-arg-value first-arg)))])
(let-values ([(e1 t1) (typecheck-expression lenv
(honu:formal-type matched)
(honu:name-arg-value first-arg))])
(loop non-matches
(cdr args)
(cons (copy-struct honu:name-arg first-arg
@ -180,39 +180,39 @@
checked-args))))))])))
(define (typecheck-members cenv lenv selftype members)
(define (typecheck-members lenv selftype members)
(let loop ([members members]
[cenv cenv]
[lenv lenv]
[ret '()])
(cond
[(null? members)
(values (reverse ret) cenv)]
(values (reverse ret) lenv)]
[(or (honu:init-field? (car members))
(honu:field? (car members)))
(let ([member (typecheck-member cenv lenv selftype (car members))])
(let ([member (typecheck-member lenv selftype (car members))])
(loop (cdr members)
(extend-fenv (get-class-member-name (car members))
(get-class-member-type selftype (car members))
cenv)
lenv)
(cons member ret)))]
[(honu:method? (car members))
(let-values ([(methods remainder) (span honu:method? members)])
(let ([cenv (fold (lambda (m cenv)
(let ([lenv (fold (lambda (m lenv)
(extend-fenv (get-class-member-name m)
(get-class-member-type selftype m)
cenv))
cenv
lenv))
lenv
methods)])
(loop remainder
cenv
lenv
;; I only through the reverse in to keep the order the same.
;; it doesn't really matter.
(append (reverse (map (lambda (m)
(typecheck-member cenv lenv selftype m))
(typecheck-member lenv selftype m))
methods))
ret))))])))
(define (typecheck-member cenv lenv selftype member)
(define (typecheck-member lenv selftype member)
(match member
[(struct honu:init-field (stx name type value))
(if (not (type-valid? type))
@ -220,8 +220,7 @@
"Type of init field is undefined"
(honu:ast-stx type)))
(if value
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv])
(typecheck-expression lenv type value))])
(let-values ([(e1 t1) (typecheck-expression lenv type value)])
(copy-struct honu:init-field member
[honu:init-field-value e1]))
member)]
@ -230,8 +229,7 @@
(raise-read-error-with-stx
"Type of field is undefined"
(honu:ast-stx type)))
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv])
(typecheck-expression lenv type value))])
(let-values ([(e1 t1) (typecheck-expression lenv type value)])
(copy-struct honu:field member
[honu:field-value e1]))]
[(struct honu:method (stx name type args body))
@ -245,8 +243,7 @@
"Type of method argument is undefined"
(honu:ast-stx t))))
(map honu:formal-type args))
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv]
[current-return-type type])
(let-values ([(e1 t1) (parameterize ([current-return-type type])
(typecheck-expression (fold (lambda (arg fenv)
(extend-fenv (honu:formal-name arg)
(honu:formal-type arg)

2
collects/honu/private/typechecker/typecheck-expression.ss
View File

@ -328,7 +328,7 @@
(raise-honu-type-error stx ctype ret-type))))]
[(struct honu:member (stx 'my _ name _))
(cond
[((current-class-environment) name)
[(lenv name)
=>
(lambda (t)
(if (honu:type-disp? t)

9
collects/honu/private/typechecker/typecheck-parameters.ss
View File

@ -2,15 +2,6 @@
(provide (all-defined))
;; since the class-environment doesn't change within typecheck-expression, we make it a parameter
;; that we set before calling it.
;;
;; cenv : ((syntax/c symbol?) . -> . (union honu:type false/c))
;; static environment inside of a class or mixin definition
;; (i.e. for my.<id>)
(define current-class-environment (make-parameter (lambda (name) #f)))
;; since the return type only changes when we go into a lambda in typecheck-expression, we
;; make it a parameter also.
;;

91
collects/honu/private/typechecker/typechecker.ss
View File

@ -97,13 +97,7 @@
(match iface
[(struct honu:iface (stx name supers members))
(check-valid-types! "interface supertype" supers)
(let ([conflicting-name (get-first-non-unique-name (map (lambda (d)
(cond
[(honu:field-decl? d)
(honu:field-decl-name d)]
[(honu:method-decl? d)
(honu:method-decl-name d)]))
members))])
(let ([conflicting-name (get-first-non-unique-name (map honu:member-decl-name members))])
(if conflicting-name
(raise-read-error-with-stx
(format "Field/method name ~a used more than once"
@ -122,30 +116,22 @@
(check-valid-type! "class self-type" type)
(check-valid-types! "implemented type of class" impls)
(let ([conflicting-name (get-first-non-unique-name (append (map honu:formal-name inits)
(map (lambda (d)
(cond
[(honu:init-field? d)
(honu:init-field-name d)]
[(honu:field? d)
(honu:field-name d)]
[(honu:method? d)
(honu:method-name d)]))
members)))])
(map honu:member-defn-name members)))])
(if conflicting-name
(raise-read-error-with-stx
(format "Init/field/method name ~a used more than once"
(printable-key conflicting-name))
conflicting-name)))
(check-valid-types! "init slot type" (map honu:formal-type inits))
(let ([cenv (srfi1:fold (lambda (a e)
(let ([lenv (srfi1:fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
(lambda (n) #f)
inits)])
(let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))]
[(members cenv) (typecheck-members cenv lenv type members)])
(typecheck-exports cenv type impls exports)
[(members lenv) (typecheck-members lenv type members)])
(typecheck-exports lenv type impls exports)
(copy-struct honu:class class
[honu:class-members members])))]))
@ -160,14 +146,7 @@
(append (tenv:type-members arg-tentry)
(tenv:type-inherited arg-tentry)))
(map honu:formal-name inits)
(map (lambda (d)
(cond
[(honu:init-field? d)
(honu:init-field-name d)]
[(honu:field? d)
(honu:field-name d)]
[(honu:method? d)
(honu:method-name d)]))
(map honu:member-defn-name
(append members-before
members-after))))])
(if conflicting-name
@ -188,6 +167,20 @@
(format "Init name ~a used more than once in expected init slots"
(printable-key conflicting-name))
conflicting-name)))]))
;; check-distinct-names! : String [Listof Identifier] -> Void
;; Raises an error if any of the names are the same.
(define (check-distinct-names! desc names)
(cond
[(check-duplicate-identifier names) =>
(lambda (name)
(raise-read-error-with-stx (format "Duplicate name ~s found in ~s." name desc) name))]
[else (void)]))
;; check-distinct-types! : String [Listof Honu:Type] -> Void
;; Raises an error if any of the types are the same.
(define (check-distinct-types! desc types)
(check-distinct-names! desc (map honu:type-iface-name types)))
;; typecheck-mixin : Mixin -> Mixin
;; Typechecks a mixin definition and produces the annotated version.
@ -195,29 +188,35 @@
(match mixin
[(struct honu:mixin (stx name type arg-type final? impls inits withs
supernew members-before members-after exports))
(define members (append members-before members-after))
(define member-names (map honu:member-defn-name members))
(define init-names (map honu:formal-name inits))
(define super-member-names (type-member-names arg-type))
(check-valid-type! "mixin argument type" arg-type)
(check-valid-type! "mixin result type" type)
(check-valid-types! "mixin implemented type" impls)
(check-mixin-internal-names! mixin)
(check-valid-types! "init slot type" (map honu:formal-type inits))
(check-mixin-expected-init-names! mixin)
(check-valid-types! "type of expected init slot" (map honu:formal-type withs))
(let ([cenv (srfi1:fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
empty-fenv
inits)])
(let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))]
[(members-before cenv) (typecheck-members cenv lenv type members-before)]
[(supernew) (typecheck-supernew cenv lenv withs supernew)]
[(cenv) (extend-cenv-with-type-members cenv arg-type)]
[(members-after cenv) (typecheck-members cenv lenv type members-after)])
(typecheck-exports cenv type impls exports)
(copy-struct honu:mixin mixin
[honu:mixin-members-before members-before]
[honu:mixin-super-new supernew]
[honu:mixin-members-after members-after])))]))
(check-valid-types! "superclass init slot type" (map honu:formal-type withs))
(check-distinct-types! "mixin implemented types" impls)
(check-distinct-names! "internally visible member/init names"
(append super-member-names init-names member-names))
(check-distinct-names! "superclass init slot names"
(map honu:formal-name withs))
(let*-values ([(lenv) (wrap-lenv)]
[(lenv) (extend-fenv #'this type lenv)]
[(lenv) (srfi1:fold extend-fenv-honu:formal lenv inits)]
[(members-before lenv) (typecheck-members lenv type members-before)]
[(supernew) (typecheck-supernew lenv withs supernew)]
[(lenv) (extend-lenv-with-type-members lenv arg-type)]
[(members-after lenv) (typecheck-members lenv type members-after)])
(typecheck-exports lenv type impls exports)
(copy-struct honu:mixin mixin
[honu:mixin-members-before members-before]
[honu:mixin-super-new supernew]
[honu:mixin-members-after members-after]))]))
;; typecheck-subclass : Subclass -> Subclass
;; Typechecks a subclass definition and produces the annotated version.

21
collects/honu/tenv-utils.ss
View File

@ -4,6 +4,7 @@
"ast.ss"
"parameters.ss"
"tenv.ss"
"utils.ss"
"private/typechecker/type-utils.ss"
(lib "plt-match.ss")
(lib "struct.ss")
@ -20,15 +21,15 @@
;; can come from mdidefns
[(honu:init-field? d)
(make-honu:field-decl (honu:ast-stx d)
(honu:init-field-name d)
(honu:member-defn-name d)
(honu:init-field-type d))]
[(honu:field? d)
(make-honu:field-decl (honu:ast-stx d)
(honu:field-name d)
(honu:member-defn-name d)
(honu:field-type d))]
[(honu:method? d)
(make-honu:method-decl (honu:ast-stx d)
(honu:method-name d)
(honu:member-defn-name d)
(honu:method-type d)
(map honu:formal-type (honu:method-formals d)))]))
(map convert-to-decl (append inits mfidefns)))
@ -41,9 +42,7 @@
;; can come from inits
[(honu:formal? d) (honu:formal-name d)]
;; can come from mdidefns
[(honu:init-field? d) (honu:init-field-name d)]
[(honu:field? d) (honu:field-name d)]
[(honu:method? d) (honu:method-name d)]))
[(honu:member-defn? d) (honu:member-defn-name d)]))
(let ([binds (map (lambda (m)
(let ([name (grab-name m)])
(make-honu:exp-bind name name))) (append inits mdidefns members))])
@ -418,13 +417,9 @@
#f))
inits)
(map (lambda (d)
(if (not (honu:init-field-value d))
(make-tenv:init (honu:init-field-name d)
(honu:init-field-type d)
#f)
(make-tenv:init (honu:init-field-name d)
(honu:init-field-type d)
#t)))
(make-tenv:init (honu:member-defn-name d)
(honu:init-field-type d)
(not (false? (honu:init-field-value d)))))
init-fields))))
(define (generate-subclass-tenv defn)

5
collects/honu/tenv.ss
View File

@ -135,6 +135,7 @@
(format "Definition of ~a is not a type" (printable-key name))
name)]
[else entry]))))
(define (get-class-entry name)
(let ([entry (get-tenv-entry name)])
(cond
@ -200,6 +201,9 @@
value
(fenv name))))
(define (extend-fenv-honu:formal formal fenv)
(extend-fenv (honu:formal-name formal) (honu:formal-type formal) fenv))
(define empty-fenv (lambda (name) #f))
(provide (struct tenv:entry (stx))
@ -241,6 +245,7 @@
[wrap-lenv (-> fenv?)]
[empty-fenv fenv?]
[extend-fenv (identifier? honu:type? fenv? . -> . fenv?)]
[extend-fenv-honu:formal (honu:formal? fenv? . -> . fenv?)]
)
)

6
collects/honu/utils.ss
View File

@ -16,7 +16,8 @@
map-two-values
partition-first
unique?
curry)
curry
false?)
(define-syntax (define/p stx)
(syntax-case stx ()
@ -144,5 +145,8 @@
(define (curry f . args)
(lambda rest
(apply f (append args rest))))
(define (false? v)
(eq? v #f))
)